From a02230ab74a5bd57c3cfe8810c50ececb0d4fad5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 25 Jun 2009 20:45:43 +0300 Subject: [PATCH 001/624] initial commit --- README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 README diff --git a/README b/README new file mode 100644 index 00000000..e69de29b From 4ad1b2956e0846c4b76839b5279d21bf2d97f48a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 28 Jun 2009 01:55:14 +0300 Subject: [PATCH 002/624] Imported existing code, documentation incomplete --- .gitignore | 2 + LICENSE | 25 ++ README | 1 + Setup.lhs | 7 + Web/Restful.hs | 888 +++++++++++++++++++++++++++++++++++++++++++++++++ restful.cabal | 17 + 6 files changed, 940 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100755 Setup.lhs create mode 100644 Web/Restful.hs create mode 100644 restful.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..39b806f8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +*.swp diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2008, 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. diff --git a/README b/README index e69de29b..4ccea4d9 100644 --- a/README +++ b/README @@ -0,0 +1 @@ +A Restful front controller built on Hack. diff --git a/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Restful.hs b/Web/Restful.hs new file mode 100644 index 00000000..3e26bad6 --- /dev/null +++ b/Web/Restful.hs @@ -0,0 +1,888 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Lightweight framework for designing RESTful APIs. +-- +--------------------------------------------------------- +module Web.Restful + ( + -- * Request parsing + -- $param_overview + + -- ** Types + ParamError + , ParamName + , ParamValue + -- ** Parameter type class + , Parameter (..) + -- ** RequestParser helpers + , getParam + , postParam + , urlParam + , anyParam + , cookieParam + , identifier + , acceptedLanguages + , requestPath + -- ** Building actual request + , Request (..) + , Hack.RequestMethod (..) + , rawFiles + -- * Response construction + , Response (..) + , response + -- ** Helper 'Response' instances + -- *** Generic hierarchichal text + , Tree (..) + , IsTree (..) + -- *** Atom news feed + , AtomFeed (..) + , AtomFeedEntry (..) + -- *** Sitemap + , sitemap + , SitemapUrl (..) + , SitemapLoc (..) + , SitemapChangeFreq (..) + -- *** Generics + -- **** List/detail + , ListDetail (..) + , ItemList (..) + , ItemDetail (..) + , -- **** Multiple response types. + GenResponse (..) + -- * Defining an application + , ApplicationMonad + -- ** Routing + , addResource + -- ** Settings + , setHandler + , setRpxnowApiKey + , setUrlRewriter + , setHtmlWrapper + -- ** Engage + , run + ) where + +-- hideously long import list +import qualified Hack +import qualified Hack.Handler.CGI +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State hiding (gets) +import Data.List (intercalate) +import Web.Encodings +import Data.Maybe (isJust) +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as BS +import Data.Function.Predicate (equals) +import Data.Default +import qualified Web.Authenticate.Rpxnow as Rpxnow +import qualified Web.Authenticate.OpenId as OpenId +import Data.List.Split (splitOneOf) + +import Hack.Middleware.Gzip +import Hack.Middleware.CleanPath +import Hack.Middleware.Jsonp +import Hack.Middleware.ClientSession + +import Data.Time.Format +import Data.Time.Clock +import System.Locale +import Control.Applicative ((<$>), Applicative (..)) +import Control.Arrow (second) + +-- $param_overview +-- In Restful, all of the underlying parameter values are strings. They can +-- come from multiple sources: GET parameters, URL rewriting (FIXME: link), +-- cookies, etc. However, most applications eventually want to convert +-- those strings into something else, like 'Int's. Additionally, it is +-- often desirable to allow multiple values, or no value at all. +-- +-- That is what the parameter concept is for. A 'Parameter' is any value +-- which can be converted from a 'String', or list of 'String's. + +-- | Any kind of error message generated in the parsing stage. +type ParamError = String + +-- | In GET parameters, the key. In cookies, the cookie name. So on and so +-- forth. +type ParamName = String + +-- | The 'String' value of a parameter, such as cookie content. +type ParamValue = String + +-- | Anything which can be converted from a 'String' or list of 'String's. +-- +-- The default implementation of 'readParams' will error out if given +-- anything but 1 'ParamValue'. This is usually what you want. +-- +-- Minimal complete definition: either 'readParam' or 'readParams'. +class Parameter a where + -- | Convert a string into the desired value, or explain why that can't + -- happen. + readParam :: ParamValue -> Either ParamError a + readParam = readParams . return + + -- | Convert a list of strings into the desired value, or explain why + -- that can't happen. + readParams :: [ParamValue] -> Either ParamError a + readParams [x] = readParam x + readParams [] = Left "Missing parameter" + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 1" + +-- | Attempt to parse a list of param values using 'readParams'. +-- If that fails, return an error message and an undefined value. This way, +-- we can process all of the parameters and get all of the error messages. +-- Be careful not to use the value inside until you can be certain the +-- reading succeeded. +tryReadParams:: Parameter a + => ParamName + -> [ParamValue] + -> RequestParser a +tryReadParams name params = + case readParams params of + Left s -> do + tell [name ++ ": " ++ s] + return $ + error $ + "Trying to evaluate nonpresent parameter " ++ + name + Right x -> return x + +-- | Helper function for generating 'RequestParser's from various +-- 'ParamValue' lists. +genParam :: Parameter a + => (RawRequest -> ParamName -> [ParamValue]) + -> ParamName + -> RequestParser a +genParam f name = do + req <- ask + tryReadParams name $ f req name + +-- | Parse a value passed as a GET parameter. +getParam :: Parameter a => ParamName -> RequestParser a +getParam = genParam getParams + +-- | Parse a value passed as a POST parameter. +postParam :: Parameter a => ParamName -> RequestParser a +postParam = genParam postParams + +-- | Parse a value passed in the URL and extracted using rewrite. +-- (FIXME: link to rewrite section.) +urlParam :: Parameter a => ParamName -> RequestParser a +urlParam = genParam urlParams + +-- | Parse a value passed as a GET, POST or URL parameter. +anyParam :: Parameter a => ParamName -> RequestParser a +anyParam = genParam anyParams + +-- | Parse a value passed as a raw cookie. +cookieParam :: Parameter a => ParamName -> RequestParser a +cookieParam = genParam cookies + +-- | Parse a value in the hackHeader field. +hackHeaderParam :: Parameter a => ParamName -> RequestParser a +hackHeaderParam name = do + env <- parseEnv + let vals' = lookup name $ Hack.hackHeaders env + vals = case vals' of + Nothing -> [] + Just x -> [x] + tryReadParams name vals + +-- | Extract the cookie which specifies the identifier for a logged in +-- user. +identifier :: Parameter a => RequestParser a +identifier = hackHeaderParam authCookieName + +-- | Get the raw 'Hack.Env' value. +parseEnv :: RequestParser Hack.Env +parseEnv = rawEnv `fmap` ask + +-- | Determine the ordered list of language preferences. +-- +-- FIXME: Future versions should account for some cookie. +acceptedLanguages :: RequestParser [String] +acceptedLanguages = do + env <- parseEnv + let rawLang = tryLookup "" "Accept-Language" $ Hack.http env + return $! parseHttpAccept rawLang + +-- | Determinge the path requested by the user (ie, the path info). +requestPath :: RequestParser String +requestPath = do + env <- parseEnv + let q = case Hack.queryString env of + "" -> "" + q'@('?':_) -> q' + q' -> q' + return $! Hack.pathInfo env ++ q + +type RequestParser a = WriterT [ParamError] (Reader RawRequest) a +instance Applicative (WriterT [ParamError] (Reader RawRequest)) where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' + +-- | Parse a request into either the desired 'Request' or a list of errors. +runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a +runRequestParser p req = + let (val, errors) = (runReader (runWriterT p)) req + in case errors of + [] -> Right val + x -> Left x + +-- | The raw information passed through Hack, cleaned up a bit. +data RawRequest = RawRequest + { rawPathInfo :: PathInfo + , rawUrlParams :: [(ParamName, ParamValue)] + , rawGetParams :: [(ParamName, ParamValue)] + , rawPostParams :: [(ParamName, ParamValue)] + , rawCookies :: [(ParamName, ParamValue)] + , rawFiles :: [(ParamName, FileInfo)] + , rawEnv :: Hack.Env + } + +-- | All GET paramater values with the given name. +getParams :: RawRequest -> ParamName -> [ParamValue] +getParams rr name = map snd + . filter (\x -> name == fst x) + . rawGetParams + $ rr + +-- | All POST paramater values with the given name. +postParams :: RawRequest -> ParamName -> [ParamValue] +postParams rr name = map snd + . filter (\x -> name == fst x) + . rawPostParams + $ rr + +-- | All URL paramater values (see rewriting) with the given name. +urlParams :: RawRequest -> ParamName -> [ParamValue] +urlParams rr name = map snd + . filter (\x -> name == fst x) + . rawUrlParams + $ rr + +-- | All GET, POST and URL paramater values (see rewriting) with the given name. +anyParams :: RawRequest -> ParamName -> [ParamValue] +anyParams req name = urlParams req name ++ + getParams req name ++ + postParams req name + +-- | All cookies with the given name. +cookies :: RawRequest -> ParamName -> [ParamValue] +cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr + +instance Parameter a => Parameter (Maybe a) where + readParams [] = Right Nothing + readParams [x] = readParam x >>= return . Just + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 0 or 1" + +instance Parameter a => Parameter [a] where + readParams = mapM readParam + +instance Parameter String where + readParam = Right + +instance Parameter Int where + readParam s = case reads s of + ((x, _):_) -> Right x + _ -> Left $ "Invalid integer: " ++ s + +-- | The input for a resource. +-- +-- Each resource can define its own instance of 'Request' and then more +-- easily ensure that it received the correct input (ie, correct variables, +-- properly typed). +class Request a where + parseRequest :: RequestParser a + +instance Request () where + parseRequest = return () + +type ContentType = String + +-- | The output for a resource. +class Response a where + -- | Provide an ordered list of possible responses, depending on content + -- type. If the user asked for a specific response type (like + -- text/html), then that will get priority. If not, then the first + -- element in this list will be used. + reps :: a -> [(ContentType, Hack.Response)] + +-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be +-- used for the body. +response :: LazyByteString lbs + => Int + -> [(String, String)] + -> lbs + -> Hack.Response +response a b c = Hack.Response a b $ toLazyByteString c + +instance Response () where + reps _ = [("text/plain", response 200 [] "")] + +newtype ErrorResponse = ErrorResponse String +instance Response ErrorResponse where + reps (ErrorResponse s) = [("text/plain", response 500 [] s)] + +data ResponseWrapper = forall res. Response res => ResponseWrapper res +instance Response ResponseWrapper where + reps (ResponseWrapper res) = reps res + +-- | Contains settings and a list of resources. +type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) +instance Applicative ApplicationMonad where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' +data ApplicationSettings = ApplicationSettings + { hackHandler :: Hack.Application -> IO () + , rpxnowApiKey :: Maybe String + , encryptKey :: Either FilePath Word256 + , urlRewriter :: UrlRewriter + , hackMiddleware :: [Hack.Middleware] + , response404 :: Hack.Env -> IO Hack.Response + , htmlWrapper :: BS.ByteString -> BS.ByteString + } +instance Default ApplicationSettings where + def = ApplicationSettings + { hackHandler = Hack.Handler.CGI.run + , rpxnowApiKey = Nothing + , encryptKey = Left defaultKeyFile + , urlRewriter = \s -> (s, []) + , hackMiddleware = [gzip, cleanPath, jsonp] + , response404 = default404 + , htmlWrapper = id + } + +default404 :: Hack.Env -> IO Hack.Response +default404 env = return $ + Hack.Response + 404 + [("Content-Type", "text/plain")] + $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env + +data Handler = forall req res. (Request req, Response res) + => Handler (req -> IO res) +type LiftedHandler = RawRequest -> IO ResponseWrapper + +liftHandler :: + Handler + -> RawRequest + -> IO ResponseWrapper +liftHandler (Handler h) rr = do + case runRequestParser parseRequest rr of + Left errors -> return $ ResponseWrapper + $ ErrorResponse + $ unlines errors + Right req -> ResponseWrapper `fmap` h req + +type PathInfo = [String] +data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler + +-- FIXME document below here + +addResource :: (Request req, Response res) + => [Hack.RequestMethod] + -> PathInfo + -> (req -> IO res) + -> ApplicationMonad () +addResource methods path f = + tell [Resource methods path $ liftHandler $ Handler f] + +setUrlRewriter :: UrlRewriter -> ApplicationMonad () +setUrlRewriter newUrlRewriter = do + s <- get + put $ s { urlRewriter = newUrlRewriter } + +setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () +setHtmlWrapper f = do + s <- get + put $ s { htmlWrapper = f } + +run :: ApplicationMonad () -> IO () +run m = do + let (settings, resources') = runWriter $ execStateT m def + key <- case encryptKey settings of + Left f -> getKey f + Right k -> return k + let defApp = defaultResources settings + defResources = execWriter $ execStateT defApp def + resources = resources' ++ defResources + app' :: Hack.Application + app' = makeApplication' resources settings + clientsession' :: Hack.Middleware + clientsession' = clientsession [authCookieName] key + app :: Hack.Application + app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] + hackHandler settings app + +setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () +setHandler h = do + settings <- get + put $ settings { hackHandler = h } + +setRpxnowApiKey :: String -> ApplicationMonad () +setRpxnowApiKey k = do + settings <- get + put $ settings { rpxnowApiKey = Just k } + +defaultResources :: ApplicationSettings -> ApplicationMonad () +defaultResources settings = do + addResource [Hack.GET] ["auth", "check"] authCheck + addResource [Hack.GET] ["auth", "logout"] authLogout + addResource [Hack.GET] ["auth", "openid"] authOpenidForm + addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward + addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete + case rpxnowApiKey settings of + Nothing -> return () + Just key -> do + addResource [Hack.GET] ["auth", "login", "rpxnow"] $ + rpxnowLogin key + +data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +instance Request OIDFormReq where + parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" +instance Show OIDFormReq where + show (OIDFormReq Nothing _) = "" + show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ + "

" +data OIDFormRes = OIDFormRes String (Maybe String) +instance Response OIDFormRes where + reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] + where + heads = + case dest of + Nothing -> [] + Just dest' -> + [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] +authOpenidForm :: OIDFormReq -> IO OIDFormRes +authOpenidForm m@(OIDFormReq _ dest) = + let html = + show m ++ + "
" ++ + "OpenID: " ++ + "" ++ + "
" + in return $! OIDFormRes html dest +data OIDFReq = OIDFReq String String +instance Request OIDFReq where + parseRequest = do + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" + return $! OIDFReq oid complete +authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward (OIDFReq oid complete) = do + res <- OpenId.getForwardUrl oid complete :: IO (Either String String) + return $ + case res of + Left err -> RedirectResponse $ "/auth/openid/?message=" ++ + encodeUrl err + Right url -> RedirectResponse url + +data OIDComp = OIDComp [(String, String)] (Maybe String) +instance Request OIDComp where + parseRequest = do + rr <- ask + let gets = rawGetParams rr + dest <- cookieParam "DEST" + return $! OIDComp gets dest +data OIDCompRes = OIDCompResErr String + | OIDCompResGood String (Maybe String) +instance Response OIDCompRes where + reps (OIDCompResErr err) = + reps $ RedirectResponse + $ "/auth/openid/?message=" ++ + encodeUrl err + reps (OIDCompResGood ident Nothing) = + reps $ OIDCompResGood ident (Just "/") + reps (OIDCompResGood ident (Just dest)) = + [("text/plain", response 303 heads "")] where + heads = + [ (authCookieName, ident) + , resetCookie "DEST" + , ("Location", dest) + ] + +resetCookie :: String -> (String, String) +resetCookie name = + ("Set-Cookie", + name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") + +authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete (OIDComp gets' dest) = do + res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) + return $ + case res of + Left err -> OIDCompResErr err + Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + +-- | token dest +data RpxnowRequest = RpxnowRequest String (Maybe String) +instance Request RpxnowRequest where + parseRequest = do + token <- getParam "token" + dest <- getParam "dest" + return $! RpxnowRequest token $ chopHash `fmap` dest + +chopHash :: String -> String +chopHash ('#':rest) = rest +chopHash x = x + +-- | dest identifier +data RpxnowResponse = RpxnowResponse String (Maybe String) +instance Response RpxnowResponse where + reps (RpxnowResponse dest Nothing) = + [("text/html", response 303 [("Location", dest)] "")] + reps (RpxnowResponse dest (Just ident)) = + [("text/html", response 303 + [ ("Location", dest) + , (authCookieName, ident) + ] + "")] + +rpxnowLogin :: String -- ^ api key + -> RpxnowRequest + -> IO RpxnowResponse +rpxnowLogin apiKey (RpxnowRequest token dest') = do + let dest = case dest' of + Nothing -> "/" + Just "" -> "/" + Just s -> s + ident' <- Rpxnow.authenticate apiKey token + return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + +authCookieName :: String +authCookieName = "IDENTIFIER" + +data AuthRequest = AuthRequest (Maybe String) +instance Request AuthRequest where + parseRequest = AuthRequest `fmap` identifier + +authCheck :: AuthRequest -> IO Tree +authCheck (AuthRequest Nothing) = + return $ TreeMap [("status", TreeScalar "notloggedin")] +authCheck (AuthRequest (Just i)) = + return $ TreeMap $ + [ ("status", TreeScalar "loggedin") + , ("ident", TreeScalar i) + ] + +authLogout :: () -> IO LogoutResponse +authLogout _ = return LogoutResponse + +data LogoutResponse = LogoutResponse +instance Response LogoutResponse where + reps _ = map (second addCookie) $ reps tree where + tree = TreeMap [("status", TreeScalar "loggedout")] + addCookie (Hack.Response s h c) = + Hack.Response s (h':h) c + h' = resetCookie authCookieName + +makeApplication' :: [Resource] + -> ApplicationSettings + -> Hack.Env + -> IO Hack.Response +makeApplication' resources settings env = do + let method = Hack.requestMethod env + rr = envToRawRequest (urlRewriter settings) env + path' = rawPathInfo rr + isValid :: Resource -> Bool + isValid (Resource methods path _) = method `elem` methods + && path == path' + case filter isValid resources of + [Resource _ _ handler] -> do + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + body <- handler rr + let reps' = reps body + ctypes = filter (\c -> isJust $ lookup c reps') ctypes' + let handlerPair = + case ctypes of + [] -> Just $ head reps' + (c:_) -> + case filter (fst `equals` c) reps' of + [pair] -> Just pair + [] -> Nothing + _ -> error "Overlapping reps" + case handlerPair of + Nothing -> response404 settings $ env + Just (ctype, Hack.Response status headers content) -> do + let wrapper = + case ctype of + "text/html" -> htmlWrapper settings + _ -> id + return $ Hack.Response status + (("Content-Type", ctype) : headers) + $ toLazyByteString $ wrapper content + [] -> response404 settings $ env + _ -> fail "Overlapping handlers" + +type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) +envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest +envToRawRequest rewriter env = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + (pi', urls) = rewriter rawPieces + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = tryLookup "0" "Content-Length" $ Hack.http env + ctype = tryLookup "" "Content-Type" $ Hack.http env + (posts, files) = parsePost ctype clength + $ Hack.hackInput env + rawCookie = tryLookup "" "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + in RawRequest pi' urls gets' posts cookies' files env + +data Tree = TreeScalar String + | TreeList [Tree] + | TreeMap [(String, Tree)] +class IsTree a where + toTree :: a -> Tree + +treeToJson :: Tree -> String +treeToJson (TreeScalar s) = '"' : encodeJson s ++ "\"" +treeToJson (TreeList l) = + "[" ++ intercalate "," (map treeToJson l) ++ "]" +treeToJson (TreeMap m) = + "{" ++ intercalate "," (map helper m) ++ "}" where + helper (k, v) = + treeToJson (TreeScalar k) ++ + ":" ++ + treeToJson v + +treeToHtml :: Tree -> String +treeToHtml (TreeScalar s) = encodeHtml s +treeToHtml (TreeList l) = + "
    " ++ concatMap (\e -> "
  • " ++ treeToHtml e ++ "
    • ") l ++ + "
" +treeToHtml (TreeMap m) = + "
" ++ + concatMap (\(k, v) -> "
" ++ encodeHtml k ++ "
" ++ + "
" ++ treeToHtml v ++ "
") m ++ + "
" + +instance Response Tree where + reps tree = + [ ("text/html", response 200 [] $ treeToHtml tree) + , ("application/json", response 200 [] $ treeToJson tree) + ] + +parseHttpAccept :: String -> [String] +parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," + +specialHttpAccept :: String -> Bool +specialHttpAccept ('q':'=':_) = True +specialHttpAccept ('*':_) = True +specialHttpAccept _ = False + +data AtomFeed = AtomFeed + { atomTitle :: String + , atomLinkSelf :: String + , atomLinkHome :: String + , atomUpdated :: UTCTime + , atomEntries :: [AtomFeedEntry] + } +instance Response AtomFeed where + reps e = + [ ("application/atom+xml", response 200 [] $ show e) + ] + +data AtomFeedEntry = AtomFeedEntry + { atomEntryLink :: String + , atomEntryUpdated :: UTCTime + , atomEntryTitle :: String + , atomEntryContent :: String + } + +instance Show AtomFeed where + show f = concat + [ "\n" + , "" + , "" + , encodeHtml $ atomTitle f + , "" + , "" + , "" + , "" + , formatW3 $ atomUpdated f + , "" + , "" + , encodeHtml $ atomLinkHome f + , "" + , concatMap show $ atomEntries f + , "" + ] + +instance Show AtomFeedEntry where + show e = concat + [ "" + , "" + , encodeHtml $ atomEntryLink e + , "" + , "" + , "" + , formatW3 $ atomEntryUpdated e + , "" + , "" + , encodeHtml $ atomEntryTitle e + , "" + , "" + , "" + ] + +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" + +class IsTree a => ListDetail a where + htmlDetail :: a -> String + htmlDetail = treeToHtml . toTree + detailTitle :: a -> String + detailUrl :: a -> String + htmlList :: [a] -> String + htmlList l = "
    " ++ concatMap helper l ++ "
" + where + helper i = "
  • " ++ encodeHtml (detailTitle i) ++ + "
    • " + -- | Often times for the JSON response of the list, we don't need all + -- the information. + treeList :: [a] -> Tree + treeList = TreeList . map treeListSingle + treeListSingle :: a -> Tree + treeListSingle = toTree + +newtype ItemList a = ItemList [a] +instance ListDetail a => Response (ItemList a) where + reps (ItemList l) = + [ ("text/html", response 200 [] $ htmlList l) + , ("application/json", response 200 [] $ treeToJson $ treeList l) + ] +newtype ItemDetail a = ItemDetail a +instance ListDetail a => Response (ItemDetail a) where + reps (ItemDetail i) = + [ ("text/html", response 200 [] $ htmlDetail i) + , ("application/json", response 200 [] $ treeToJson $ toTree i) + ] + +-- sitemaps +data SitemapLoc = AbsLoc String | RelLoc String +data SitemapChangeFreq = Always + | Hourly + | Daily + | Weekly + | Monthly + | Yearly + | Never +instance Show SitemapChangeFreq where + show Always = "always" + show Hourly = "hourly" + show Daily = "daily" + show Weekly = "weekly" + show Monthly = "monthly" + show Yearly = "yearly" + show Never = "never" + +data SitemapUrl = SitemapUrl + { sitemapLoc :: SitemapLoc + , sitemapLastMod :: UTCTime + , sitemapChangeFreq :: SitemapChangeFreq + , priority :: Double + } +data SitemapRequest = SitemapRequest String Int +instance Request SitemapRequest where + parseRequest = do + env <- parseEnv + return $! SitemapRequest (Hack.serverName env) + (Hack.serverPort env) +data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] +instance Show SitemapResponse where + show (SitemapResponse (SitemapRequest host port) urls) = + "\n" ++ + "" ++ + concatMap helper urls ++ + "" + where + prefix = "http://" ++ host ++ + case port of + 80 -> "" + _ -> ":" ++ show port + helper (SitemapUrl loc modTime freq pri) = concat + [ "" + , encodeHtml $ showLoc loc + , "" + , formatW3 modTime + , "" + , show freq + , "" + , show pri + , "" + ] + showLoc (AbsLoc s) = s + showLoc (RelLoc s) = prefix ++ s + +instance Response SitemapResponse where + reps res = + [ ("text/xml", response 200 [] $ show res) + ] + +sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse +sitemap urls' req = do + urls <- urls' + return $ SitemapResponse req urls + +-- misc helper functions +tryLookup :: Eq k => v -> k -> [(k, v)] -> v +tryLookup v _ [] = v +tryLookup v k ((k', v'):rest) + | k == k' = v' + | otherwise = tryLookup v k rest + +data GenResponse = HtmlResponse String + | TreeResponse Tree + | HtmlOrTreeResponse String Tree + | RedirectResponse String + | PermissionDeniedResult String + | NotFoundResponse String +instance Response GenResponse where + reps (HtmlResponse h) = [("text/html", response 200 [] h)] + reps (TreeResponse t) = reps t + reps (HtmlOrTreeResponse h t) = + ("text/html", response 200 [] h) : reps t + reps (RedirectResponse url) = [("text/html", response 303 heads body)] + where + heads = [("Location", url)] + body = "

    Redirecting to " ++ encodeHtml url ++ "

    " + reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] + reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] diff --git a/restful.cabal b/restful.cabal new file mode 100644 index 00000000..d48ec210 --- /dev/null +++ b/restful.cabal @@ -0,0 +1,17 @@ +name: restful +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: A Restful front controller built on Hack. +category: Web +stability: unstable +cabal-version: >= 1.2 +build-type: Simple +homepage: http://github.com/snoyberg/restful/tree/master + +library + build-depends: base + exposed-modules: Web.Restful + ghc-options: -Wall From d99fa2d8bc5282afdcde16accc97340bbaa41714 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 2 Jul 2009 01:35:07 +0300 Subject: [PATCH 003/624] Updated build-depends list --- restful.cabal | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/restful.cabal b/restful.cabal index d48ec210..26910f74 100644 --- a/restful.cabal +++ b/restful.cabal @@ -12,6 +12,22 @@ build-type: Simple homepage: http://github.com/snoyberg/restful/tree/master library - build-depends: base + build-depends: base >= 4 && < 5, + old-locale >= 1.0.0.1, + time >= 1.1.3, + hack-middleware-clientsession, + hack-middleware-jsonp >= 0.0.1, + hack-middleware-cleanpath >= 0.0.1, + hack-middleware-gzip, + hack-handler-cgi >= 0.0.2, + hack >= 2009.5.19, + split >= 0.1.1, + authenticate >= 0.0.1, + data-default >= 0.2, + predicates >= 0.1, + bytestring >= 0.9.1.4, + bytestring-class, + web-encodings, + mtl >= 1.1.0.2 exposed-modules: Web.Restful ghc-options: -Wall From 019dca9968ec475688fc0a51683caa6941b33a94 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Aug 2009 09:23:30 +0300 Subject: [PATCH 004/624] Split into multiple modules --- Web/Restful.hs | 879 +------------------------------------ Web/Restful/Application.hs | 362 +++++++++++++++ Web/Restful/Constants.hs | 17 + Web/Restful/Request.hs | 271 ++++++++++++ Web/Restful/Response.hs | 293 +++++++++++++ Web/Restful/Utils.hs | 33 ++ restful.cabal | 10 +- 7 files changed, 992 insertions(+), 873 deletions(-) create mode 100644 Web/Restful/Application.hs create mode 100644 Web/Restful/Constants.hs create mode 100644 Web/Restful/Request.hs create mode 100644 Web/Restful/Response.hs create mode 100644 Web/Restful/Utils.hs diff --git a/Web/Restful.hs b/Web/Restful.hs index 3e26bad6..f4925cad 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverlappingInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful @@ -19,870 +13,13 @@ --------------------------------------------------------- module Web.Restful ( - -- * Request parsing - -- $param_overview - - -- ** Types - ParamError - , ParamName - , ParamValue - -- ** Parameter type class - , Parameter (..) - -- ** RequestParser helpers - , getParam - , postParam - , urlParam - , anyParam - , cookieParam - , identifier - , acceptedLanguages - , requestPath - -- ** Building actual request - , Request (..) - , Hack.RequestMethod (..) - , rawFiles - -- * Response construction - , Response (..) - , response - -- ** Helper 'Response' instances - -- *** Generic hierarchichal text - , Tree (..) - , IsTree (..) - -- *** Atom news feed - , AtomFeed (..) - , AtomFeedEntry (..) - -- *** Sitemap - , sitemap - , SitemapUrl (..) - , SitemapLoc (..) - , SitemapChangeFreq (..) - -- *** Generics - -- **** List/detail - , ListDetail (..) - , ItemList (..) - , ItemDetail (..) - , -- **** Multiple response types. - GenResponse (..) - -- * Defining an application - , ApplicationMonad - -- ** Routing - , addResource - -- ** Settings - , setHandler - , setRpxnowApiKey - , setUrlRewriter - , setHtmlWrapper - -- ** Engage - , run + module Data.Object + , module Web.Restful.Request + , module Web.Restful.Response + , module Web.Restful.Application ) where --- hideously long import list -import qualified Hack -import qualified Hack.Handler.CGI -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State hiding (gets) -import Data.List (intercalate) -import Web.Encodings -import Data.Maybe (isJust) -import Data.ByteString.Class -import qualified Data.ByteString.Lazy as BS -import Data.Function.Predicate (equals) -import Data.Default -import qualified Web.Authenticate.Rpxnow as Rpxnow -import qualified Web.Authenticate.OpenId as OpenId -import Data.List.Split (splitOneOf) - -import Hack.Middleware.Gzip -import Hack.Middleware.CleanPath -import Hack.Middleware.Jsonp -import Hack.Middleware.ClientSession - -import Data.Time.Format -import Data.Time.Clock -import System.Locale -import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) - --- $param_overview --- In Restful, all of the underlying parameter values are strings. They can --- come from multiple sources: GET parameters, URL rewriting (FIXME: link), --- cookies, etc. However, most applications eventually want to convert --- those strings into something else, like 'Int's. Additionally, it is --- often desirable to allow multiple values, or no value at all. --- --- That is what the parameter concept is for. A 'Parameter' is any value --- which can be converted from a 'String', or list of 'String's. - --- | Any kind of error message generated in the parsing stage. -type ParamError = String - --- | In GET parameters, the key. In cookies, the cookie name. So on and so --- forth. -type ParamName = String - --- | The 'String' value of a parameter, such as cookie content. -type ParamValue = String - --- | Anything which can be converted from a 'String' or list of 'String's. --- --- The default implementation of 'readParams' will error out if given --- anything but 1 'ParamValue'. This is usually what you want. --- --- Minimal complete definition: either 'readParam' or 'readParams'. -class Parameter a where - -- | Convert a string into the desired value, or explain why that can't - -- happen. - readParam :: ParamValue -> Either ParamError a - readParam = readParams . return - - -- | Convert a list of strings into the desired value, or explain why - -- that can't happen. - readParams :: [ParamValue] -> Either ParamError a - readParams [x] = readParam x - readParams [] = Left "Missing parameter" - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 1" - --- | Attempt to parse a list of param values using 'readParams'. --- If that fails, return an error message and an undefined value. This way, --- we can process all of the parameters and get all of the error messages. --- Be careful not to use the value inside until you can be certain the --- reading succeeded. -tryReadParams:: Parameter a - => ParamName - -> [ParamValue] - -> RequestParser a -tryReadParams name params = - case readParams params of - Left s -> do - tell [name ++ ": " ++ s] - return $ - error $ - "Trying to evaluate nonpresent parameter " ++ - name - Right x -> return x - --- | Helper function for generating 'RequestParser's from various --- 'ParamValue' lists. -genParam :: Parameter a - => (RawRequest -> ParamName -> [ParamValue]) - -> ParamName - -> RequestParser a -genParam f name = do - req <- ask - tryReadParams name $ f req name - --- | Parse a value passed as a GET parameter. -getParam :: Parameter a => ParamName -> RequestParser a -getParam = genParam getParams - --- | Parse a value passed as a POST parameter. -postParam :: Parameter a => ParamName -> RequestParser a -postParam = genParam postParams - --- | Parse a value passed in the URL and extracted using rewrite. --- (FIXME: link to rewrite section.) -urlParam :: Parameter a => ParamName -> RequestParser a -urlParam = genParam urlParams - --- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: Parameter a => ParamName -> RequestParser a -anyParam = genParam anyParams - --- | Parse a value passed as a raw cookie. -cookieParam :: Parameter a => ParamName -> RequestParser a -cookieParam = genParam cookies - --- | Parse a value in the hackHeader field. -hackHeaderParam :: Parameter a => ParamName -> RequestParser a -hackHeaderParam name = do - env <- parseEnv - let vals' = lookup name $ Hack.hackHeaders env - vals = case vals' of - Nothing -> [] - Just x -> [x] - tryReadParams name vals - --- | Extract the cookie which specifies the identifier for a logged in --- user. -identifier :: Parameter a => RequestParser a -identifier = hackHeaderParam authCookieName - --- | Get the raw 'Hack.Env' value. -parseEnv :: RequestParser Hack.Env -parseEnv = rawEnv `fmap` ask - --- | Determine the ordered list of language preferences. --- --- FIXME: Future versions should account for some cookie. -acceptedLanguages :: RequestParser [String] -acceptedLanguages = do - env <- parseEnv - let rawLang = tryLookup "" "Accept-Language" $ Hack.http env - return $! parseHttpAccept rawLang - --- | Determinge the path requested by the user (ie, the path info). -requestPath :: RequestParser String -requestPath = do - env <- parseEnv - let q = case Hack.queryString env of - "" -> "" - q'@('?':_) -> q' - q' -> q' - return $! Hack.pathInfo env ++ q - -type RequestParser a = WriterT [ParamError] (Reader RawRequest) a -instance Applicative (WriterT [ParamError] (Reader RawRequest)) where - pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' - --- | Parse a request into either the desired 'Request' or a list of errors. -runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a -runRequestParser p req = - let (val, errors) = (runReader (runWriterT p)) req - in case errors of - [] -> Right val - x -> Left x - --- | The raw information passed through Hack, cleaned up a bit. -data RawRequest = RawRequest - { rawPathInfo :: PathInfo - , rawUrlParams :: [(ParamName, ParamValue)] - , rawGetParams :: [(ParamName, ParamValue)] - , rawPostParams :: [(ParamName, ParamValue)] - , rawCookies :: [(ParamName, ParamValue)] - , rawFiles :: [(ParamName, FileInfo)] - , rawEnv :: Hack.Env - } - --- | All GET paramater values with the given name. -getParams :: RawRequest -> ParamName -> [ParamValue] -getParams rr name = map snd - . filter (\x -> name == fst x) - . rawGetParams - $ rr - --- | All POST paramater values with the given name. -postParams :: RawRequest -> ParamName -> [ParamValue] -postParams rr name = map snd - . filter (\x -> name == fst x) - . rawPostParams - $ rr - --- | All URL paramater values (see rewriting) with the given name. -urlParams :: RawRequest -> ParamName -> [ParamValue] -urlParams rr name = map snd - . filter (\x -> name == fst x) - . rawUrlParams - $ rr - --- | All GET, POST and URL paramater values (see rewriting) with the given name. -anyParams :: RawRequest -> ParamName -> [ParamValue] -anyParams req name = urlParams req name ++ - getParams req name ++ - postParams req name - --- | All cookies with the given name. -cookies :: RawRequest -> ParamName -> [ParamValue] -cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr - -instance Parameter a => Parameter (Maybe a) where - readParams [] = Right Nothing - readParams [x] = readParam x >>= return . Just - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 0 or 1" - -instance Parameter a => Parameter [a] where - readParams = mapM readParam - -instance Parameter String where - readParam = Right - -instance Parameter Int where - readParam s = case reads s of - ((x, _):_) -> Right x - _ -> Left $ "Invalid integer: " ++ s - --- | The input for a resource. --- --- Each resource can define its own instance of 'Request' and then more --- easily ensure that it received the correct input (ie, correct variables, --- properly typed). -class Request a where - parseRequest :: RequestParser a - -instance Request () where - parseRequest = return () - -type ContentType = String - --- | The output for a resource. -class Response a where - -- | Provide an ordered list of possible responses, depending on content - -- type. If the user asked for a specific response type (like - -- text/html), then that will get priority. If not, then the first - -- element in this list will be used. - reps :: a -> [(ContentType, Hack.Response)] - --- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be --- used for the body. -response :: LazyByteString lbs - => Int - -> [(String, String)] - -> lbs - -> Hack.Response -response a b c = Hack.Response a b $ toLazyByteString c - -instance Response () where - reps _ = [("text/plain", response 200 [] "")] - -newtype ErrorResponse = ErrorResponse String -instance Response ErrorResponse where - reps (ErrorResponse s) = [("text/plain", response 500 [] s)] - -data ResponseWrapper = forall res. Response res => ResponseWrapper res -instance Response ResponseWrapper where - reps (ResponseWrapper res) = reps res - --- | Contains settings and a list of resources. -type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) -instance Applicative ApplicationMonad where - pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' -data ApplicationSettings = ApplicationSettings - { hackHandler :: Hack.Application -> IO () - , rpxnowApiKey :: Maybe String - , encryptKey :: Either FilePath Word256 - , urlRewriter :: UrlRewriter - , hackMiddleware :: [Hack.Middleware] - , response404 :: Hack.Env -> IO Hack.Response - , htmlWrapper :: BS.ByteString -> BS.ByteString - } -instance Default ApplicationSettings where - def = ApplicationSettings - { hackHandler = Hack.Handler.CGI.run - , rpxnowApiKey = Nothing - , encryptKey = Left defaultKeyFile - , urlRewriter = \s -> (s, []) - , hackMiddleware = [gzip, cleanPath, jsonp] - , response404 = default404 - , htmlWrapper = id - } - -default404 :: Hack.Env -> IO Hack.Response -default404 env = return $ - Hack.Response - 404 - [("Content-Type", "text/plain")] - $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env - -data Handler = forall req res. (Request req, Response res) - => Handler (req -> IO res) -type LiftedHandler = RawRequest -> IO ResponseWrapper - -liftHandler :: - Handler - -> RawRequest - -> IO ResponseWrapper -liftHandler (Handler h) rr = do - case runRequestParser parseRequest rr of - Left errors -> return $ ResponseWrapper - $ ErrorResponse - $ unlines errors - Right req -> ResponseWrapper `fmap` h req - -type PathInfo = [String] -data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler - --- FIXME document below here - -addResource :: (Request req, Response res) - => [Hack.RequestMethod] - -> PathInfo - -> (req -> IO res) - -> ApplicationMonad () -addResource methods path f = - tell [Resource methods path $ liftHandler $ Handler f] - -setUrlRewriter :: UrlRewriter -> ApplicationMonad () -setUrlRewriter newUrlRewriter = do - s <- get - put $ s { urlRewriter = newUrlRewriter } - -setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () -setHtmlWrapper f = do - s <- get - put $ s { htmlWrapper = f } - -run :: ApplicationMonad () -> IO () -run m = do - let (settings, resources') = runWriter $ execStateT m def - key <- case encryptKey settings of - Left f -> getKey f - Right k -> return k - let defApp = defaultResources settings - defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources - app' :: Hack.Application - app' = makeApplication' resources settings - clientsession' :: Hack.Middleware - clientsession' = clientsession [authCookieName] key - app :: Hack.Application - app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] - hackHandler settings app - -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () -setHandler h = do - settings <- get - put $ settings { hackHandler = h } - -setRpxnowApiKey :: String -> ApplicationMonad () -setRpxnowApiKey k = do - settings <- get - put $ settings { rpxnowApiKey = Just k } - -defaultResources :: ApplicationSettings -> ApplicationMonad () -defaultResources settings = do - addResource [Hack.GET] ["auth", "check"] authCheck - addResource [Hack.GET] ["auth", "logout"] authLogout - addResource [Hack.GET] ["auth", "openid"] authOpenidForm - addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward - addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete - case rpxnowApiKey settings of - Nothing -> return () - Just key -> do - addResource [Hack.GET] ["auth", "login", "rpxnow"] $ - rpxnowLogin key - -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" -instance Show OIDFormReq where - show (OIDFormReq Nothing _) = "" - show (OIDFormReq (Just s) _) = "

    " ++ encodeHtml s ++ - "

    " -data OIDFormRes = OIDFormRes String (Maybe String) -instance Response OIDFormRes where - reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] - where - heads = - case dest of - Nothing -> [] - Just dest' -> - [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] -authOpenidForm :: OIDFormReq -> IO OIDFormRes -authOpenidForm m@(OIDFormReq _ dest) = - let html = - show m ++ - "
    " ++ - "OpenID: " ++ - "" ++ - "
    " - in return $! OIDFormRes html dest -data OIDFReq = OIDFReq String String -instance Request OIDFReq where - parseRequest = do - oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" - return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse -authOpenidForward (OIDFReq oid complete) = do - res <- OpenId.getForwardUrl oid complete :: IO (Either String String) - return $ - case res of - Left err -> RedirectResponse $ "/auth/openid/?message=" ++ - encodeUrl err - Right url -> RedirectResponse url - -data OIDComp = OIDComp [(String, String)] (Maybe String) -instance Request OIDComp where - parseRequest = do - rr <- ask - let gets = rawGetParams rr - dest <- cookieParam "DEST" - return $! OIDComp gets dest -data OIDCompRes = OIDCompResErr String - | OIDCompResGood String (Maybe String) -instance Response OIDCompRes where - reps (OIDCompResErr err) = - reps $ RedirectResponse - $ "/auth/openid/?message=" ++ - encodeUrl err - reps (OIDCompResGood ident Nothing) = - reps $ OIDCompResGood ident (Just "/") - reps (OIDCompResGood ident (Just dest)) = - [("text/plain", response 303 heads "")] where - heads = - [ (authCookieName, ident) - , resetCookie "DEST" - , ("Location", dest) - ] - -resetCookie :: String -> (String, String) -resetCookie name = - ("Set-Cookie", - name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") - -authOpenidComplete :: OIDComp -> IO OIDCompRes -authOpenidComplete (OIDComp gets' dest) = do - res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) - return $ - case res of - Left err -> OIDCompResErr err - Right (OpenId.Identifier ident) -> OIDCompResGood ident dest - --- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- getParam "token" - dest <- getParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - -chopHash :: String -> String -chopHash ('#':rest) = rest -chopHash x = x - --- | dest identifier -data RpxnowResponse = RpxnowResponse String (Maybe String) -instance Response RpxnowResponse where - reps (RpxnowResponse dest Nothing) = - [("text/html", response 303 [("Location", dest)] "")] - reps (RpxnowResponse dest (Just ident)) = - [("text/html", response 303 - [ ("Location", dest) - , (authCookieName, ident) - ] - "")] - -rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> IO RpxnowResponse -rpxnowLogin apiKey (RpxnowRequest token dest') = do - let dest = case dest' of - Nothing -> "/" - Just "" -> "/" - Just s -> s - ident' <- Rpxnow.authenticate apiKey token - return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') - -authCookieName :: String -authCookieName = "IDENTIFIER" - -data AuthRequest = AuthRequest (Maybe String) -instance Request AuthRequest where - parseRequest = AuthRequest `fmap` identifier - -authCheck :: AuthRequest -> IO Tree -authCheck (AuthRequest Nothing) = - return $ TreeMap [("status", TreeScalar "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ TreeMap $ - [ ("status", TreeScalar "loggedin") - , ("ident", TreeScalar i) - ] - -authLogout :: () -> IO LogoutResponse -authLogout _ = return LogoutResponse - -data LogoutResponse = LogoutResponse -instance Response LogoutResponse where - reps _ = map (second addCookie) $ reps tree where - tree = TreeMap [("status", TreeScalar "loggedout")] - addCookie (Hack.Response s h c) = - Hack.Response s (h':h) c - h' = resetCookie authCookieName - -makeApplication' :: [Resource] - -> ApplicationSettings - -> Hack.Env - -> IO Hack.Response -makeApplication' resources settings env = do - let method = Hack.requestMethod env - rr = envToRawRequest (urlRewriter settings) env - path' = rawPathInfo rr - isValid :: Resource -> Bool - isValid (Resource methods path _) = method `elem` methods - && path == path' - case filter isValid resources of - [Resource _ _ handler] -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- handler rr - let reps' = reps body - ctypes = filter (\c -> isJust $ lookup c reps') ctypes' - let handlerPair = - case ctypes of - [] -> Just $ head reps' - (c:_) -> - case filter (fst `equals` c) reps' of - [pair] -> Just pair - [] -> Nothing - _ -> error "Overlapping reps" - case handlerPair of - Nothing -> response404 settings $ env - Just (ctype, Hack.Response status headers content) -> do - let wrapper = - case ctype of - "text/html" -> htmlWrapper settings - _ -> id - return $ Hack.Response status - (("Content-Type", ctype) : headers) - $ toLazyByteString $ wrapper content - [] -> response404 settings $ env - _ -> fail "Overlapping handlers" - -type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) -envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest -envToRawRequest rewriter env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - (pi', urls) = rewriter rawPieces - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = tryLookup "0" "Content-Length" $ Hack.http env - ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = parsePost ctype clength - $ Hack.hackInput env - rawCookie = tryLookup "" "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest pi' urls gets' posts cookies' files env - -data Tree = TreeScalar String - | TreeList [Tree] - | TreeMap [(String, Tree)] -class IsTree a where - toTree :: a -> Tree - -treeToJson :: Tree -> String -treeToJson (TreeScalar s) = '"' : encodeJson s ++ "\"" -treeToJson (TreeList l) = - "[" ++ intercalate "," (map treeToJson l) ++ "]" -treeToJson (TreeMap m) = - "{" ++ intercalate "," (map helper m) ++ "}" where - helper (k, v) = - treeToJson (TreeScalar k) ++ - ":" ++ - treeToJson v - -treeToHtml :: Tree -> String -treeToHtml (TreeScalar s) = encodeHtml s -treeToHtml (TreeList l) = - "
      " ++ concatMap (\e -> "
    • " ++ treeToHtml e ++ "
      • ") l ++ - "
    " -treeToHtml (TreeMap m) = - "
    " ++ - concatMap (\(k, v) -> "
    " ++ encodeHtml k ++ "
    " ++ - "
    " ++ treeToHtml v ++ "
    ") m ++ - "
    " - -instance Response Tree where - reps tree = - [ ("text/html", response 200 [] $ treeToHtml tree) - , ("application/json", response 200 [] $ treeToJson tree) - ] - -parseHttpAccept :: String -> [String] -parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," - -specialHttpAccept :: String -> Bool -specialHttpAccept ('q':'=':_) = True -specialHttpAccept ('*':_) = True -specialHttpAccept _ = False - -data AtomFeed = AtomFeed - { atomTitle :: String - , atomLinkSelf :: String - , atomLinkHome :: String - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry] - } -instance Response AtomFeed where - reps e = - [ ("application/atom+xml", response 200 [] $ show e) - ] - -data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: String - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: String - } - -instance Show AtomFeed where - show f = concat - [ "\n" - , "" - , "" - , encodeHtml $ atomTitle f - , "" - , "" - , "" - , "" - , formatW3 $ atomUpdated f - , "" - , "" - , encodeHtml $ atomLinkHome f - , "" - , concatMap show $ atomEntries f - , "" - ] - -instance Show AtomFeedEntry where - show e = concat - [ "" - , "" - , encodeHtml $ atomEntryLink e - , "" - , "" - , "" - , formatW3 $ atomEntryUpdated e - , "" - , "" - , encodeHtml $ atomEntryTitle e - , "" - , "" - , "" - ] - -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" - -class IsTree a => ListDetail a where - htmlDetail :: a -> String - htmlDetail = treeToHtml . toTree - detailTitle :: a -> String - detailUrl :: a -> String - htmlList :: [a] -> String - htmlList l = "
      " ++ concatMap helper l ++ "
    " - where - helper i = "
  • " ++ encodeHtml (detailTitle i) ++ - "
    • " - -- | Often times for the JSON response of the list, we don't need all - -- the information. - treeList :: [a] -> Tree - treeList = TreeList . map treeListSingle - treeListSingle :: a -> Tree - treeListSingle = toTree - -newtype ItemList a = ItemList [a] -instance ListDetail a => Response (ItemList a) where - reps (ItemList l) = - [ ("text/html", response 200 [] $ htmlList l) - , ("application/json", response 200 [] $ treeToJson $ treeList l) - ] -newtype ItemDetail a = ItemDetail a -instance ListDetail a => Response (ItemDetail a) where - reps (ItemDetail i) = - [ ("text/html", response 200 [] $ htmlDetail i) - , ("application/json", response 200 [] $ treeToJson $ toTree i) - ] - --- sitemaps -data SitemapLoc = AbsLoc String | RelLoc String -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never -instance Show SitemapChangeFreq where - show Always = "always" - show Hourly = "hourly" - show Daily = "daily" - show Weekly = "weekly" - show Monthly = "monthly" - show Yearly = "yearly" - show Never = "never" - -data SitemapUrl = SitemapUrl - { sitemapLoc :: SitemapLoc - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } -data SitemapRequest = SitemapRequest String Int -instance Request SitemapRequest where - parseRequest = do - env <- parseEnv - return $! SitemapRequest (Hack.serverName env) - (Hack.serverPort env) -data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] -instance Show SitemapResponse where - show (SitemapResponse (SitemapRequest host port) urls) = - "\n" ++ - "" ++ - concatMap helper urls ++ - "" - where - prefix = "http://" ++ host ++ - case port of - 80 -> "" - _ -> ":" ++ show port - helper (SitemapUrl loc modTime freq pri) = concat - [ "" - , encodeHtml $ showLoc loc - , "" - , formatW3 modTime - , "" - , show freq - , "" - , show pri - , "" - ] - showLoc (AbsLoc s) = s - showLoc (RelLoc s) = prefix ++ s - -instance Response SitemapResponse where - reps res = - [ ("text/xml", response 200 [] $ show res) - ] - -sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse -sitemap urls' req = do - urls <- urls' - return $ SitemapResponse req urls - --- misc helper functions -tryLookup :: Eq k => v -> k -> [(k, v)] -> v -tryLookup v _ [] = v -tryLookup v k ((k', v'):rest) - | k == k' = v' - | otherwise = tryLookup v k rest - -data GenResponse = HtmlResponse String - | TreeResponse Tree - | HtmlOrTreeResponse String Tree - | RedirectResponse String - | PermissionDeniedResult String - | NotFoundResponse String -instance Response GenResponse where - reps (HtmlResponse h) = [("text/html", response 200 [] h)] - reps (TreeResponse t) = reps t - reps (HtmlOrTreeResponse h t) = - ("text/html", response 200 [] h) : reps t - reps (RedirectResponse url) = [("text/html", response 303 heads body)] - where - heads = [("Location", url)] - body = "

    Redirecting to " ++ encodeHtml url ++ "

    " - reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] - reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] +import Data.Object +import Web.Restful.Request +import Web.Restful.Response +import Web.Restful.Application diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs new file mode 100644 index 00000000..84c30672 --- /dev/null +++ b/Web/Restful/Application.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Application +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Defining the application. +-- +--------------------------------------------------------- +module Web.Restful.Application + ( + -- * Defining an application + ApplicationMonad + -- ** Routing + , addResource + -- ** Settings + , setHandler + , setRpxnowApiKey + , setUrlRewriter + , setHtmlWrapper + -- ** Engage + , run + ) where + +-- hideously long import list +import qualified Hack +import qualified Hack.Handler.CGI +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State hiding (gets) +import Web.Encodings +import Data.Maybe (isJust) +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as BS +import Data.Function.Predicate (equals) +import Data.Default +import qualified Web.Authenticate.Rpxnow as Rpxnow +import qualified Web.Authenticate.OpenId as OpenId + +import Hack.Middleware.Gzip +import Hack.Middleware.CleanPath +import Hack.Middleware.Jsonp +import Hack.Middleware.ClientSession + +import Control.Applicative ((<$>), Applicative (..)) +import Control.Arrow (second) + +import Web.Restful.Request +import Web.Restful.Response +import Web.Restful.Constants +import Web.Restful.Utils +import Data.Object + +-- | Contains settings and a list of resources. +type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) +instance Applicative ApplicationMonad where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' +data ApplicationSettings = ApplicationSettings + { hackHandler :: Hack.Application -> IO () + , rpxnowApiKey :: Maybe String + , encryptKey :: Either FilePath Word256 + , urlRewriter :: UrlRewriter + , hackMiddleware :: [Hack.Middleware] + , response404 :: Hack.Env -> IO Hack.Response + , htmlWrapper :: BS.ByteString -> BS.ByteString + } +instance Default ApplicationSettings where + def = ApplicationSettings + { hackHandler = Hack.Handler.CGI.run + , rpxnowApiKey = Nothing + , encryptKey = Left defaultKeyFile + , urlRewriter = \s -> (s, []) + , hackMiddleware = [gzip, cleanPath, jsonp] + , response404 = default404 + , htmlWrapper = id + } + +default404 :: Hack.Env -> IO Hack.Response +default404 env = return $ + Hack.Response + 404 + [("Content-Type", "text/plain")] + $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env + +data Handler = forall req res. (Request req, Response res) + => Handler (req -> IO res) +type LiftedHandler = RawRequest -> IO ResponseWrapper + +liftHandler :: + Handler + -> RawRequest + -> IO ResponseWrapper +liftHandler (Handler h) rr = do + case runRequestParser parseRequest rr of + Left errors -> return $ ResponseWrapper + $ ErrorResponse + $ unlines errors + Right req -> ResponseWrapper `fmap` h req + +data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler + +-- FIXME document below here + +addResource :: (Request req, Response res) + => [Hack.RequestMethod] + -> PathInfo + -> (req -> IO res) + -> ApplicationMonad () +addResource methods path f = + tell [Resource methods path $ liftHandler $ Handler f] + +setUrlRewriter :: UrlRewriter -> ApplicationMonad () +setUrlRewriter newUrlRewriter = do + s <- get + put $ s { urlRewriter = newUrlRewriter } + +setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () +setHtmlWrapper f = do + s <- get + put $ s { htmlWrapper = f } + +run :: ApplicationMonad () -> IO () +run m = do + let (settings, resources') = runWriter $ execStateT m def + key <- case encryptKey settings of + Left f -> getKey f + Right k -> return k + let defApp = defaultResources settings + defResources = execWriter $ execStateT defApp def + resources = resources' ++ defResources + app' :: Hack.Application + app' = makeApplication' resources settings + clientsession' :: Hack.Middleware + clientsession' = clientsession [authCookieName] key + app :: Hack.Application + app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] + hackHandler settings app + +setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () +setHandler h = do + settings <- get + put $ settings { hackHandler = h } + +setRpxnowApiKey :: String -> ApplicationMonad () +setRpxnowApiKey k = do + settings <- get + put $ settings { rpxnowApiKey = Just k } + +defaultResources :: ApplicationSettings -> ApplicationMonad () +defaultResources settings = do + addResource [Hack.GET] ["auth", "check"] authCheck + addResource [Hack.GET] ["auth", "logout"] authLogout + addResource [Hack.GET] ["auth", "openid"] authOpenidForm + addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward + addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete + case rpxnowApiKey settings of + Nothing -> return () + Just key -> do + addResource [Hack.GET] ["auth", "login", "rpxnow"] $ + rpxnowLogin key + +data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +instance Request OIDFormReq where + parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" +instance Show OIDFormReq where + show (OIDFormReq Nothing _) = "" + show (OIDFormReq (Just s) _) = "

    " ++ encodeHtml s ++ + "

    " +data OIDFormRes = OIDFormRes String (Maybe String) +instance Response OIDFormRes where + reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] + where + heads = + case dest of + Nothing -> [] + Just dest' -> + [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] +authOpenidForm :: OIDFormReq -> IO OIDFormRes +authOpenidForm m@(OIDFormReq _ dest) = + let html = + show m ++ + "
    " ++ + "OpenID: " ++ + "" ++ + "
    " + in return $! OIDFormRes html dest +data OIDFReq = OIDFReq String String +instance Request OIDFReq where + parseRequest = do + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" + return $! OIDFReq oid complete +authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward (OIDFReq oid complete) = do + res <- OpenId.getForwardUrl oid complete :: IO (Either String String) + return $ + case res of + Left err -> RedirectResponse $ "/auth/openid/?message=" ++ + encodeUrl err + Right url -> RedirectResponse url + +data OIDComp = OIDComp [(String, String)] (Maybe String) +instance Request OIDComp where + parseRequest = do + rr <- ask + let gets = rawGetParams rr + dest <- cookieParam "DEST" + return $! OIDComp gets dest +data OIDCompRes = OIDCompResErr String + | OIDCompResGood String (Maybe String) +instance Response OIDCompRes where + reps (OIDCompResErr err) = + reps $ RedirectResponse + $ "/auth/openid/?message=" ++ + encodeUrl err + reps (OIDCompResGood ident Nothing) = + reps $ OIDCompResGood ident (Just "/") + reps (OIDCompResGood ident (Just dest)) = + [("text/plain", response 303 heads "")] where + heads = + [ (authCookieName, ident) + , resetCookie "DEST" + , ("Location", dest) + ] + +resetCookie :: String -> (String, String) +resetCookie name = + ("Set-Cookie", + name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") + +authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete (OIDComp gets' dest) = do + res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) + return $ + case res of + Left err -> OIDCompResErr err + Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + +-- | token dest +data RpxnowRequest = RpxnowRequest String (Maybe String) +instance Request RpxnowRequest where + parseRequest = do + token <- getParam "token" + dest <- getParam "dest" + return $! RpxnowRequest token $ chopHash `fmap` dest + +chopHash :: String -> String +chopHash ('#':rest) = rest +chopHash x = x + +-- | dest identifier +data RpxnowResponse = RpxnowResponse String (Maybe String) +instance Response RpxnowResponse where + reps (RpxnowResponse dest Nothing) = + [("text/html", response 303 [("Location", dest)] "")] + reps (RpxnowResponse dest (Just ident)) = + [("text/html", response 303 + [ ("Location", dest) + , (authCookieName, ident) + ] + "")] + +rpxnowLogin :: String -- ^ api key + -> RpxnowRequest + -> IO RpxnowResponse +rpxnowLogin apiKey (RpxnowRequest token dest') = do + let dest = case dest' of + Nothing -> "/" + Just "" -> "/" + Just s -> s + ident' <- Rpxnow.authenticate apiKey token + return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + +data AuthRequest = AuthRequest (Maybe String) +instance Request AuthRequest where + parseRequest = AuthRequest `fmap` identifier + +authCheck :: AuthRequest -> IO Object +authCheck (AuthRequest Nothing) = + return $ toObject [("status", "notloggedin")] +authCheck (AuthRequest (Just i)) = + return $ toObject + [ ("status", "loggedin") + , ("ident", i) + ] + +authLogout :: () -> IO LogoutResponse +authLogout _ = return LogoutResponse + +data LogoutResponse = LogoutResponse +instance Response LogoutResponse where + reps _ = map (second addCookie) $ reps tree where + tree = toObject [("status", "loggedout")] + addCookie (Hack.Response s h c) = + Hack.Response s (h':h) c + h' = resetCookie authCookieName + +makeApplication' :: [Resource] + -> ApplicationSettings + -> Hack.Env + -> IO Hack.Response +makeApplication' resources settings env = do + let method = Hack.requestMethod env + rr = envToRawRequest (urlRewriter settings) env + path' = rawPathInfo rr + isValid :: Resource -> Bool + isValid (Resource methods path _) = method `elem` methods + && path == path' + case filter isValid resources of + [Resource _ _ handler] -> do + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + body <- handler rr + let reps' = reps body + ctypes = filter (\c -> isJust $ lookup c reps') ctypes' + let handlerPair = + case ctypes of + [] -> Just $ head reps' + (c:_) -> + case filter (fst `equals` c) reps' of + [pair] -> Just pair + [] -> Nothing + _ -> error "Overlapping reps" + case handlerPair of + Nothing -> response404 settings $ env + Just (ctype, Hack.Response status headers content) -> do + let wrapper = + case ctype of + "text/html" -> htmlWrapper settings + _ -> id + return $ Hack.Response status + (("Content-Type", ctype) : headers) + $ toLazyByteString $ wrapper content + [] -> response404 settings $ env + _ -> fail "Overlapping handlers" + +type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) +envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest +envToRawRequest rewriter env = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + (pi', urls) = rewriter rawPieces + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = tryLookup "0" "Content-Length" $ Hack.http env + ctype = tryLookup "" "Content-Type" $ Hack.http env + (posts, files) = parsePost ctype clength + $ Hack.hackInput env + rawCookie = tryLookup "" "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + in RawRequest pi' urls gets' posts cookies' files env diff --git a/Web/Restful/Constants.hs b/Web/Restful/Constants.hs new file mode 100644 index 00000000..c39aa532 --- /dev/null +++ b/Web/Restful/Constants.hs @@ -0,0 +1,17 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Constants +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Constants used throughout Restful. +-- +--------------------------------------------------------- +module Web.Restful.Constants where + +authCookieName :: String +authCookieName = "IDENTIFIER" diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs new file mode 100644 index 00000000..9f98849b --- /dev/null +++ b/Web/Restful/Request.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Request +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Code for extracting parameters from requests. +-- +--------------------------------------------------------- +module Web.Restful.Request + ( + -- * Request parsing + -- $param_overview + + -- ** Types + ParamError + , ParamName + , ParamValue + -- ** Parameter type class + , Parameter (..) + -- ** RequestParser helpers + , getParam + , postParam + , urlParam + , anyParam + , cookieParam + , identifier + , acceptedLanguages + , requestPath + -- ** Building actual request + , Request (..) + , Hack.RequestMethod (..) + -- ** FIXME + , parseEnv + , RawRequest (..) + , PathInfo + , runRequestParser + ) where + +import qualified Hack +import Data.Function.Predicate (equals) +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Error () +import Web.Restful.Constants +import Web.Restful.Utils +import Control.Applicative (Applicative (..)) +import Web.Encodings + +-- $param_overview +-- In Restful, all of the underlying parameter values are strings. They can +-- come from multiple sources: GET parameters, URL rewriting (FIXME: link), +-- cookies, etc. However, most applications eventually want to convert +-- those strings into something else, like 'Int's. Additionally, it is +-- often desirable to allow multiple values, or no value at all. +-- +-- That is what the parameter concept is for. A 'Parameter' is any value +-- which can be converted from a 'String', or list of 'String's. + +-- | Any kind of error message generated in the parsing stage. +type ParamError = String + +-- | In GET parameters, the key. In cookies, the cookie name. So on and so +-- forth. +type ParamName = String + +-- | The 'String' value of a parameter, such as cookie content. +type ParamValue = String + +-- | Anything which can be converted from a 'String' or list of 'String's. +-- +-- The default implementation of 'readParams' will error out if given +-- anything but 1 'ParamValue'. This is usually what you want. +-- +-- Minimal complete definition: either 'readParam' or 'readParams'. +class Parameter a where + -- | Convert a string into the desired value, or explain why that can't + -- happen. + readParam :: ParamValue -> Either ParamError a + readParam = readParams . return + + -- | Convert a list of strings into the desired value, or explain why + -- that can't happen. + readParams :: [ParamValue] -> Either ParamError a + readParams [x] = readParam x + readParams [] = Left "Missing parameter" + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 1" + +-- | Attempt to parse a list of param values using 'readParams'. +-- If that fails, return an error message and an undefined value. This way, +-- we can process all of the parameters and get all of the error messages. +-- Be careful not to use the value inside until you can be certain the +-- reading succeeded. +tryReadParams:: Parameter a + => ParamName + -> [ParamValue] + -> RequestParser a +tryReadParams name params = + case readParams params of + Left s -> do + tell [name ++ ": " ++ s] + return $ + error $ + "Trying to evaluate nonpresent parameter " ++ + name + Right x -> return x + +-- | Helper function for generating 'RequestParser's from various +-- 'ParamValue' lists. +genParam :: Parameter a + => (RawRequest -> ParamName -> [ParamValue]) + -> ParamName + -> RequestParser a +genParam f name = do + req <- ask + tryReadParams name $ f req name + +-- | Parse a value passed as a GET parameter. +getParam :: Parameter a => ParamName -> RequestParser a +getParam = genParam getParams + +-- | Parse a value passed as a POST parameter. +postParam :: Parameter a => ParamName -> RequestParser a +postParam = genParam postParams + +-- | Parse a value passed in the URL and extracted using rewrite. +-- (FIXME: link to rewrite section.) +urlParam :: Parameter a => ParamName -> RequestParser a +urlParam = genParam urlParams + +-- | Parse a value passed as a GET, POST or URL parameter. +anyParam :: Parameter a => ParamName -> RequestParser a +anyParam = genParam anyParams + +-- | Parse a value passed as a raw cookie. +cookieParam :: Parameter a => ParamName -> RequestParser a +cookieParam = genParam cookies + +-- | Parse a value in the hackHeader field. +hackHeaderParam :: Parameter a => ParamName -> RequestParser a +hackHeaderParam name = do + env <- parseEnv + let vals' = lookup name $ Hack.hackHeaders env + vals = case vals' of + Nothing -> [] + Just x -> [x] + tryReadParams name vals + +-- | Extract the cookie which specifies the identifier for a logged in +-- user. +identifier :: Parameter a => RequestParser a +identifier = hackHeaderParam authCookieName + +-- | Get the raw 'Hack.Env' value. +parseEnv :: RequestParser Hack.Env +parseEnv = rawEnv `fmap` ask + +-- | Determine the ordered list of language preferences. +-- +-- FIXME: Future versions should account for some cookie. +acceptedLanguages :: RequestParser [String] +acceptedLanguages = do + env <- parseEnv + let rawLang = tryLookup "" "Accept-Language" $ Hack.http env + return $! parseHttpAccept rawLang + +-- | Determinge the path requested by the user (ie, the path info). +requestPath :: RequestParser String +requestPath = do + env <- parseEnv + let q = case Hack.queryString env of + "" -> "" + q'@('?':_) -> q' + q' -> q' + return $! Hack.pathInfo env ++ q + +type RequestParser a = WriterT [ParamError] (Reader RawRequest) a +instance Applicative (WriterT [ParamError] (Reader RawRequest)) where + pure = return + f <*> a = do + f' <- f + a' <- a + return $! f' a' + +-- | Parse a request into either the desired 'Request' or a list of errors. +runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a +runRequestParser p req = + let (val, errors) = (runReader (runWriterT p)) req + in case errors of + [] -> Right val + x -> Left x + +-- | The raw information passed through Hack, cleaned up a bit. +data RawRequest = RawRequest + { rawPathInfo :: PathInfo + , rawUrlParams :: [(ParamName, ParamValue)] + , rawGetParams :: [(ParamName, ParamValue)] + , rawPostParams :: [(ParamName, ParamValue)] + , rawCookies :: [(ParamName, ParamValue)] + , rawFiles :: [(ParamName, FileInfo)] + , rawEnv :: Hack.Env + } + +-- | All GET paramater values with the given name. +getParams :: RawRequest -> ParamName -> [ParamValue] +getParams rr name = map snd + . filter (\x -> name == fst x) + . rawGetParams + $ rr + +-- | All POST paramater values with the given name. +postParams :: RawRequest -> ParamName -> [ParamValue] +postParams rr name = map snd + . filter (\x -> name == fst x) + . rawPostParams + $ rr + +-- | All URL paramater values (see rewriting) with the given name. +urlParams :: RawRequest -> ParamName -> [ParamValue] +urlParams rr name = map snd + . filter (\x -> name == fst x) + . rawUrlParams + $ rr + +-- | All GET, POST and URL paramater values (see rewriting) with the given name. +anyParams :: RawRequest -> ParamName -> [ParamValue] +anyParams req name = urlParams req name ++ + getParams req name ++ + postParams req name + +-- | All cookies with the given name. +cookies :: RawRequest -> ParamName -> [ParamValue] +cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr + +instance Parameter a => Parameter (Maybe a) where + readParams [] = Right Nothing + readParams [x] = readParam x >>= return . Just + readParams xs = Left $ "Given " ++ show (length xs) ++ + " values, expecting 0 or 1" + +instance Parameter a => Parameter [a] where + readParams = mapM readParam + +instance Parameter String where + readParam = Right + +instance Parameter Int where + readParam s = case reads s of + ((x, _):_) -> Right x + _ -> Left $ "Invalid integer: " ++ s + +-- | The input for a resource. +-- +-- Each resource can define its own instance of 'Request' and then more +-- easily ensure that it received the correct input (ie, correct variables, +-- properly typed). +class Request a where + parseRequest :: RequestParser a + +instance Request () where + parseRequest = return () + +type PathInfo = [String] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs new file mode 100644 index 00000000..8fd46e7c --- /dev/null +++ b/Web/Restful/Response.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating responses. +-- +--------------------------------------------------------- +module Web.Restful.Response + ( + -- * Response construction + Response (..) + , response + -- ** Helper 'Response' instances + -- *** Atom news feed + , AtomFeed (..) + , AtomFeedEntry (..) + -- *** Sitemap + , sitemap + , SitemapUrl (..) + , SitemapLoc (..) + , SitemapChangeFreq (..) + -- *** Generics + -- **** List/detail + , ListDetail (..) + , ItemList (..) + , ItemDetail (..) + -- **** Multiple response types. + , GenResponse (..) + -- * FIXME + , ResponseWrapper (..) + , ErrorResponse (..) + ) where + +import Data.ByteString.Class +import qualified Hack +import Data.Time.Format +import Data.Time.Clock +import Web.Encodings +import System.Locale +import Web.Restful.Request -- FIXME ultimately remove +import Data.Object +import Data.List (intercalate) + +type ContentType = String + +-- | The output for a resource. +class Response a where + -- | Provide an ordered list of possible responses, depending on content + -- type. If the user asked for a specific response type (like + -- text/html), then that will get priority. If not, then the first + -- element in this list will be used. + reps :: a -> [(ContentType, Hack.Response)] + +-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be +-- used for the body. +response :: LazyByteString lbs + => Int + -> [(String, String)] + -> lbs + -> Hack.Response +response a b c = Hack.Response a b $ toLazyByteString c + +instance Response () where + reps _ = [("text/plain", response 200 [] "")] + +newtype ErrorResponse = ErrorResponse String +instance Response ErrorResponse where + reps (ErrorResponse s) = [("text/plain", response 500 [] s)] + +data ResponseWrapper = forall res. Response res => ResponseWrapper res +instance Response ResponseWrapper where + reps (ResponseWrapper res) = reps res + +data AtomFeed = AtomFeed + { atomTitle :: String + , atomLinkSelf :: String + , atomLinkHome :: String + , atomUpdated :: UTCTime + , atomEntries :: [AtomFeedEntry] + } +instance Response AtomFeed where + reps e = + [ ("application/atom+xml", response 200 [] $ show e) + ] + +data AtomFeedEntry = AtomFeedEntry + { atomEntryLink :: String + , atomEntryUpdated :: UTCTime + , atomEntryTitle :: String + , atomEntryContent :: String + } + +instance Show AtomFeed where + show f = concat + [ "\n" + , "" + , "" + , encodeHtml $ atomTitle f + , "" + , "" + , "" + , "" + , formatW3 $ atomUpdated f + , "" + , "" + , encodeHtml $ atomLinkHome f + , "" + , concatMap show $ atomEntries f + , "" + ] + +instance Show AtomFeedEntry where + show e = concat + [ "" + , "" + , encodeHtml $ atomEntryLink e + , "" + , "" + , "" + , formatW3 $ atomEntryUpdated e + , "" + , "" + , encodeHtml $ atomEntryTitle e + , "" + , "" + , "" + ] + +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" + +-- sitemaps +data SitemapLoc = AbsLoc String | RelLoc String +data SitemapChangeFreq = Always + | Hourly + | Daily + | Weekly + | Monthly + | Yearly + | Never +instance Show SitemapChangeFreq where + show Always = "always" + show Hourly = "hourly" + show Daily = "daily" + show Weekly = "weekly" + show Monthly = "monthly" + show Yearly = "yearly" + show Never = "never" + +data SitemapUrl = SitemapUrl + { sitemapLoc :: SitemapLoc + , sitemapLastMod :: UTCTime + , sitemapChangeFreq :: SitemapChangeFreq + , priority :: Double + } +data SitemapRequest = SitemapRequest String Int +instance Request SitemapRequest where + parseRequest = do + env <- parseEnv + return $! SitemapRequest (Hack.serverName env) + (Hack.serverPort env) +data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] +instance Show SitemapResponse where + show (SitemapResponse (SitemapRequest host port) urls) = + "\n" ++ + "" ++ + concatMap helper urls ++ + "" + where + prefix = "http://" ++ host ++ + case port of + 80 -> "" + _ -> ":" ++ show port + helper (SitemapUrl loc modTime freq pri) = concat + [ "" + , encodeHtml $ showLoc loc + , "" + , formatW3 modTime + , "" + , show freq + , "" + , show pri + , "" + ] + showLoc (AbsLoc s) = s + showLoc (RelLoc s) = prefix ++ s + +instance Response SitemapResponse where + reps res = + [ ("text/xml", response 200 [] $ show res) + ] + +sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse +sitemap urls' req = do + urls <- urls' + return $ SitemapResponse req urls + +data GenResponse = HtmlResponse String + | ObjectResponse Object + | HtmlOrObjectResponse String Object + | RedirectResponse String + | PermissionDeniedResult String + | NotFoundResponse String +instance Response GenResponse where + reps (HtmlResponse h) = [("text/html", response 200 [] h)] + reps (ObjectResponse t) = reps t + reps (HtmlOrObjectResponse h t) = + ("text/html", response 200 [] h) : reps t + reps (RedirectResponse url) = [("text/html", response 303 heads body)] + where + heads = [("Location", url)] + body = "

    Redirecting to " ++ encodeHtml url ++ "

    " + reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] + reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] +class ToObject a => ListDetail a where + htmlDetail :: a -> String + htmlDetail = treeToHtml . toObject + detailTitle :: a -> String + detailUrl :: a -> String + htmlList :: [a] -> String + htmlList l = "
      " ++ concatMap helper l ++ "
    " + where + helper i = "
  • " ++ encodeHtml (detailTitle i) ++ + "
    • " + -- | Often times for the JSON response of the list, we don't need all + -- the information. + treeList :: [a] -> Object -- FIXME + treeList = Sequence . map treeListSingle + treeListSingle :: a -> Object + treeListSingle = toObject + +newtype ItemList a = ItemList [a] +instance ListDetail a => Response (ItemList a) where + reps (ItemList l) = + [ ("text/html", response 200 [] $ htmlList l) + , ("application/json", response 200 [] $ treeToJson $ treeList l) + ] +newtype ItemDetail a = ItemDetail a +instance ListDetail a => Response (ItemDetail a) where + reps (ItemDetail i) = + [ ("text/html", response 200 [] $ htmlDetail i) + , ("application/json", response 200 [] $ treeToJson $ toObject i) + ] + +-- FIXME remove treeTo functions, replace with Object instances +treeToJson :: Object -> String +treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\"" +treeToJson (Sequence l) = + "[" ++ intercalate "," (map treeToJson l) ++ "]" +treeToJson (Mapping m) = + "{" ++ intercalate "," (map helper m) ++ "}" where + helper (k, v) = + treeToJson (Scalar k) ++ + ":" ++ + treeToJson v + +treeToHtml :: Object -> String +treeToHtml (Scalar s) = encodeHtml $ fromStrictByteString s +treeToHtml (Sequence l) = + "
      " ++ concatMap (\e -> "
    • " ++ treeToHtml e ++ "
      • ") l ++ + "
    " +treeToHtml (Mapping m) = + "
    " ++ + concatMap (\(k, v) -> "
    " ++ + encodeHtml (fromStrictByteString k) ++ + "
    " ++ + "
    " ++ + treeToHtml v ++ + "
    ") m ++ + "
    " + +instance Response Object where + reps tree = + [ ("text/html", response 200 [] $ treeToHtml tree) + , ("application/json", response 200 [] $ treeToJson tree) + ] diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs new file mode 100644 index 00000000..605a9c99 --- /dev/null +++ b/Web/Restful/Utils.hs @@ -0,0 +1,33 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Utils +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Utility functions for Restful. +-- +--------------------------------------------------------- +module Web.Restful.Utils + ( parseHttpAccept + , tryLookup + ) where + +import Data.List.Split (splitOneOf) + +parseHttpAccept :: String -> [String] +parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," + +specialHttpAccept :: String -> Bool +specialHttpAccept ('q':'=':_) = True +specialHttpAccept ('*':_) = True +specialHttpAccept _ = False + +tryLookup :: Eq k => v -> k -> [(k, v)] -> v +tryLookup v _ [] = v +tryLookup v k ((k', v'):rest) + | k == k' = v' + | otherwise = tryLookup v k rest diff --git a/restful.cabal b/restful.cabal index 26910f74..dacf32c7 100644 --- a/restful.cabal +++ b/restful.cabal @@ -28,6 +28,12 @@ library bytestring >= 0.9.1.4, bytestring-class, web-encodings, - mtl >= 1.1.0.2 - exposed-modules: Web.Restful + mtl >= 1.1.0.2, + data-object + exposed-modules: Web.Restful, + Web.Restful.Constants, + Web.Restful.Request, + Web.Restful.Response, + Web.Restful.Utils, + Web.Restful.Application ghc-options: -Wall From 24520b9b16b21de3da84fd1a4f87bbd8c53bf545 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Aug 2009 10:02:58 +0300 Subject: [PATCH 005/624] Updated README to show future refactor goals. --- README | 1 - README.md | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 93 insertions(+), 1 deletion(-) delete mode 100644 README create mode 100644 README.md diff --git a/README b/README deleted file mode 100644 index 4ccea4d9..00000000 --- a/README +++ /dev/null @@ -1 +0,0 @@ -A Restful front controller built on Hack. diff --git a/README.md b/README.md new file mode 100644 index 00000000..e84ad30e --- /dev/null +++ b/README.md @@ -0,0 +1,93 @@ +A Restful front controller built on Hack. + +Below is an overview of how the refactored code will hopefully turn out. + +# Terminology + +## Verb + +HTTP request methods. Possible values: GET, POST, PUT, DELETE. Please see +http://rest.blueoxen.net/cgi-bin/wiki.pl?MinimumMethods. In sum: + +GET: Read only. +PUT: Replace data on server. +DELETE: Remove data from server. +POST: Some form of update. + +FIXME Note: not all clients support PUT and DELETE. Therefore, we need a +workaround. I will implement two fixes: + +1. X-HTTP-Method-Override header. +2. Get parameter (ie, in the query string). This will be more useful for web forms. + +## Resource + +A Resource is a single URL. Each Resource can be addressed with the four verbs, +though does not necesarily support all of them. There are a few different ways +of passing parameters: + +1. URL parameter. For example, you can set up your application so that +/articles/my_title/ will hand off to the article resource with a parameter of +my_title. The idea here is to avoid the regexs present in most other +frameworks and provide a uniform interface for all parameters. + +2. Get parameter, ie query string. + +3. Post parameter, ie content body. This is *not* available for GET requests. +However, it *is* available for PUT and DELETE. + +4. Headers, including cookies. + +### ResourceName + +As a side point to the URL parameter mentioned above: let us say you have +multiple resources like /articles/my_title/ and /articles/other_title/. You +clearly do not want to write code twice to process these requests. Instead, +convert the article name into a URL parameter and then articles will have its +own ResourceName. + +## RawRequest + +The parsed data sent from the client. Has, for example, GET and POST +parameters, not QUERY_STRING and CONTENT_BODY. + +## Request + +Request is actually a **type class** for parsing a RawRequest. This allows +putting all form handling code and the like into a single place. Your handler +code (see below) need only deal with your data type. + +## Representation + +Some method of showing data to the client. These are identified by MIME types. +For the most part, you should be using hierarchichal data (see Data.Object). +There are some exceptions, such as: + +* HTML for non-Ajax clients (search engines, old browsers). +* Atom/RSS feeds. +* Sitemaps. + +Whenever possible, use Data.Object, as this will automatically handle some +basic representations (JSON, JSONP, Yaml, XML, undecorated HTML). + +## Response + +Contains basic HTTP response information and something which can be represented +in different ways. + +## Handler + +There is a single Handler for each combination of ResourceName and Verb. A +Handler takes some instance of Request and returns a Response. + +# Static files + +All static files should go under the /static/ path. A typical application will +probably have a Javascript file in there which deals directly with the entire +Restful API. + +# Non-Ajax clients + +Search engines nad older clients should not be ignored. However, it is quite +tedious to write view code twice. Hopefully, in the future there will be a view +component to this framework which can automate some of that process. From 543b15d7688ff98bcf134cdc01604f4b82d81292 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Aug 2009 10:05:02 +0300 Subject: [PATCH 006/624] Added method override middleware --- Hack/Middleware/MethodOverride.hs | 37 +++++++++++++++++++++++++++++++ README.md | 9 +++++--- Web/Restful/Application.hs | 8 ++++++- 3 files changed, 50 insertions(+), 4 deletions(-) create mode 100644 Hack/Middleware/MethodOverride.hs diff --git a/Hack/Middleware/MethodOverride.hs b/Hack/Middleware/MethodOverride.hs new file mode 100644 index 00000000..940c168d --- /dev/null +++ b/Hack/Middleware/MethodOverride.hs @@ -0,0 +1,37 @@ +--------------------------------------------------------- +-- | +-- Module : Hack.Middleware.MethodOverride +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Override the HTTP method based on either: +-- The X-HTTP-Method-Override header. +-- The _method_override GET parameter. +-- +--------------------------------------------------------- +module Hack.Middleware.MethodOverride (methodOverride) where + +import Hack +import Web.Encodings (decodeUrlPairs) +import Data.Monoid (mappend) + +methodOverride :: Middleware +methodOverride app env = do + let mo1 = lookup "X-HTTP-Method-Override" $ http env + gets = decodeUrlPairs $ queryString env + mo2 = lookup "_method_override" gets + cm = requestMethod env + app $ + case mo1 `mappend` mo2 of + Nothing -> env + Just nm -> env { requestMethod = safeRead cm nm } + +safeRead :: Read a => a -> String -> a +safeRead d s = + case reads s of + ((x, _):_) -> x + [] -> d diff --git a/README.md b/README.md index e84ad30e..21c4cc8d 100644 --- a/README.md +++ b/README.md @@ -14,11 +14,14 @@ PUT: Replace data on server. DELETE: Remove data from server. POST: Some form of update. -FIXME Note: not all clients support PUT and DELETE. Therefore, we need a -workaround. I will implement two fixes: +Note: not all clients support PUT and DELETE. Therefore, we need a +workaround. There are two fixes: 1. X-HTTP-Method-Override header. -2. Get parameter (ie, in the query string). This will be more useful for web forms. +2. Get parameter _method_override (ie, in the query string). This will be more +useful for web forms. + +See MethodOverride middleware. ## Resource diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 84c30672..dc9679fa 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -47,6 +47,7 @@ import Hack.Middleware.Gzip import Hack.Middleware.CleanPath import Hack.Middleware.Jsonp import Hack.Middleware.ClientSession +import Hack.Middleware.MethodOverride import Control.Applicative ((<$>), Applicative (..)) import Control.Arrow (second) @@ -80,7 +81,12 @@ instance Default ApplicationSettings where , rpxnowApiKey = Nothing , encryptKey = Left defaultKeyFile , urlRewriter = \s -> (s, []) - , hackMiddleware = [gzip, cleanPath, jsonp] + , hackMiddleware = + [ gzip + , cleanPath + , jsonp + , methodOverride + ] , response404 = default404 , htmlWrapper = id } From c4eb5e1ee71fdd6de3fda79cdb6a1b183c21328a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 4 Aug 2009 15:52:21 +0300 Subject: [PATCH 007/624] Replaced UrlRewriter with HandlerParser --- .gitignore | 2 + README.md | 19 ++++++ Web/Restful.hs | 2 + Web/Restful/Application.hs | 132 ++++++++++++++++++------------------- Web/Restful/Constants.hs | 4 +- Web/Restful/Definitions.hs | 47 +++++++++++++ Web/Restful/Handler.hs | 36 ++++++++++ restful.cabal | 4 +- 8 files changed, 178 insertions(+), 68 deletions(-) create mode 100644 Web/Restful/Definitions.hs create mode 100644 Web/Restful/Handler.hs diff --git a/.gitignore b/.gitignore index 39b806f8..678893b5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ dist *.swp +*.hi +*.o diff --git a/README.md b/README.md index 21c4cc8d..6b699ebc 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,11 @@ clearly do not want to write code twice to process these requests. Instead, convert the article name into a URL parameter and then articles will have its own ResourceName. +### ResourceParser + +A ResourceParser converts a Resource (ie, a URL) to a ResourceName and URL +parameters. + ## RawRequest The parsed data sent from the client. Has, for example, GET and POST @@ -83,6 +88,15 @@ in different ways. There is a single Handler for each combination of ResourceName and Verb. A Handler takes some instance of Request and returns a Response. +### HandlerMap + +Maps a ResourceName/Verb pair to a Handler. + +## Application + +An application is essentially a ResourceParser and HandlerMap. It also has some +settings involved. + # Static files All static files should go under the /static/ path. A typical application will @@ -94,3 +108,8 @@ Restful API. Search engines nad older clients should not be ignored. However, it is quite tedious to write view code twice. Hopefully, in the future there will be a view component to this framework which can automate some of that process. + +# Passing global data + +You should use function currying to pass around global information (the list of +entries in a blog, a database connection, etc). diff --git a/Web/Restful.hs b/Web/Restful.hs index f4925cad..c2878f2c 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -17,9 +17,11 @@ module Web.Restful , module Web.Restful.Request , module Web.Restful.Response , module Web.Restful.Application + , module Web.Restful.Definitions ) where import Data.Object import Web.Restful.Request import Web.Restful.Response import Web.Restful.Application +import Web.Restful.Definitions diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index dc9679fa..f03f3d43 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Web.Restful.Application @@ -22,10 +23,12 @@ module Web.Restful.Application -- ** Settings , setHandler , setRpxnowApiKey - , setUrlRewriter + , setResourceParser , setHtmlWrapper -- ** Engage , run + -- * FIXME + , Application (..) ) where -- hideously long import list @@ -56,31 +59,33 @@ import Web.Restful.Request import Web.Restful.Response import Web.Restful.Constants import Web.Restful.Utils +import Web.Restful.Handler +import Web.Restful.Definitions import Data.Object -- | Contains settings and a list of resources. -type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) -instance Applicative ApplicationMonad where +type ApplicationMonad a = StateT (ApplicationSettings a) (Writer (HandlerMap a)) +instance Applicative (ApplicationMonad a) where pure = return f <*> a = do f' <- f a' <- a return $! f' a' -data ApplicationSettings = ApplicationSettings +data ApplicationSettings rn = ApplicationSettings { hackHandler :: Hack.Application -> IO () , rpxnowApiKey :: Maybe String , encryptKey :: Either FilePath Word256 - , urlRewriter :: UrlRewriter + , appResourceParser :: ResourceParser rn , hackMiddleware :: [Hack.Middleware] , response404 :: Hack.Env -> IO Hack.Response , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance Default ApplicationSettings where +instance ResourceName a => Default (ApplicationSettings a) where def = ApplicationSettings { hackHandler = Hack.Handler.CGI.run , rpxnowApiKey = Nothing , encryptKey = Left defaultKeyFile - , urlRewriter = \s -> (s, []) + , appResourceParser = \s -> ParsedResource (toResourceName s) [] , hackMiddleware = [ gzip , cleanPath @@ -98,44 +103,32 @@ default404 env = return $ [("Content-Type", "text/plain")] $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env -data Handler = forall req res. (Request req, Response res) - => Handler (req -> IO res) -type LiftedHandler = RawRequest -> IO ResponseWrapper - -liftHandler :: - Handler - -> RawRequest - -> IO ResponseWrapper -liftHandler (Handler h) rr = do - case runRequestParser parseRequest rr of - Left errors -> return $ ResponseWrapper - $ ErrorResponse - $ unlines errors - Right req -> ResponseWrapper `fmap` h req - -data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler - -- FIXME document below here -addResource :: (Request req, Response res) - => [Hack.RequestMethod] - -> PathInfo +addResource :: (Request req, Response res, ResourceName rn) + => Verb + -> rn -> (req -> IO res) - -> ApplicationMonad () -addResource methods path f = - tell [Resource methods path $ liftHandler $ Handler f] + -> ApplicationMonad rn () +addResource verb resourceName' f = do + let handler :: Handler + handler = Handler $ (fmap ResponseWrapper) . f + handlerDesc = HandlerDesc resourceName' verb handler + tell [handlerDesc] -setUrlRewriter :: UrlRewriter -> ApplicationMonad () -setUrlRewriter newUrlRewriter = do +setResourceParser :: ResourceName rn + => ResourceParser rn + -> ApplicationMonad rn () +setResourceParser newRP = do s <- get - put $ s { urlRewriter = newUrlRewriter } + put $ s { appResourceParser = newRP } -setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () +setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a () setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -run :: ApplicationMonad () -> IO () +run :: ResourceName a => ApplicationMonad a () -> IO () run m = do let (settings, resources') = runWriter $ execStateT m def key <- case encryptKey settings of @@ -143,36 +136,38 @@ run m = do Right k -> return k let defApp = defaultResources settings defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources + resources = resources' ++ defResources -- FIXME rename HandlerDescs app' :: Hack.Application - app' = makeApplication' resources settings + app' = toHackApplication $ Application resources settings clientsession' :: Hack.Middleware clientsession' = clientsession [authCookieName] key app :: Hack.Application app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] hackHandler settings app -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () +setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad a () setHandler h = do settings <- get put $ settings { hackHandler = h } -setRpxnowApiKey :: String -> ApplicationMonad () +setRpxnowApiKey :: String -> ApplicationMonad a () setRpxnowApiKey k = do settings <- get put $ settings { rpxnowApiKey = Just k } -defaultResources :: ApplicationSettings -> ApplicationMonad () +defaultResources :: ResourceName rn + => ApplicationSettings rn + -> ApplicationMonad rn () defaultResources settings = do - addResource [Hack.GET] ["auth", "check"] authCheck - addResource [Hack.GET] ["auth", "logout"] authLogout - addResource [Hack.GET] ["auth", "openid"] authOpenidForm - addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward - addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete + addResource Get (toResourceName ["auth", "check"]) authCheck + addResource Get (toResourceName ["auth", "logout"]) authLogout + addResource Get (toResourceName ["auth", "openid"]) authOpenidForm + addResource Get (toResourceName ["auth", "openid", "forward"]) authOpenidForward + addResource Get (toResourceName ["auth", "openid", "complete"]) authOpenidComplete case rpxnowApiKey settings of Nothing -> return () Just key -> do - addResource [Hack.GET] ["auth", "login", "rpxnow"] $ + addResource Get (toResourceName ["auth", "login", "rpxnow"]) $ rpxnowLogin key data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) @@ -314,22 +309,24 @@ instance Response LogoutResponse where Hack.Response s (h':h) c h' = resetCookie authCookieName -makeApplication' :: [Resource] - -> ApplicationSettings - -> Hack.Env - -> IO Hack.Response -makeApplication' resources settings env = do - let method = Hack.requestMethod env - rr = envToRawRequest (urlRewriter settings) env - path' = rawPathInfo rr - isValid :: Resource -> Bool - isValid (Resource methods path _) = method `elem` methods - && path == path' - case filter isValid resources of - [Resource _ _ handler] -> do +toHackApplication :: Eq resourceName + => Application resourceName + -> Hack.Application +toHackApplication (Application hm settings) env = do + let (Right resource) = splitPath $ Hack.pathInfo env + (ParsedResource rn urlParams') = (appResourceParser settings) resource + verb :: Verb + verb = toVerb $ Hack.requestMethod env + rr :: RawRequest + rr = envToRawRequest urlParams' env + matchingHandler (HandlerDesc resourceName' verb' _) = + rn == resourceName' && + verb == verb' + case filter matchingHandler hm of + [HandlerDesc _ _ handler] -> do let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - body <- handler rr + body <- runHandler handler rr let reps' = reps body ctypes = filter (\c -> isJust $ lookup c reps') ctypes' let handlerPair = @@ -351,13 +348,11 @@ makeApplication' resources settings env = do (("Content-Type", ctype) : headers) $ toLazyByteString $ wrapper content [] -> response404 settings $ env - _ -> fail "Overlapping handlers" + _ -> fail $ "Overlapping handlers for: " ++ show env -type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) -envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest -envToRawRequest rewriter env = +envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest +envToRawRequest urlParams' env = let (Right rawPieces) = splitPath $ Hack.pathInfo env - (pi', urls) = rewriter rawPieces gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] clength = tryLookup "0" "Content-Length" $ Hack.http env ctype = tryLookup "" "Content-Type" $ Hack.http env @@ -365,4 +360,9 @@ envToRawRequest rewriter env = $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest pi' urls gets' posts cookies' files env + in RawRequest rawPieces urlParams' gets' posts cookies' files env + +data Application a = Application + { handlerMap :: HandlerMap a + , applicationSettings :: ApplicationSettings a + } diff --git a/Web/Restful/Constants.hs b/Web/Restful/Constants.hs index c39aa532..e6445b54 100644 --- a/Web/Restful/Constants.hs +++ b/Web/Restful/Constants.hs @@ -11,7 +11,9 @@ -- Constants used throughout Restful. -- --------------------------------------------------------- -module Web.Restful.Constants where +module Web.Restful.Constants + ( authCookieName + ) where authCookieName :: String authCookieName = "IDENTIFIER" diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs new file mode 100644 index 00000000..f96ca895 --- /dev/null +++ b/Web/Restful/Definitions.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Definitions +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Definitions throughout Restful. +-- +--------------------------------------------------------- +module Web.Restful.Definitions + ( Verb (..) + , toVerb + , Resource + , ParsedResource (..) + , ResourceParser + , ResourceName (..) + ) where + +import qualified Hack + +data Verb = Get | Put | Delete | Post + deriving (Eq, Show) + +toVerb :: Hack.RequestMethod -> Verb +toVerb Hack.PUT = Put +toVerb Hack.DELETE = Delete +toVerb Hack.POST = Post +toVerb _ = Get + +type Resource = [String] + +class Eq a => ResourceName a where + toResourceName :: [String] -> a +instance ResourceName [String] where + toResourceName = id + +data ParsedResource a = ParsedResource + { resourceName :: a + , urlParameters :: [(String, String)] + } + +type ResourceParser a = Resource -> ParsedResource a diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs new file mode 100644 index 00000000..100440ad --- /dev/null +++ b/Web/Restful/Handler.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Handler +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : unstable +-- Portability : portable +-- +-- Define Handler stuff. +-- +--------------------------------------------------------- +module Web.Restful.Handler + ( Handler (..) + , runHandler + , HandlerMap + , HandlerDesc (..) + ) where + +import Web.Restful.Definitions +import Web.Restful.Request +import Web.Restful.Response + +data Handler = forall req. Request req => Handler (req -> IO ResponseWrapper) + +runHandler :: Handler -> RawRequest -> IO ResponseWrapper +runHandler (Handler f) rreq = do + let rparser = parseRequest + case runRequestParser rparser rreq of + Left errors -> fail $ unlines errors -- FIXME + Right req -> f req + +data HandlerDesc a = HandlerDesc a Verb Handler +type HandlerMap a = [HandlerDesc a] diff --git a/restful.cabal b/restful.cabal index dacf32c7..7a10957a 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.0.0 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -35,5 +35,7 @@ library Web.Restful.Request, Web.Restful.Response, Web.Restful.Utils, + Web.Restful.Definitions, + Web.Restful.Handler, Web.Restful.Application ghc-options: -Wall From cb963a6231cad41dc3a773a707e2ff0ebd6e4f9a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 5 Aug 2009 13:32:01 +0300 Subject: [PATCH 008/624] Vastly simplified Web.Restful.Application --- Data/Object/Instances.hs | 93 +++++++++++ Web/Restful.hs | 27 --- Web/Restful/Application.hs | 321 +++++++----------------------------- Web/Restful/Definitions.hs | 15 +- Web/Restful/Handler.hs | 16 +- Web/Restful/Helpers/Auth.hs | 216 ++++++++++++++++++++++++ Web/Restful/Response.hs | 1 + restful.cabal | 8 +- 8 files changed, 393 insertions(+), 304 deletions(-) create mode 100644 Data/Object/Instances.hs delete mode 100644 Web/Restful.hs create mode 100644 Web/Restful/Helpers/Auth.hs diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs new file mode 100644 index 00000000..6f2301ef --- /dev/null +++ b/Data/Object/Instances.hs @@ -0,0 +1,93 @@ +--------------------------------------------------------- +-- +-- Module : Data.Object.Instances +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Instances for converting various types of data into Data.Object.Object. +-- +--------------------------------------------------------- +module Data.Object.Instances + ( Json (..) + , Yaml (..) + , Html (..) + ) where + +import Data.Object +import qualified Data.ByteString as B +import Data.ByteString.Class +import Web.Encodings (encodeJson) +import qualified Text.Yaml as Y + +newtype Json = Json B.ByteString +instance FromObject Json where + fromObject = return . Json . helper where + helper :: Object -> B.ByteString + helper (Scalar s) = B.concat + [ toStrictByteString "\"" + , encodeJson $ fromStrictByteString s + , toStrictByteString "\"" + ] + helper (Sequence s) = B.concat + [ toStrictByteString "[" + , B.intercalate (toStrictByteString ",") $ map helper s + , toStrictByteString "]" + ] + helper (Mapping m) = B.concat + [ toStrictByteString "{" + , B.intercalate (toStrictByteString ",") $ map helper2 m + , toStrictByteString "}" + ] + helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 (k, v) = B.concat + [ toStrictByteString "\"" + , encodeJson $ fromStrictByteString k + , toStrictByteString "\":" + , helper v + ] + +newtype Yaml = Yaml B.ByteString +instance FromObject Yaml where + fromObject = return . Yaml . Y.encode + +-- | Represents as an entire HTML 5 document by using the following: +-- +-- * A scalar is a paragraph. +-- * A sequence is an unordered list. +-- * A mapping is a definition list. +newtype Html = Html B.ByteString + +instance FromObject Html where + fromObject o = return $ Html $ B.concat + [ toStrictByteString "\n" + , helper o + , toStrictByteString "" + ] where + helper :: Object -> B.ByteString + helper (Scalar s) = B.concat + [ toStrictByteString "

    " + , s + , toStrictByteString "

    " + ] + helper (Sequence []) = toStrictByteString "
      " + helper (Sequence s) = B.concat + [ toStrictByteString "
      • " + , B.intercalate (toStrictByteString "
      • ") $ map helper s + , toStrictByteString "
      " + ] + helper (Mapping m) = B.concat $ + toStrictByteString "
      " : + map helper2 m ++ + [ toStrictByteString "
      " ] + helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 (k, v) = B.concat $ + [ toStrictByteString "
      " + , k + , toStrictByteString "
      " + , helper v + , toStrictByteString "
      " + ] diff --git a/Web/Restful.hs b/Web/Restful.hs deleted file mode 100644 index c2878f2c..00000000 --- a/Web/Restful.hs +++ /dev/null @@ -1,27 +0,0 @@ ---------------------------------------------------------- --- --- Module : Web.Restful --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Lightweight framework for designing RESTful APIs. --- ---------------------------------------------------------- -module Web.Restful - ( - module Data.Object - , module Web.Restful.Request - , module Web.Restful.Response - , module Web.Restful.Application - , module Web.Restful.Definitions - ) where - -import Data.Object -import Web.Restful.Request -import Web.Restful.Response -import Web.Restful.Application -import Web.Restful.Definitions diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index f03f3d43..dbe63821 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -18,24 +18,14 @@ module Web.Restful.Application ( -- * Defining an application ApplicationMonad - -- ** Routing - , addResource -- ** Settings - , setHandler - , setRpxnowApiKey - , setResourceParser , setHtmlWrapper -- ** Engage - , run - -- * FIXME - , Application (..) + , toHackApp ) where -- hideously long import list import qualified Hack -import qualified Hack.Handler.CGI -import Control.Monad.Reader -import Control.Monad.Writer import Control.Monad.State hiding (gets) import Web.Encodings import Data.Maybe (isJust) @@ -43,8 +33,7 @@ import Data.ByteString.Class import qualified Data.ByteString.Lazy as BS import Data.Function.Predicate (equals) import Data.Default -import qualified Web.Authenticate.Rpxnow as Rpxnow -import qualified Web.Authenticate.OpenId as OpenId +import Control.Applicative ( Applicative (..)) import Hack.Middleware.Gzip import Hack.Middleware.CleanPath @@ -52,19 +41,15 @@ import Hack.Middleware.Jsonp import Hack.Middleware.ClientSession import Hack.Middleware.MethodOverride -import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) - import Web.Restful.Request import Web.Restful.Response -import Web.Restful.Constants import Web.Restful.Utils import Web.Restful.Handler import Web.Restful.Definitions -import Data.Object +import Web.Restful.Constants -- | Contains settings and a list of resources. -type ApplicationMonad a = StateT (ApplicationSettings a) (Writer (HandlerMap a)) +type ApplicationMonad a = State (ApplicationSettings a) instance Applicative (ApplicationMonad a) where pure = return f <*> a = do @@ -72,20 +57,16 @@ instance Applicative (ApplicationMonad a) where a' <- a return $! f' a' data ApplicationSettings rn = ApplicationSettings - { hackHandler :: Hack.Application -> IO () - , rpxnowApiKey :: Maybe String - , encryptKey :: Either FilePath Word256 - , appResourceParser :: ResourceParser rn + { encryptKey :: Either FilePath Word256 , hackMiddleware :: [Hack.Middleware] , response404 :: Hack.Env -> IO Hack.Response , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance ResourceName a => Default (ApplicationSettings a) where + +instance (HasResourceParser a) => + Default (ApplicationSettings a) where def = ApplicationSettings - { hackHandler = Hack.Handler.CGI.run - , rpxnowApiKey = Nothing - , encryptKey = Left defaultKeyFile - , appResourceParser = \s -> ParsedResource (toResourceName s) [] + { encryptKey = Left defaultKeyFile , hackMiddleware = [ gzip , cleanPath @@ -105,250 +86,65 @@ default404 env = return $ -- FIXME document below here -addResource :: (Request req, Response res, ResourceName rn) - => Verb - -> rn - -> (req -> IO res) - -> ApplicationMonad rn () -addResource verb resourceName' f = do - let handler :: Handler - handler = Handler $ (fmap ResponseWrapper) . f - handlerDesc = HandlerDesc resourceName' verb handler - tell [handlerDesc] - -setResourceParser :: ResourceName rn - => ResourceParser rn - -> ApplicationMonad rn () -setResourceParser newRP = do - s <- get - put $ s { appResourceParser = newRP } - setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a () setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -run :: ResourceName a => ApplicationMonad a () -> IO () -run m = do - let (settings, resources') = runWriter $ execStateT m def +toHackApp :: (Eq a, HasResourceParser a, HasHandlers a b) + => ApplicationMonad a () + -> b + -> IO Hack.Application +toHackApp am model = do + let settings = execState am def key <- case encryptKey settings of Left f -> getKey f Right k -> return k - let defApp = defaultResources settings - defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources -- FIXME rename HandlerDescs - app' :: Hack.Application - app' = toHackApplication $ Application resources settings - clientsession' :: Hack.Middleware - clientsession' = clientsession [authCookieName] key - app :: Hack.Application + let handlers = getHandler model + app' = toHackApplication handlers settings + clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] - hackHandler settings app + return app -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad a () -setHandler h = do - settings <- get - put $ settings { hackHandler = h } - -setRpxnowApiKey :: String -> ApplicationMonad a () -setRpxnowApiKey k = do - settings <- get - put $ settings { rpxnowApiKey = Just k } - -defaultResources :: ResourceName rn - => ApplicationSettings rn - -> ApplicationMonad rn () -defaultResources settings = do - addResource Get (toResourceName ["auth", "check"]) authCheck - addResource Get (toResourceName ["auth", "logout"]) authLogout - addResource Get (toResourceName ["auth", "openid"]) authOpenidForm - addResource Get (toResourceName ["auth", "openid", "forward"]) authOpenidForward - addResource Get (toResourceName ["auth", "openid", "complete"]) authOpenidComplete - case rpxnowApiKey settings of - Nothing -> return () - Just key -> do - addResource Get (toResourceName ["auth", "login", "rpxnow"]) $ - rpxnowLogin key - -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" -instance Show OIDFormReq where - show (OIDFormReq Nothing _) = "" - show (OIDFormReq (Just s) _) = "

      " ++ encodeHtml s ++ - "

      " -data OIDFormRes = OIDFormRes String (Maybe String) -instance Response OIDFormRes where - reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] - where - heads = - case dest of - Nothing -> [] - Just dest' -> - [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] -authOpenidForm :: OIDFormReq -> IO OIDFormRes -authOpenidForm m@(OIDFormReq _ dest) = - let html = - show m ++ - "
      " ++ - "OpenID: " ++ - "" ++ - "
      " - in return $! OIDFormRes html dest -data OIDFReq = OIDFReq String String -instance Request OIDFReq where - parseRequest = do - oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" - return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse -authOpenidForward (OIDFReq oid complete) = do - res <- OpenId.getForwardUrl oid complete :: IO (Either String String) - return $ - case res of - Left err -> RedirectResponse $ "/auth/openid/?message=" ++ - encodeUrl err - Right url -> RedirectResponse url - -data OIDComp = OIDComp [(String, String)] (Maybe String) -instance Request OIDComp where - parseRequest = do - rr <- ask - let gets = rawGetParams rr - dest <- cookieParam "DEST" - return $! OIDComp gets dest -data OIDCompRes = OIDCompResErr String - | OIDCompResGood String (Maybe String) -instance Response OIDCompRes where - reps (OIDCompResErr err) = - reps $ RedirectResponse - $ "/auth/openid/?message=" ++ - encodeUrl err - reps (OIDCompResGood ident Nothing) = - reps $ OIDCompResGood ident (Just "/") - reps (OIDCompResGood ident (Just dest)) = - [("text/plain", response 303 heads "")] where - heads = - [ (authCookieName, ident) - , resetCookie "DEST" - , ("Location", dest) - ] - -resetCookie :: String -> (String, String) -resetCookie name = - ("Set-Cookie", - name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") - -authOpenidComplete :: OIDComp -> IO OIDCompRes -authOpenidComplete (OIDComp gets' dest) = do - res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) - return $ - case res of - Left err -> OIDCompResErr err - Right (OpenId.Identifier ident) -> OIDCompResGood ident dest - --- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- getParam "token" - dest <- getParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - -chopHash :: String -> String -chopHash ('#':rest) = rest -chopHash x = x - --- | dest identifier -data RpxnowResponse = RpxnowResponse String (Maybe String) -instance Response RpxnowResponse where - reps (RpxnowResponse dest Nothing) = - [("text/html", response 303 [("Location", dest)] "")] - reps (RpxnowResponse dest (Just ident)) = - [("text/html", response 303 - [ ("Location", dest) - , (authCookieName, ident) - ] - "")] - -rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> IO RpxnowResponse -rpxnowLogin apiKey (RpxnowRequest token dest') = do - let dest = case dest' of - Nothing -> "/" - Just "" -> "/" - Just s -> s - ident' <- Rpxnow.authenticate apiKey token - return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') - -data AuthRequest = AuthRequest (Maybe String) -instance Request AuthRequest where - parseRequest = AuthRequest `fmap` identifier - -authCheck :: AuthRequest -> IO Object -authCheck (AuthRequest Nothing) = - return $ toObject [("status", "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ toObject - [ ("status", "loggedin") - , ("ident", i) - ] - -authLogout :: () -> IO LogoutResponse -authLogout _ = return LogoutResponse - -data LogoutResponse = LogoutResponse -instance Response LogoutResponse where - reps _ = map (second addCookie) $ reps tree where - tree = toObject [("status", "loggedout")] - addCookie (Hack.Response s h c) = - Hack.Response s (h':h) c - h' = resetCookie authCookieName - -toHackApplication :: Eq resourceName - => Application resourceName +toHackApplication :: (HasResourceParser resourceName, Eq resourceName) + => HandlerMap resourceName + -> ApplicationSettings resourceName -> Hack.Application -toHackApplication (Application hm settings) env = do +toHackApplication hm settings env = do let (Right resource) = splitPath $ Hack.pathInfo env - (ParsedResource rn urlParams') = (appResourceParser settings) resource - verb :: Verb - verb = toVerb $ Hack.requestMethod env - rr :: RawRequest - rr = envToRawRequest urlParams' env - matchingHandler (HandlerDesc resourceName' verb' _) = - rn == resourceName' && - verb == verb' - case filter matchingHandler hm of - [HandlerDesc _ _ handler] -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- runHandler handler rr - let reps' = reps body - ctypes = filter (\c -> isJust $ lookup c reps') ctypes' - let handlerPair = - case ctypes of - [] -> Just $ head reps' - (c:_) -> - case filter (fst `equals` c) reps' of - [pair] -> Just pair - [] -> Nothing - _ -> error "Overlapping reps" - case handlerPair of - Nothing -> response404 settings $ env - Just (ctype, Hack.Response status headers content) -> do - let wrapper = - case ctype of - "text/html" -> htmlWrapper settings - _ -> id - return $ Hack.Response status - (("Content-Type", ctype) : headers) - $ toLazyByteString $ wrapper content - [] -> response404 settings $ env - _ -> fail $ "Overlapping handlers for: " ++ show env + case resourceParser resource of + Nothing -> response404 settings $ env + (Just (ParsedResource rn urlParams')) -> do + let verb :: Verb + verb = toVerb $ Hack.requestMethod env + rr :: RawRequest + rr = envToRawRequest urlParams' env + case hm rn verb of + (Just handler) -> do + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + body <- runHandler handler rr + let reps' = reps body + ctypes = filter (\c -> isJust $ lookup c reps') ctypes' + let handlerPair = + case ctypes of + [] -> Just $ head reps' + (c:_) -> + case filter (fst `equals` c) reps' of + [pair] -> Just pair + [] -> Nothing + _ -> error "Overlapping reps" + case handlerPair of + Nothing -> response404 settings $ env + Just (ctype, Hack.Response status headers content) -> do + let wrapper = + case ctype of + "text/html" -> htmlWrapper settings + _ -> id + return $ Hack.Response status + (("Content-Type", ctype) : headers) + $ toLazyByteString $ wrapper content + Nothing -> response404 settings $ env envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = @@ -361,8 +157,3 @@ envToRawRequest urlParams' env = rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] in RawRequest rawPieces urlParams' gets' posts cookies' files env - -data Application a = Application - { handlerMap :: HandlerMap a - , applicationSettings :: ApplicationSettings a - } diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs index f96ca895..12a6aab1 100644 --- a/Web/Restful/Definitions.hs +++ b/Web/Restful/Definitions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Definitions @@ -18,7 +19,7 @@ module Web.Restful.Definitions , Resource , ParsedResource (..) , ResourceParser - , ResourceName (..) + , HasResourceParser (..) ) where import qualified Hack @@ -34,14 +35,14 @@ toVerb _ = Get type Resource = [String] -class Eq a => ResourceName a where - toResourceName :: [String] -> a -instance ResourceName [String] where - toResourceName = id - data ParsedResource a = ParsedResource { resourceName :: a , urlParameters :: [(String, String)] } -type ResourceParser a = Resource -> ParsedResource a +type ResourceParser a = Resource -> Maybe (ParsedResource a) + +class HasResourceParser a where + resourceParser :: ResourceParser a + simpleParse :: a -> Maybe (ParsedResource a) + simpleParse x = Just $ ParsedResource x [] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 100440ad..980ff848 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -16,7 +18,8 @@ module Web.Restful.Handler ( Handler (..) , runHandler , HandlerMap - , HandlerDesc (..) + , HasHandlers (..) + , liftHandler ) where import Web.Restful.Definitions @@ -32,5 +35,12 @@ runHandler (Handler f) rreq = do Left errors -> fail $ unlines errors -- FIXME Right req -> f req -data HandlerDesc a = HandlerDesc a Verb Handler -type HandlerMap a = [HandlerDesc a] +type HandlerMap a = a -> Verb -> Maybe Handler + +class HasHandlers a b | a -> b where + getHandler :: b -> a -> Verb -> Maybe Handler + +liftHandler :: (Request req, Response res) + => (req -> IO res) + -> Maybe Handler +liftHandler f = Just . Handler $ fmap ResponseWrapper . f diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs new file mode 100644 index 00000000..44cd26e8 --- /dev/null +++ b/Web/Restful/Helpers/Auth.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Helpers.Auth +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Authentication through the authentication package. +-- +--------------------------------------------------------- +module Web.Restful.Helpers.Auth + ( AuthResource + , FromAuthResource (..) + , authResourceParser + ) where + +import qualified Hack +import Web.Encodings +import qualified Web.Authenticate.Rpxnow as Rpxnow +import qualified Web.Authenticate.OpenId as OpenId + +import Web.Restful +import Web.Restful.Constants + +import Control.Applicative ((<$>), Applicative (..)) +import Control.Arrow (second) +import Control.Monad.Reader + +import Data.Object + +data AuthResource = + AuthCheck + | AuthLogout + | AuthOpenid + | AuthOpenidForward + | AuthOpenidComplete + | AuthLoginRpxnow + deriving Eq +class FromAuthResource a where + fromAuthResource :: AuthResource -> a + +authResourceParser :: FromAuthResource far + => Resource + -> Maybe (ParsedResource far) +authResourceParser ["check"] = + authResourceParser' AuthCheck +authResourceParser ["logout"] = + authResourceParser' AuthLogout +authResourceParser ["openid"] = + authResourceParser' AuthOpenid +authResourceParser ["openid", "forward"] = + authResourceParser' AuthOpenidForward +authResourceParser ["openid", "complete"] = + authResourceParser' AuthOpenidComplete +authResourceParser ["login", "rpxnow"] = + authResourceParser' AuthLoginRpxnow +authResourceParser _ = Nothing + +authResourceParser' :: FromAuthResource far + => AuthResource + -> Maybe (ParsedResource far) +authResourceParser' x = Just $ ParsedResource (fromAuthResource x) [] + +type RpxnowApiKey = String -- FIXME newtype +instance HasHandlers AuthResource (Maybe RpxnowApiKey) where + getHandler _ AuthCheck Get = liftHandler authCheck + getHandler _ AuthLogout Get = liftHandler authLogout + getHandler _ AuthOpenid Get = liftHandler authOpenidForm + getHandler _ AuthOpenidForward Get = liftHandler authOpenidForward + getHandler _ AuthOpenidComplete Get = liftHandler authOpenidComplete + getHandler (Just key) AuthLoginRpxnow Get = liftHandler $ rpxnowLogin key + getHandler _ _ _ = Nothing + +data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) +instance Request OIDFormReq where + parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" +instance Show OIDFormReq where + show (OIDFormReq Nothing _) = "" + show (OIDFormReq (Just s) _) = "

      " ++ encodeHtml s ++ + "

      " +data OIDFormRes = OIDFormRes String (Maybe String) +instance Response OIDFormRes where + reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] + where + heads = + case dest of + Nothing -> [] + Just dest' -> + [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] +authOpenidForm :: OIDFormReq -> IO OIDFormRes +authOpenidForm m@(OIDFormReq _ dest) = + let html = + show m ++ + "
      " ++ + "OpenID: " ++ + "" ++ + "
      " + in return $! OIDFormRes html dest +data OIDFReq = OIDFReq String String +instance Request OIDFReq where + parseRequest = do + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" + return $! OIDFReq oid complete +authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward (OIDFReq oid complete) = do + res <- OpenId.getForwardUrl oid complete :: IO (Either String String) + return $ + case res of + Left err -> RedirectResponse $ "/auth/openid/?message=" ++ + encodeUrl err + Right url -> RedirectResponse url + +data OIDComp = OIDComp [(String, String)] (Maybe String) +instance Request OIDComp where + parseRequest = do + rr <- ask + let gets = rawGetParams rr + dest <- cookieParam "DEST" + return $! OIDComp gets dest +data OIDCompRes = OIDCompResErr String + | OIDCompResGood String (Maybe String) +instance Response OIDCompRes where + reps (OIDCompResErr err) = + reps $ RedirectResponse + $ "/auth/openid/?message=" ++ + encodeUrl err + reps (OIDCompResGood ident Nothing) = + reps $ OIDCompResGood ident (Just "/") + reps (OIDCompResGood ident (Just dest)) = + [("text/plain", response 303 heads "")] where + heads = + [ (authCookieName, ident) + , resetCookie "DEST" + , ("Location", dest) + ] + +resetCookie :: String -> (String, String) +resetCookie name = + ("Set-Cookie", + name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") + +authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete (OIDComp gets' dest) = do + res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) + return $ + case res of + Left err -> OIDCompResErr err + Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + +-- | token dest +data RpxnowRequest = RpxnowRequest String (Maybe String) +instance Request RpxnowRequest where + parseRequest = do + token <- getParam "token" + dest <- getParam "dest" + return $! RpxnowRequest token $ chopHash `fmap` dest + +chopHash :: String -> String +chopHash ('#':rest) = rest +chopHash x = x + +-- | dest identifier +data RpxnowResponse = RpxnowResponse String (Maybe String) +instance Response RpxnowResponse where + reps (RpxnowResponse dest Nothing) = + [("text/html", response 303 [("Location", dest)] "")] + reps (RpxnowResponse dest (Just ident)) = + [("text/html", response 303 + [ ("Location", dest) + , (authCookieName, ident) + ] + "")] + +rpxnowLogin :: String -- ^ api key + -> RpxnowRequest + -> IO RpxnowResponse +rpxnowLogin apiKey (RpxnowRequest token dest') = do + let dest = case dest' of + Nothing -> "/" + Just "" -> "/" + Just s -> s + ident' <- Rpxnow.authenticate apiKey token + return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + +data AuthRequest = AuthRequest (Maybe String) +instance Request AuthRequest where + parseRequest = AuthRequest `fmap` identifier + +authCheck :: AuthRequest -> IO Object +authCheck (AuthRequest Nothing) = + return $ toObject [("status", "notloggedin")] +authCheck (AuthRequest (Just i)) = + return $ toObject + [ ("status", "loggedin") + , ("ident", i) + ] + +authLogout :: () -> IO LogoutResponse +authLogout _ = return LogoutResponse + +data LogoutResponse = LogoutResponse +instance Response LogoutResponse where + reps _ = map (second addCookie) $ reps tree where + tree = toObject [("status", "loggedout")] + addCookie (Hack.Response s h c) = + Hack.Response s (h':h) c + h' = resetCookie authCookieName diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 8fd46e7c..a26027bd 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -47,6 +47,7 @@ import System.Locale import Web.Restful.Request -- FIXME ultimately remove import Data.Object import Data.List (intercalate) +import Data.Object.Instances type ContentType = String diff --git a/restful.cabal b/restful.cabal index 7a10957a..661ffd09 100644 --- a/restful.cabal +++ b/restful.cabal @@ -29,7 +29,8 @@ library bytestring-class, web-encodings, mtl >= 1.1.0.2, - data-object + data-object, + yaml >= 0.0.1 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -37,5 +38,8 @@ library Web.Restful.Utils, Web.Restful.Definitions, Web.Restful.Handler, - Web.Restful.Application + Web.Restful.Application, + Data.Object.Instances, + Hack.Middleware.MethodOverride, + Web.Restful.Helpers.Auth ghc-options: -Wall From b338a160f5779440c7106ce8df2fb826a65c3a08 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Aug 2009 16:28:06 +0300 Subject: [PATCH 009/624] Added missing Web/Restful.hs --- Web/Restful.hs | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 Web/Restful.hs diff --git a/Web/Restful.hs b/Web/Restful.hs new file mode 100644 index 00000000..a4699743 --- /dev/null +++ b/Web/Restful.hs @@ -0,0 +1,29 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Lightweight framework for designing RESTful APIs. +-- +--------------------------------------------------------- +module Web.Restful + ( + module Data.Object + , module Web.Restful.Request + , module Web.Restful.Response + , module Web.Restful.Application + , module Web.Restful.Definitions + , module Web.Restful.Handler + ) where + +import Data.Object +import Web.Restful.Request +import Web.Restful.Response +import Web.Restful.Application +import Web.Restful.Definitions +import Web.Restful.Handler From a3e328ca9969c4e31f752dc4f1b5fc504ab3b547 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 10 Aug 2009 08:51:16 +0300 Subject: [PATCH 010/624] Switched to ResourceName type class --- Web/Restful.hs | 2 ++ Web/Restful/Application.hs | 34 ++++++++++++++---- Web/Restful/Definitions.hs | 15 -------- Web/Restful/Handler.hs | 4 --- Web/Restful/Helpers/Auth.hs | 71 ++++++++++++++++--------------------- Web/Restful/Resource.hs | 65 +++++++++++++++++++++++++++++++++ 6 files changed, 125 insertions(+), 66 deletions(-) create mode 100644 Web/Restful/Resource.hs diff --git a/Web/Restful.hs b/Web/Restful.hs index a4699743..47ac2fbc 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -19,6 +19,7 @@ module Web.Restful , module Web.Restful.Application , module Web.Restful.Definitions , module Web.Restful.Handler + , module Web.Restful.Resource ) where import Data.Object @@ -27,3 +28,4 @@ import Web.Restful.Response import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler +import Web.Restful.Resource diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index dbe63821..1890644e 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -47,6 +47,7 @@ import Web.Restful.Utils import Web.Restful.Handler import Web.Restful.Definitions import Web.Restful.Constants +import Web.Restful.Resource -- | Contains settings and a list of resources. type ApplicationMonad a = State (ApplicationSettings a) @@ -63,8 +64,7 @@ data ApplicationSettings rn = ApplicationSettings , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance (HasResourceParser a) => - Default (ApplicationSettings a) where +instance Default (ApplicationSettings a) where def = ApplicationSettings { encryptKey = Left defaultKeyFile , hackMiddleware = @@ -91,7 +91,7 @@ setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -toHackApp :: (Eq a, HasResourceParser a, HasHandlers a b) +toHackApp :: ResourceName a b => ApplicationMonad a () -> b -> IO Hack.Application @@ -106,15 +106,34 @@ toHackApp am model = do app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] return app -toHackApplication :: (HasResourceParser resourceName, Eq resourceName) +findResourceNames :: ResourceName a model + => Resource + -> [(a, [(String, String)])] +findResourceNames r = takeJusts $ map (checkPatternHelper r) allValues + +checkPatternHelper :: ResourceName a model + => Resource + -> a + -> Maybe (a, [(String, String)]) +checkPatternHelper r rn = + case checkPattern (fromString $ resourcePattern rn) r of + Nothing -> Nothing + Just pairs -> Just (rn, pairs) + +takeJusts :: [Maybe a] -> [a] +takeJusts [] = [] +takeJusts (Nothing:rest) = takeJusts rest +takeJusts (Just x:rest) = x : takeJusts rest + +toHackApplication :: ResourceName resourceName model => HandlerMap resourceName -> ApplicationSettings resourceName -> Hack.Application toHackApplication hm settings env = do let (Right resource) = splitPath $ Hack.pathInfo env - case resourceParser resource of - Nothing -> response404 settings $ env - (Just (ParsedResource rn urlParams')) -> do + case findResourceNames resource of + [] -> response404 settings $ env + [(rn, urlParams')] -> do let verb :: Verb verb = toVerb $ Hack.requestMethod env rr :: RawRequest @@ -145,6 +164,7 @@ toHackApplication hm settings env = do (("Content-Type", ctype) : headers) $ toLazyByteString $ wrapper content Nothing -> response404 settings $ env + x -> error $ "Invalid matches: " ++ show x envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs index 12a6aab1..0d21bcd8 100644 --- a/Web/Restful/Definitions.hs +++ b/Web/Restful/Definitions.hs @@ -17,9 +17,6 @@ module Web.Restful.Definitions ( Verb (..) , toVerb , Resource - , ParsedResource (..) - , ResourceParser - , HasResourceParser (..) ) where import qualified Hack @@ -34,15 +31,3 @@ toVerb Hack.POST = Post toVerb _ = Get type Resource = [String] - -data ParsedResource a = ParsedResource - { resourceName :: a - , urlParameters :: [(String, String)] - } - -type ResourceParser a = Resource -> Maybe (ParsedResource a) - -class HasResourceParser a where - resourceParser :: ResourceParser a - simpleParse :: a -> Maybe (ParsedResource a) - simpleParse x = Just $ ParsedResource x [] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 980ff848..b4a1f1fa 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -18,7 +18,6 @@ module Web.Restful.Handler ( Handler (..) , runHandler , HandlerMap - , HasHandlers (..) , liftHandler ) where @@ -37,9 +36,6 @@ runHandler (Handler f) rreq = do type HandlerMap a = a -> Verb -> Maybe Handler -class HasHandlers a b | a -> b where - getHandler :: b -> a -> Verb -> Maybe Handler - liftHandler :: (Request req, Response res) => (req -> IO res) -> Maybe Handler diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 44cd26e8..7d2c2481 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -15,8 +15,6 @@ --------------------------------------------------------- module Web.Restful.Helpers.Auth ( AuthResource - , FromAuthResource (..) - , authResourceParser ) where import qualified Hack @@ -34,48 +32,41 @@ import Control.Monad.Reader import Data.Object data AuthResource = - AuthCheck - | AuthLogout - | AuthOpenid - | AuthOpenidForward - | AuthOpenidComplete - | AuthLoginRpxnow - deriving Eq -class FromAuthResource a where - fromAuthResource :: AuthResource -> a - -authResourceParser :: FromAuthResource far - => Resource - -> Maybe (ParsedResource far) -authResourceParser ["check"] = - authResourceParser' AuthCheck -authResourceParser ["logout"] = - authResourceParser' AuthLogout -authResourceParser ["openid"] = - authResourceParser' AuthOpenid -authResourceParser ["openid", "forward"] = - authResourceParser' AuthOpenidForward -authResourceParser ["openid", "complete"] = - authResourceParser' AuthOpenidComplete -authResourceParser ["login", "rpxnow"] = - authResourceParser' AuthLoginRpxnow -authResourceParser _ = Nothing - -authResourceParser' :: FromAuthResource far - => AuthResource - -> Maybe (ParsedResource far) -authResourceParser' x = Just $ ParsedResource (fromAuthResource x) [] + Check + | Logout + | Openid + | OpenidForward + | OpenidComplete + | LoginRpxnow + deriving Show type RpxnowApiKey = String -- FIXME newtype -instance HasHandlers AuthResource (Maybe RpxnowApiKey) where - getHandler _ AuthCheck Get = liftHandler authCheck - getHandler _ AuthLogout Get = liftHandler authLogout - getHandler _ AuthOpenid Get = liftHandler authOpenidForm - getHandler _ AuthOpenidForward Get = liftHandler authOpenidForward - getHandler _ AuthOpenidComplete Get = liftHandler authOpenidComplete - getHandler (Just key) AuthLoginRpxnow Get = liftHandler $ rpxnowLogin key +instance ResourceName AuthResource (Maybe RpxnowApiKey) where + getHandler _ Check Get = liftHandler authCheck + getHandler _ Logout Get = liftHandler authLogout + getHandler _ Openid Get = liftHandler authOpenidForm + getHandler _ OpenidForward Get = liftHandler authOpenidForward + getHandler _ OpenidComplete Get = liftHandler authOpenidComplete + getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key getHandler _ _ _ = Nothing + allValues = + Check + : Logout + : Openid + : OpenidForward + : OpenidComplete + : LoginRpxnow + : [] + + resourcePattern Check = "/auth/check/" + resourcePattern Logout = "/auth/logout/" + resourcePattern Openid = "/auth/openid/" + resourcePattern OpenidForward = "/auth/openid/forward/" + resourcePattern OpenidComplete = "/auth/openid/complete/" + resourcePattern LoginRpxnow = "/auth/login/rpxnow/" + + data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) instance Request OIDFormReq where parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs new file mode 100644 index 00000000..f229c6d6 --- /dev/null +++ b/Web/Restful/Resource.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Resource +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Defines the Resource class. +-- +--------------------------------------------------------- +module Web.Restful.Resource + ( ResourceName (..) + , fromString + , checkPattern + ) where + +import Data.List.Split (splitOn) +import Web.Restful.Definitions +import Web.Restful.Handler + +data ResourcePatternPiece = + Static String + | Dynamic String + deriving Show + +type ResourcePattern = [ResourcePatternPiece] + +fromString :: String -> ResourcePattern +fromString = map fromString' . filter (not . null) . splitOn "/" + +fromString' :: String -> ResourcePatternPiece +fromString' ('$':rest) = Dynamic rest +fromString' x = Static x + +class Show a => ResourceName a b | a -> b where + resourcePattern :: a -> String + allValues :: [a] + getHandler :: b -> a -> Verb -> Maybe Handler + +-- FIXME add some overlap checking functions + +type SMap = [(String, String)] + +data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch + +checkPattern :: ResourcePattern -> Resource -> Maybe SMap +checkPattern rp r = + if length rp /= length r + then Nothing + else combine [] $ zipWith checkPattern' rp r + +checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn +checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch +checkPattern' (Dynamic x) y = DynamicMatch (x, y) + +combine :: SMap -> [CheckPatternReturn] -> Maybe SMap +combine s [] = Just $ reverse s +combine _ (NoMatch:_) = Nothing +combine s (StaticMatch:rest) = combine s rest +combine s (DynamicMatch x:rest) = combine (x:s) rest From 2b8131b29bd8b84709cda497de4c21a368d27028 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 24 Aug 2009 21:08:57 +0300 Subject: [PATCH 011/624] Added a Response instance --- Web/Restful/Response.hs | 4 ++++ restful.cabal | 1 + 2 files changed, 5 insertions(+) diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index a26027bd..c950ab86 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -292,3 +293,6 @@ instance Response Object where [ ("text/html", response 200 [] $ treeToHtml tree) , ("application/json", response 200 [] $ treeToJson tree) ] + +instance Response [(String, Hack.Response)] where + reps = id diff --git a/restful.cabal b/restful.cabal index 661ffd09..b8ee84d9 100644 --- a/restful.cabal +++ b/restful.cabal @@ -39,6 +39,7 @@ library Web.Restful.Definitions, Web.Restful.Handler, Web.Restful.Application, + Web.Restful.Resource, Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth From 1caa0c4891bfe2fffdcf1909b589cccd153a4506 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 28 Aug 2009 11:01:19 +0300 Subject: [PATCH 012/624] Split up Web.Restful.Response --- Data/Object/Instances.hs | 23 ++-- Web/Restful/Generic/ListDetail.hs | 55 +++++++++ Web/Restful/Response.hs | 187 ++---------------------------- Web/Restful/Response/AtomFeed.hs | 88 ++++++++++++++ Web/Restful/Response/Sitemap.hs | 90 ++++++++++++++ restful.cabal | 5 +- 6 files changed, 258 insertions(+), 190 deletions(-) create mode 100644 Web/Restful/Generic/ListDetail.hs create mode 100644 Web/Restful/Response/AtomFeed.hs create mode 100644 Web/Restful/Response/Sitemap.hs diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 6f2301ef..8b3ba8ef 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} --------------------------------------------------------- -- -- Module : Data.Object.Instances @@ -15,6 +16,7 @@ module Data.Object.Instances ( Json (..) , Yaml (..) , Html (..) + , SafeFromObject (..) ) where import Data.Object @@ -23,9 +25,12 @@ import Data.ByteString.Class import Web.Encodings (encodeJson) import qualified Text.Yaml as Y -newtype Json = Json B.ByteString -instance FromObject Json where - fromObject = return . Json . helper where +class SafeFromObject a where + safeFromObject :: Object -> a + +newtype Json = Json { unJson :: B.ByteString } +instance SafeFromObject Json where + safeFromObject = Json . helper where helper :: Object -> B.ByteString helper (Scalar s) = B.concat [ toStrictByteString "\"" @@ -50,19 +55,19 @@ instance FromObject Json where , helper v ] -newtype Yaml = Yaml B.ByteString -instance FromObject Yaml where - fromObject = return . Yaml . Y.encode +newtype Yaml = Yaml { unYaml :: B.ByteString } +instance SafeFromObject Yaml where + safeFromObject = Yaml . Y.encode -- | Represents as an entire HTML 5 document by using the following: -- -- * A scalar is a paragraph. -- * A sequence is an unordered list. -- * A mapping is a definition list. -newtype Html = Html B.ByteString +newtype Html = Html { unHtml :: B.ByteString } -instance FromObject Html where - fromObject o = return $ Html $ B.concat +instance SafeFromObject Html where + safeFromObject o = Html $ B.concat [ toStrictByteString "\n" , helper o , toStrictByteString "" diff --git a/Web/Restful/Generic/ListDetail.hs b/Web/Restful/Generic/ListDetail.hs new file mode 100644 index 00000000..00d48d57 --- /dev/null +++ b/Web/Restful/Generic/ListDetail.hs @@ -0,0 +1,55 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Generic.ListDetail +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generic responses for listing items and then detailing them. +-- +--------------------------------------------------------- +module Web.Restful.Generic.ListDetail + ( ListDetail (..) + , ItemList (..) + , ItemDetail (..) + ) where + +import Web.Restful.Response +import Web.Encodings +import Data.Object +import Data.Object.Instances +import Data.ByteString.Class + +class ToObject a => ListDetail a where + htmlDetail :: a -> String + htmlDetail = fromStrictByteString . unHtml . safeFromObject . toObject + detailTitle :: a -> String + detailUrl :: a -> String + htmlList :: [a] -> String + htmlList l = "
        " ++ concatMap helper l ++ "
      " + where + helper i = "
    • " ++ encodeHtml (detailTitle i) ++ + "
      • " + -- | Often times for the JSON response of the list, we don't need all + -- the information. + treeList :: [a] -> Object -- FIXME + treeList = Sequence . map treeListSingle + treeListSingle :: a -> Object + treeListSingle = toObject + +newtype ItemList a = ItemList [a] +instance ListDetail a => Response (ItemList a) where + reps (ItemList l) = + [ ("text/html", response 200 [] $ htmlList l) + , ("application/json", response 200 [] $ unJson $ safeFromObject $ treeList l) + ] +newtype ItemDetail a = ItemDetail a +instance ListDetail a => Response (ItemDetail a) where + reps (ItemDetail i) = + [ ("text/html", response 200 [] $ htmlDetail i) + , ("application/json", response 200 [] $ unJson $ safeFromObject $ toObject i) + ] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index c950ab86..9d5e8221 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -18,25 +18,12 @@ module Web.Restful.Response -- * Response construction Response (..) , response - -- ** Helper 'Response' instances - -- *** Atom news feed - , AtomFeed (..) - , AtomFeedEntry (..) - -- *** Sitemap - , sitemap - , SitemapUrl (..) - , SitemapLoc (..) - , SitemapChangeFreq (..) - -- *** Generics - -- **** List/detail - , ListDetail (..) - , ItemList (..) - , ItemDetail (..) - -- **** Multiple response types. - , GenResponse (..) -- * FIXME + , GenResponse (..) , ResponseWrapper (..) , ErrorResponse (..) + , formatW3 + , UTCTime ) where import Data.ByteString.Class @@ -45,10 +32,8 @@ import Data.Time.Format import Data.Time.Clock import Web.Encodings import System.Locale -import Web.Restful.Request -- FIXME ultimately remove import Data.Object import Data.List (intercalate) -import Data.Object.Instances type ContentType = String @@ -80,138 +65,6 @@ data ResponseWrapper = forall res. Response res => ResponseWrapper res instance Response ResponseWrapper where reps (ResponseWrapper res) = reps res -data AtomFeed = AtomFeed - { atomTitle :: String - , atomLinkSelf :: String - , atomLinkHome :: String - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry] - } -instance Response AtomFeed where - reps e = - [ ("application/atom+xml", response 200 [] $ show e) - ] - -data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: String - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: String - } - -instance Show AtomFeed where - show f = concat - [ "\n" - , "" - , "" - , encodeHtml $ atomTitle f - , "" - , "" - , "" - , "" - , formatW3 $ atomUpdated f - , "" - , "" - , encodeHtml $ atomLinkHome f - , "" - , concatMap show $ atomEntries f - , "" - ] - -instance Show AtomFeedEntry where - show e = concat - [ "" - , "" - , encodeHtml $ atomEntryLink e - , "" - , "" - , "" - , formatW3 $ atomEntryUpdated e - , "" - , "" - , encodeHtml $ atomEntryTitle e - , "" - , "" - , "" - ] - -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" - --- sitemaps -data SitemapLoc = AbsLoc String | RelLoc String -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never -instance Show SitemapChangeFreq where - show Always = "always" - show Hourly = "hourly" - show Daily = "daily" - show Weekly = "weekly" - show Monthly = "monthly" - show Yearly = "yearly" - show Never = "never" - -data SitemapUrl = SitemapUrl - { sitemapLoc :: SitemapLoc - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } -data SitemapRequest = SitemapRequest String Int -instance Request SitemapRequest where - parseRequest = do - env <- parseEnv - return $! SitemapRequest (Hack.serverName env) - (Hack.serverPort env) -data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] -instance Show SitemapResponse where - show (SitemapResponse (SitemapRequest host port) urls) = - "\n" ++ - "" ++ - concatMap helper urls ++ - "" - where - prefix = "http://" ++ host ++ - case port of - 80 -> "" - _ -> ":" ++ show port - helper (SitemapUrl loc modTime freq pri) = concat - [ "" - , encodeHtml $ showLoc loc - , "" - , formatW3 modTime - , "" - , show freq - , "" - , show pri - , "" - ] - showLoc (AbsLoc s) = s - showLoc (RelLoc s) = prefix ++ s - -instance Response SitemapResponse where - reps res = - [ ("text/xml", response 200 [] $ show res) - ] - -sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse -sitemap urls' req = do - urls <- urls' - return $ SitemapResponse req urls - data GenResponse = HtmlResponse String | ObjectResponse Object | HtmlOrObjectResponse String Object @@ -230,36 +83,6 @@ instance Response GenResponse where "'>" ++ encodeHtml url ++ "

      " reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] -class ToObject a => ListDetail a where - htmlDetail :: a -> String - htmlDetail = treeToHtml . toObject - detailTitle :: a -> String - detailUrl :: a -> String - htmlList :: [a] -> String - htmlList l = "
        " ++ concatMap helper l ++ "
      " - where - helper i = "
    • " ++ encodeHtml (detailTitle i) ++ - "
      • " - -- | Often times for the JSON response of the list, we don't need all - -- the information. - treeList :: [a] -> Object -- FIXME - treeList = Sequence . map treeListSingle - treeListSingle :: a -> Object - treeListSingle = toObject - -newtype ItemList a = ItemList [a] -instance ListDetail a => Response (ItemList a) where - reps (ItemList l) = - [ ("text/html", response 200 [] $ htmlList l) - , ("application/json", response 200 [] $ treeToJson $ treeList l) - ] -newtype ItemDetail a = ItemDetail a -instance ListDetail a => Response (ItemDetail a) where - reps (ItemDetail i) = - [ ("text/html", response 200 [] $ htmlDetail i) - , ("application/json", response 200 [] $ treeToJson $ toObject i) - ] -- FIXME remove treeTo functions, replace with Object instances treeToJson :: Object -> String @@ -296,3 +119,7 @@ instance Response Object where instance Response [(String, Hack.Response)] where reps = id + +-- FIXME put in a separate module (maybe Web.Encodings) +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs new file mode 100644 index 00000000..c79d9d3b --- /dev/null +++ b/Web/Restful/Response/AtomFeed.hs @@ -0,0 +1,88 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response.AtomFeed +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating atom news feeds. +-- +--------------------------------------------------------- + +module Web.Restful.Response.AtomFeed + ( AtomFeed (..) + , AtomFeedEntry (..) + ) where + +import Web.Restful.Response + +import Data.Time.Format +import Data.Time.Clock +import Web.Encodings +import System.Locale + +data AtomFeed = AtomFeed + { atomTitle :: String + , atomLinkSelf :: String + , atomLinkHome :: String + , atomUpdated :: UTCTime + , atomEntries :: [AtomFeedEntry] + } +instance Response AtomFeed where + reps e = + [ ("application/atom+xml", response 200 [] $ show e) + ] + +data AtomFeedEntry = AtomFeedEntry + { atomEntryLink :: String + , atomEntryUpdated :: UTCTime + , atomEntryTitle :: String + , atomEntryContent :: String + } + +instance Show AtomFeed where + show f = concat + [ "\n" + , "" + , "" + , encodeHtml $ atomTitle f + , "" + , "" + , "" + , "" + , formatW3 $ atomUpdated f + , "" + , "" + , encodeHtml $ atomLinkHome f + , "" + , concatMap show $ atomEntries f + , "" + ] + +instance Show AtomFeedEntry where + show e = concat + [ "" + , "" + , encodeHtml $ atomEntryLink e + , "" + , "" + , "" + , formatW3 $ atomEntryUpdated e + , "" + , "" + , encodeHtml $ atomEntryTitle e + , "" + , "" + , "" + ] diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs new file mode 100644 index 00000000..0167a9f5 --- /dev/null +++ b/Web/Restful/Response/Sitemap.hs @@ -0,0 +1,90 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response.AtomFeed +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating Google sitemap files. +-- +--------------------------------------------------------- + +module Web.Restful.Response.Sitemap + ( sitemap + , SitemapUrl (..) + , SitemapLoc (..) + , SitemapChangeFreq (..) + ) where + +import Web.Restful.Response +import Web.Encodings +import qualified Hack +import Web.Restful.Request + +data SitemapLoc = AbsLoc String | RelLoc String +data SitemapChangeFreq = Always + | Hourly + | Daily + | Weekly + | Monthly + | Yearly + | Never +instance Show SitemapChangeFreq where + show Always = "always" + show Hourly = "hourly" + show Daily = "daily" + show Weekly = "weekly" + show Monthly = "monthly" + show Yearly = "yearly" + show Never = "never" + +data SitemapUrl = SitemapUrl + { sitemapLoc :: SitemapLoc + , sitemapLastMod :: UTCTime + , sitemapChangeFreq :: SitemapChangeFreq + , priority :: Double + } +data SitemapRequest = SitemapRequest String Int +instance Request SitemapRequest where + parseRequest = do + env <- parseEnv + return $! SitemapRequest (Hack.serverName env) + (Hack.serverPort env) +data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] +instance Show SitemapResponse where + show (SitemapResponse (SitemapRequest host port) urls) = + "\n" ++ + "" ++ + concatMap helper urls ++ + "" + where + prefix = "http://" ++ host ++ + case port of + 80 -> "" + _ -> ":" ++ show port + helper (SitemapUrl loc modTime freq pri) = concat + [ "" + , encodeHtml $ showLoc loc + , "" + , formatW3 modTime + , "" + , show freq + , "" + , show pri + , "" + ] + showLoc (AbsLoc s) = s + showLoc (RelLoc s) = prefix ++ s + +instance Response SitemapResponse where + reps res = + [ ("text/xml", response 200 [] $ show res) + ] + +sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse +sitemap urls' req = do + urls <- urls' + return $ SitemapResponse req urls diff --git a/restful.cabal b/restful.cabal index b8ee84d9..8a8efa37 100644 --- a/restful.cabal +++ b/restful.cabal @@ -42,5 +42,8 @@ library Web.Restful.Resource, Data.Object.Instances, Hack.Middleware.MethodOverride, - Web.Restful.Helpers.Auth + Web.Restful.Helpers.Auth, + Web.Restful.Response.AtomFeed, + Web.Restful.Response.Sitemap, + Web.Restful.Generic.ListDetail ghc-options: -Wall From 6842ef68642a6aab2f9c989ea2b3606e289e962b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Sep 2009 22:34:34 +0300 Subject: [PATCH 013/624] Added parameter instance for day --- Web/Restful/Request.hs | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 9f98849b..4596458b 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -53,6 +53,8 @@ import Web.Restful.Constants import Web.Restful.Utils import Control.Applicative (Applicative (..)) import Web.Encodings +import Data.Time.Calendar (Day, fromGregorian) +import Data.Char (isDigit) -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -257,6 +259,24 @@ instance Parameter Int where ((x, _):_) -> Right x _ -> Left $ "Invalid integer: " ++ s +instance Parameter Day where + readParam s = + let t1 = length s == 10 + t2 = s !! 4 == '-' + t3 = s !! 7 == '-' + t4 = all isDigit $ concat + [ take 4 s + , take 2 $ drop 5 s + , take 2 $ drop 8 s + ] + t = and [t1, t2, t3, t4] + y = read $ take 4 s + m = read $ take 2 $ drop 5 s + d = read $ take 2 $ drop 8 s + in if t + then Right $ fromGregorian y m d + else Left $ "Invalid date: " ++ s + -- | The input for a resource. -- -- Each resource can define its own instance of 'Request' and then more From b728e7ff84ffb9a7f92cebfe1bd91bacf5114c41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 16 Sep 2009 23:27:37 +0300 Subject: [PATCH 014/624] Replaced ApplicationMonad with RestfulApp, version bump --- Web/Restful/Application.hs | 128 ++++++++++++++++--------------------- Web/Restful/Resource.hs | 9 +++ restful.cabal | 2 +- 3 files changed, 66 insertions(+), 73 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 1890644e..9236a35e 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,29 +18,21 @@ --------------------------------------------------------- module Web.Restful.Application ( - -- * Defining an application - ApplicationMonad - -- ** Settings - , setHtmlWrapper - -- ** Engage - , toHackApp + toHackApp + , RestfulApp (..) ) where --- hideously long import list -import qualified Hack -import Control.Monad.State hiding (gets) import Web.Encodings import Data.Maybe (isJust) -import Data.ByteString.Class -import qualified Data.ByteString.Lazy as BS import Data.Function.Predicate (equals) -import Data.Default -import Control.Applicative ( Applicative (..)) +import Data.ByteString.Class +import qualified Data.ByteString.Lazy as B -import Hack.Middleware.Gzip +import qualified Hack import Hack.Middleware.CleanPath -import Hack.Middleware.Jsonp import Hack.Middleware.ClientSession +import Hack.Middleware.Gzip +import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride import Web.Restful.Request @@ -49,61 +43,45 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource --- | Contains settings and a list of resources. -type ApplicationMonad a = State (ApplicationSettings a) -instance Applicative (ApplicationMonad a) where - pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' -data ApplicationSettings rn = ApplicationSettings - { encryptKey :: Either FilePath Word256 - , hackMiddleware :: [Hack.Middleware] - , response404 :: Hack.Env -> IO Hack.Response - , htmlWrapper :: BS.ByteString -> BS.ByteString - } +-- | A data type that can be turned into a Hack application. +class ResourceName a b => RestfulApp a b | a -> b where + -- | Load up the model, ie the data which use passed to each handler. + getModel :: a -> IO b -instance Default (ApplicationSettings a) where - def = ApplicationSettings - { encryptKey = Left defaultKeyFile - , hackMiddleware = + -- | The encryption key to be used for encrypting client sessions. + encryptKey :: a -> IO Word256 + encryptKey _ = getKey defaultKeyFile + + -- | All of the middlewares to install. + hackMiddleware :: a -> [Hack.Middleware] + hackMiddleware _ = [ gzip , cleanPath , jsonp , methodOverride ] - , response404 = default404 - , htmlWrapper = id - } -default404 :: Hack.Env -> IO Hack.Response -default404 env = return $ - Hack.Response - 404 - [("Content-Type", "text/plain")] - $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env + -- | How to generate 404 pages. FIXME make more user-friendly. + response404 :: a -> Hack.Env -> IO Hack.Response + response404 _ = default404 --- FIXME document below here + -- | Wrappers for cleaning up responses. Especially intended for + -- beautifying static HTML. FIXME more user friendly. + responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString + responseWrapper _ _ = return -setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a () -setHtmlWrapper f = do - s <- get - put $ s { htmlWrapper = f } - -toHackApp :: ResourceName a b - => ApplicationMonad a () - -> b +-- | Given a sample resource name (purely for typing reasons), generating +-- a Hack application. +toHackApp :: RestfulApp resourceName modelType + => resourceName -> IO Hack.Application -toHackApp am model = do - let settings = execState am def - key <- case encryptKey settings of - Left f -> getKey f - Right k -> return k +toHackApp a = do + model <- getModel a + key <- encryptKey a let handlers = getHandler model - app' = toHackApplication handlers settings + app' = toHackApplication a handlers clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... - app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] + app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] return app findResourceNames :: ResourceName a model @@ -125,14 +103,14 @@ takeJusts [] = [] takeJusts (Nothing:rest) = takeJusts rest takeJusts (Just x:rest) = x : takeJusts rest -toHackApplication :: ResourceName resourceName model - => HandlerMap resourceName - -> ApplicationSettings resourceName +toHackApplication :: RestfulApp resourceName model + => resourceName + -> HandlerMap resourceName -> Hack.Application -toHackApplication hm settings env = do +toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env case findResourceNames resource of - [] -> response404 settings $ env + [] -> response404 sampleRN $ env [(rn, urlParams')] -> do let verb :: Verb verb = toVerb $ Hack.requestMethod env @@ -154,16 +132,15 @@ toHackApplication hm settings env = do [] -> Nothing _ -> error "Overlapping reps" case handlerPair of - Nothing -> response404 settings $ env + Nothing -> response404 sampleRN $ env Just (ctype, Hack.Response status headers content) -> do - let wrapper = - case ctype of - "text/html" -> htmlWrapper settings - _ -> id - return $ Hack.Response status - (("Content-Type", ctype) : headers) - $ toLazyByteString $ wrapper content - Nothing -> response404 settings $ env + content' <- responseWrapper sampleRN ctype content + let response' = Hack.Response + status + (("Content-Type", ctype) : headers) + content' + return response' + Nothing -> response404 sampleRN $ env x -> error $ "Invalid matches: " ++ show x envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest @@ -177,3 +154,10 @@ envToRawRequest urlParams' env = rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] in RawRequest rawPieces urlParams' gets' posts cookies' files env + +default404 :: Hack.Env -> IO Hack.Response +default404 env = return $ + Hack.Response + 404 + [("Content-Type", "text/plain")] + $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index f229c6d6..afb1867c 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -38,8 +38,17 @@ fromString' ('$':rest) = Dynamic rest fromString' x = Static x class Show a => ResourceName a b | a -> b where + -- | Get the URL pattern for each different resource name. + -- Something like /foo/$bar/baz/ will match the regular expression + -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. resourcePattern :: a -> String + + -- | Get all possible values for resource names. + -- Remember, if you use variables ($foo) in your resourcePatterns you + -- can get an unlimited number of resources for each resource name. allValues :: [a] + + -- | Find the handler for each resource name/verb pattern. getHandler :: b -> a -> Verb -> Maybe Handler -- FIXME add some overlap checking functions diff --git a/restful.cabal b/restful.cabal index 8a8efa37..4c28e492 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.0 +version: 0.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From c3c4d647d3867c3a246ba5bf9414f91bfafb0fbb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 16 Sep 2009 23:33:34 +0300 Subject: [PATCH 015/624] Slight documentation update --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 6b699ebc..96cce18a 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,10 @@ clearly do not want to write code twice to process these requests. Instead, convert the article name into a URL parameter and then articles will have its own ResourceName. +NOTE: This has taken on a very central role in the restful library, in addition +to the RestfulApp class. Hopefully I will have a chance to document this soon. +As a result, some of the following documentation is outdated. + ### ResourceParser A ResourceParser converts a Resource (ie, a URL) to a ResourceName and URL From 86ca811ac5d3b085fecb8202ee079937e5cb796b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 18 Sep 2009 04:14:52 +0300 Subject: [PATCH 016/624] Massive revamp of responses; not yet fully functional --- Data/Object/Instances.hs | 61 ++++---- Web/Restful/Application.hs | 34 +---- Web/Restful/Generic/ListDetail.hs | 14 +- Web/Restful/Handler.hs | 30 ++-- Web/Restful/Helpers/Auth.hs | 110 +++++--------- Web/Restful/Resource.hs | 2 +- Web/Restful/Response.hs | 239 ++++++++++++++++++++---------- Web/Restful/Response/AtomFeed.hs | 7 +- Web/Restful/Response/Sitemap.hs | 10 +- restful.cabal | 2 +- 10 files changed, 266 insertions(+), 243 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 8b3ba8ef..3bb2f241 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -20,10 +20,11 @@ module Data.Object.Instances ) where import Data.Object -import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as BS import Data.ByteString.Class import Web.Encodings (encodeJson) -import qualified Text.Yaml as Y +import Text.Yaml (encode) class SafeFromObject a where safeFromObject :: Object -> a @@ -33,31 +34,31 @@ instance SafeFromObject Json where safeFromObject = Json . helper where helper :: Object -> B.ByteString helper (Scalar s) = B.concat - [ toStrictByteString "\"" + [ toLazyByteString "\"" , encodeJson $ fromStrictByteString s - , toStrictByteString "\"" + , toLazyByteString "\"" ] helper (Sequence s) = B.concat - [ toStrictByteString "[" - , B.intercalate (toStrictByteString ",") $ map helper s - , toStrictByteString "]" + [ toLazyByteString "[" + , B.intercalate (toLazyByteString ",") $ map helper s + , toLazyByteString "]" ] helper (Mapping m) = B.concat - [ toStrictByteString "{" - , B.intercalate (toStrictByteString ",") $ map helper2 m - , toStrictByteString "}" + [ toLazyByteString "{" + , B.intercalate (toLazyByteString ",") $ map helper2 m + , toLazyByteString "}" ] - helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 :: (BS.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat - [ toStrictByteString "\"" + [ toLazyByteString "\"" , encodeJson $ fromStrictByteString k - , toStrictByteString "\":" + , toLazyByteString "\":" , helper v ] newtype Yaml = Yaml { unYaml :: B.ByteString } instance SafeFromObject Yaml where - safeFromObject = Yaml . Y.encode + safeFromObject = Yaml . encode -- | Represents as an entire HTML 5 document by using the following: -- @@ -68,31 +69,31 @@ newtype Html = Html { unHtml :: B.ByteString } instance SafeFromObject Html where safeFromObject o = Html $ B.concat - [ toStrictByteString "\n" + [ toLazyByteString "\n" -- FIXME full doc or just fragment? , helper o - , toStrictByteString "" + , toLazyByteString "" ] where helper :: Object -> B.ByteString helper (Scalar s) = B.concat - [ toStrictByteString "

      " - , s - , toStrictByteString "

      " + [ toLazyByteString "

      " + , toLazyByteString s + , toLazyByteString "

      " ] - helper (Sequence []) = toStrictByteString "
        " + helper (Sequence []) = toLazyByteString "
          " helper (Sequence s) = B.concat - [ toStrictByteString "
          • " - , B.intercalate (toStrictByteString "
          • ") $ map helper s - , toStrictByteString "
          " + [ toLazyByteString "
          • " + , B.intercalate (toLazyByteString "
          • ") $ map helper s + , toLazyByteString "
          " ] helper (Mapping m) = B.concat $ - toStrictByteString "
          " : + toLazyByteString "
          " : map helper2 m ++ - [ toStrictByteString "
          " ] - helper2 :: (B.ByteString, Object) -> B.ByteString + [ toLazyByteString "
          " ] + helper2 :: (BS.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat $ - [ toStrictByteString "
          " - , k - , toStrictByteString "
          " + [ toLazyByteString "
          " + , toLazyByteString k + , toLazyByteString "
          " , helper v - , toStrictByteString "
          " + , toLazyByteString "" ] diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 9236a35e..529910ba 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,8 +23,6 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.Maybe (isJust) -import Data.Function.Predicate (equals) import Data.ByteString.Class import qualified Data.ByteString.Lazy as B @@ -105,7 +103,7 @@ takeJusts (Just x:rest) = x : takeJusts rest toHackApplication :: RestfulApp resourceName model => resourceName - -> HandlerMap resourceName + -> (resourceName -> Verb -> Handler) -> Hack.Application toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env @@ -116,31 +114,11 @@ toHackApplication sampleRN hm env = do verb = toVerb $ Hack.requestMethod env rr :: RawRequest rr = envToRawRequest urlParams' env - case hm rn verb of - (Just handler) -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- runHandler handler rr - let reps' = reps body - ctypes = filter (\c -> isJust $ lookup c reps') ctypes' - let handlerPair = - case ctypes of - [] -> Just $ head reps' - (c:_) -> - case filter (fst `equals` c) reps' of - [pair] -> Just pair - [] -> Nothing - _ -> error "Overlapping reps" - case handlerPair of - Nothing -> response404 sampleRN $ env - Just (ctype, Hack.Response status headers content) -> do - content' <- responseWrapper sampleRN ctype content - let response' = Hack.Response - status - (("Content-Type", ctype) : headers) - content' - return response' - Nothing -> response404 sampleRN $ env + handler :: Handler + handler = hm rn verb + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + runResponse (handler rr) ctypes' x -> error $ "Invalid matches: " ++ show x envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest diff --git a/Web/Restful/Generic/ListDetail.hs b/Web/Restful/Generic/ListDetail.hs index 00d48d57..6c4c45e7 100644 --- a/Web/Restful/Generic/ListDetail.hs +++ b/Web/Restful/Generic/ListDetail.hs @@ -25,7 +25,7 @@ import Data.ByteString.Class class ToObject a => ListDetail a where htmlDetail :: a -> String - htmlDetail = fromStrictByteString . unHtml . safeFromObject . toObject + htmlDetail = fromLazyByteString . unHtml . safeFromObject . toObject detailTitle :: a -> String detailUrl :: a -> String htmlList :: [a] -> String @@ -42,14 +42,14 @@ class ToObject a => ListDetail a where treeListSingle = toObject newtype ItemList a = ItemList [a] -instance ListDetail a => Response (ItemList a) where +instance ListDetail a => HasReps (ItemList a) where reps (ItemList l) = - [ ("text/html", response 200 [] $ htmlList l) - , ("application/json", response 200 [] $ unJson $ safeFromObject $ treeList l) + [ ("text/html", toLazyByteString $ htmlList l) + , ("application/json", unJson $ safeFromObject $ treeList l) ] newtype ItemDetail a = ItemDetail a -instance ListDetail a => Response (ItemDetail a) where +instance ListDetail a => HasReps (ItemDetail a) where reps (ItemDetail i) = - [ ("text/html", response 200 [] $ htmlDetail i) - , ("application/json", response 200 [] $ unJson $ safeFromObject $ toObject i) + [ ("text/html", toLazyByteString $ htmlDetail i) + , ("application/json", unJson $ safeFromObject $ toObject i) ] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index b4a1f1fa..074240b6 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -15,28 +15,26 @@ -- --------------------------------------------------------- module Web.Restful.Handler - ( Handler (..) - , runHandler - , HandlerMap + ( Handler , liftHandler + , noHandler ) where -import Web.Restful.Definitions import Web.Restful.Request import Web.Restful.Response -data Handler = forall req. Request req => Handler (req -> IO ResponseWrapper) +type Handler = RawRequest -> Response -runHandler :: Handler -> RawRequest -> IO ResponseWrapper -runHandler (Handler f) rreq = do - let rparser = parseRequest - case runRequestParser rparser rreq of +liftHandler :: (Request req, HasReps rep) + => (req -> ResponseIO rep) + -> Handler +liftHandler f req = liftRequest req >>= wrapResponse . f + +liftRequest :: (Request req, Monad m) => RawRequest -> m req +liftRequest r = + case runRequestParser parseRequest r of Left errors -> fail $ unlines errors -- FIXME - Right req -> f req + Right req -> return req -type HandlerMap a = a -> Verb -> Maybe Handler - -liftHandler :: (Request req, Response res) - => (req -> IO res) - -> Maybe Handler -liftHandler f = Just . Handler $ fmap ResponseWrapper . f +noHandler :: Handler +noHandler = const notFound diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 7d2c2481..7844e2c9 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -26,10 +26,10 @@ import Web.Restful import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) import Control.Monad.Reader import Data.Object +import Data.Maybe (fromMaybe) data AuthResource = Check @@ -48,7 +48,7 @@ instance ResourceName AuthResource (Maybe RpxnowApiKey) where getHandler _ OpenidForward Get = liftHandler authOpenidForward getHandler _ OpenidComplete Get = liftHandler authOpenidComplete getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key - getHandler _ _ _ = Nothing + getHandler _ _ _ = noHandler allValues = Check @@ -74,24 +74,20 @@ instance Show OIDFormReq where show (OIDFormReq Nothing _) = "" show (OIDFormReq (Just s) _) = "

          " ++ encodeHtml s ++ "

          " -data OIDFormRes = OIDFormRes String (Maybe String) -instance Response OIDFormRes where - reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] - where - heads = - case dest of - Nothing -> [] - Just dest' -> - [("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")] -authOpenidForm :: OIDFormReq -> IO OIDFormRes -authOpenidForm m@(OIDFormReq _ dest) = + +authOpenidForm :: OIDFormReq -> ResponseIO GenResponse +authOpenidForm m@(OIDFormReq _ dest) = do let html = show m ++ "
          " ++ "OpenID: " ++ "" ++ "
          " - in return $! OIDFormRes html dest + case dest of + Just dest' -> addCookie 20 "DEST" dest' + Nothing -> return () + return $! HtmlResponse html + data OIDFReq = OIDFReq String String instance Request OIDFReq where parseRequest = do @@ -101,14 +97,13 @@ instance Request OIDFReq where show (Hack.serverPort env) ++ "/auth/openid/complete/" return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward :: OIDFReq -> Response authOpenidForward (OIDFReq oid complete) = do - res <- OpenId.getForwardUrl oid complete :: IO (Either String String) - return $ - case res of - Left err -> RedirectResponse $ "/auth/openid/?message=" ++ - encodeUrl err - Right url -> RedirectResponse url + res <- liftIO $ OpenId.getForwardUrl oid complete + case res of + Left err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (err :: String) + Right url -> redirect url data OIDComp = OIDComp [(String, String)] (Maybe String) instance Request OIDComp where @@ -117,35 +112,17 @@ instance Request OIDComp where let gets = rawGetParams rr dest <- cookieParam "DEST" return $! OIDComp gets dest -data OIDCompRes = OIDCompResErr String - | OIDCompResGood String (Maybe String) -instance Response OIDCompRes where - reps (OIDCompResErr err) = - reps $ RedirectResponse - $ "/auth/openid/?message=" ++ - encodeUrl err - reps (OIDCompResGood ident Nothing) = - reps $ OIDCompResGood ident (Just "/") - reps (OIDCompResGood ident (Just dest)) = - [("text/plain", response 303 heads "")] where - heads = - [ (authCookieName, ident) - , resetCookie "DEST" - , ("Location", dest) - ] -resetCookie :: String -> (String, String) -resetCookie name = - ("Set-Cookie", - name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") - -authOpenidComplete :: OIDComp -> IO OIDCompRes +authOpenidComplete :: OIDComp -> Response authOpenidComplete (OIDComp gets' dest) = do - res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) - return $ - case res of - Left err -> OIDCompResErr err - Right (OpenId.Identifier ident) -> OIDCompResGood ident dest + res <- liftIO $ OpenId.authenticate gets' + case res of + Left err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (err :: String) + Right (OpenId.Identifier ident) -> do + deleteCookie "DEST" + header authCookieName ident + redirect $ fromMaybe "/" dest -- | token dest data RpxnowRequest = RpxnowRequest String (Maybe String) @@ -159,34 +136,25 @@ chopHash :: String -> String chopHash ('#':rest) = rest chopHash x = x --- | dest identifier -data RpxnowResponse = RpxnowResponse String (Maybe String) -instance Response RpxnowResponse where - reps (RpxnowResponse dest Nothing) = - [("text/html", response 303 [("Location", dest)] "")] - reps (RpxnowResponse dest (Just ident)) = - [("text/html", response 303 - [ ("Location", dest) - , (authCookieName, ident) - ] - "")] - rpxnowLogin :: String -- ^ api key -> RpxnowRequest - -> IO RpxnowResponse + -> Response rpxnowLogin apiKey (RpxnowRequest token dest') = do let dest = case dest' of Nothing -> "/" Just "" -> "/" Just s -> s - ident' <- Rpxnow.authenticate apiKey token - return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') + ident' <- liftIO $ Rpxnow.authenticate apiKey token + case ident' of + Nothing -> return () + Just ident -> header authCookieName $ Rpxnow.identifier ident + redirect dest data AuthRequest = AuthRequest (Maybe String) instance Request AuthRequest where parseRequest = AuthRequest `fmap` identifier -authCheck :: AuthRequest -> IO Object +authCheck :: AuthRequest -> ResponseIO Object authCheck (AuthRequest Nothing) = return $ toObject [("status", "notloggedin")] authCheck (AuthRequest (Just i)) = @@ -195,13 +163,7 @@ authCheck (AuthRequest (Just i)) = , ("ident", i) ] -authLogout :: () -> IO LogoutResponse -authLogout _ = return LogoutResponse - -data LogoutResponse = LogoutResponse -instance Response LogoutResponse where - reps _ = map (second addCookie) $ reps tree where - tree = toObject [("status", "loggedout")] - addCookie (Hack.Response s h c) = - Hack.Response s (h':h) c - h' = resetCookie authCookieName +authLogout :: () -> ResponseIO Object +authLogout _ = do + deleteCookie authCookieName + return $ toObject [("status", "loggedout")] diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index afb1867c..2470c70d 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -49,7 +49,7 @@ class Show a => ResourceName a b | a -> b where allValues :: [a] -- | Find the handler for each resource name/verb pattern. - getHandler :: b -> a -> Verb -> Maybe Handler + getHandler :: b -> a -> Verb -> Handler -- FIXME add some overlap checking functions diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 9d5e8221..19db94d4 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -14,110 +15,192 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( - -- * Response construction - Response (..) - , response - -- * FIXME + ( formatW3 + , HasReps (..) + , notFound + , wrapResponse + , ResponseIO + , ResponseT + , Response + , runResponse + , deleteCookie + , redirect + , addCookie + , header , GenResponse (..) - , ResponseWrapper (..) - , ErrorResponse (..) - , formatW3 - , UTCTime + , liftIO ) where import Data.ByteString.Class -import qualified Hack import Data.Time.Format import Data.Time.Clock -import Web.Encodings import System.Locale import Data.Object -import Data.List (intercalate) +import qualified Data.ByteString.Lazy as B +import Data.Object.Instances +import Data.Maybe (fromJust) + +import Control.Monad.Trans + +import qualified Hack type ContentType = String --- | The output for a resource. -class Response a where - -- | Provide an ordered list of possible responses, depending on content - -- type. If the user asked for a specific response type (like +-- | Something which can be represented as multiple content types. +-- Each content type is called a representation of the data. +class HasReps a where + -- | Provide an ordered list of possible representations, depending on + -- content type. If the user asked for a specific response type (like -- text/html), then that will get priority. If not, then the first -- element in this list will be used. - reps :: a -> [(ContentType, Hack.Response)] + reps :: a -> [(ContentType, B.ByteString)] --- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be --- used for the body. -response :: LazyByteString lbs - => Int - -> [(String, String)] - -> lbs - -> Hack.Response -response a b c = Hack.Response a b $ toLazyByteString c +-- | Wrap up any instance of 'HasReps'. +data HasRepsW = forall a. HasReps a => HasRepsW a -instance Response () where - reps _ = [("text/plain", response 200 [] "")] +instance HasReps HasRepsW where + reps (HasRepsW r) = reps r -newtype ErrorResponse = ErrorResponse String -instance Response ErrorResponse where - reps (ErrorResponse s) = [("text/plain", response 500 [] s)] +-- | The result of a request. This does not include possible headers. +data Result = + Redirect String + | NotFound + | InternalError String + | Content HasRepsW -data ResponseWrapper = forall res. Response res => ResponseWrapper res -instance Response ResponseWrapper where - reps (ResponseWrapper res) = reps res +instance HasReps Result where + reps (Redirect s) = [("text/plain", toLazyByteString s)] + reps NotFound = [("text/plain", toLazyByteString "not found")] -- FIXME use the real 404 page + reps (InternalError s) = [("text/plain", toLazyByteString s)] + reps (Content r) = reps r + +getStatus :: Result -> Int +getStatus (Redirect _) = 303 +getStatus NotFound = 404 +getStatus (InternalError _) = 500 +getStatus (Content _) = 200 + +getHeaders :: Result -> [Header] +getHeaders (Redirect s) = [Header "Location" s] +getHeaders _ = [] + +newtype ResponseT m a = ResponseT (m (Either Result a, [Header])) +type ResponseIO = ResponseT IO +type Response = ResponseIO HasRepsW + +runResponse :: Response -> [ContentType] -> IO Hack.Response +runResponse (ResponseT inside) ctypesAll = do + (x, headers') <- inside + let extraHeaders = + case x of + Left r -> getHeaders r + Right _ -> [] + headers <- mapM toPair (headers' ++ extraHeaders) + let outReps = either reps reps x + let statusCode = + case x of + Left r -> getStatus r + Right _ -> 200 + (ctype, finalRep) <- chooseRep outReps ctypesAll + let headers'' = ("Content-Type", ctype) : headers + return $! Hack.Response statusCode headers'' finalRep + +chooseRep :: Monad m + => [(ContentType, B.ByteString)] + -> [ContentType] + -> m (ContentType, B.ByteString) +chooseRep rs cs + | length rs == 0 = fail "All reps must have at least one value" + | otherwise = do + let availCs = map fst rs + case filter (`elem` availCs) cs of + [] -> return $ head rs + [ctype] -> return (ctype, fromJust $ lookup ctype rs) + _ -> fail "Overlapping representations" + +toPair :: Header -> IO (String, String) +toPair (AddCookie minutes key value) = do + now <- getCurrentTime + let expires = addUTCTime (fromIntegral $ minutes * 60) now + return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires=" + ++ formatW3 expires) +toPair (DeleteCookie key) = return + ("Set-Cookie", + key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") +toPair (Header key value) = return (key, value) + +wrapResponse :: (Monad m, HasReps rep) + => ResponseT m rep + -> ResponseT m HasRepsW +wrapResponse = fmap HasRepsW + +instance MonadTrans ResponseT where + lift ma = ResponseT $ do + a <- ma + return (Right a, []) + +instance MonadIO ResponseIO where + liftIO = lift + +redirect :: Monad m => String -> ResponseT m a +redirect s = ResponseT (return (Left $ Redirect s, [])) + +notFound :: Monad m => ResponseT m a +notFound = ResponseT (return (Left NotFound, [])) + +instance Monad m => Functor (ResponseT m) where + fmap f x = x >>= return . f + +instance Monad m => Monad (ResponseT m) where + return = lift . return + fail s = ResponseT (return (Left $ InternalError s, [])) + (ResponseT mx) >>= f = ResponseT $ do + (x, hs1) <- mx + case x of + Left x' -> return (Left x', hs1) + Right a -> do + let (ResponseT b') = f a + (b, hs2) <- b' + return (b, hs1 ++ hs2) + +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int String String + | DeleteCookie String + | Header String String + +addCookie :: Monad m => Int -> String -> String -> ResponseT m () +addCookie a b c = addHeader $ AddCookie a b c + +deleteCookie :: Monad m => String -> ResponseT m () +deleteCookie = addHeader . DeleteCookie + +header :: Monad m => String -> String -> ResponseT m () +header a b = addHeader $ Header a b + +addHeader :: Monad m => Header -> ResponseT m () +addHeader h = ResponseT (return (Right (), [h])) + +instance HasReps () where + reps _ = [("text/plain", toLazyByteString "")] data GenResponse = HtmlResponse String | ObjectResponse Object | HtmlOrObjectResponse String Object - | RedirectResponse String - | PermissionDeniedResult String - | NotFoundResponse String -instance Response GenResponse where - reps (HtmlResponse h) = [("text/html", response 200 [] h)] +instance HasReps GenResponse where + reps (HtmlResponse h) = [("text/html", toLazyByteString h)] reps (ObjectResponse t) = reps t reps (HtmlOrObjectResponse h t) = - ("text/html", response 200 [] h) : reps t - reps (RedirectResponse url) = [("text/html", response 303 heads body)] - where - heads = [("Location", url)] - body = "

          Redirecting to " ++ encodeHtml url ++ "

          " - reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] - reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] + ("text/html", toLazyByteString h) : reps t --- FIXME remove treeTo functions, replace with Object instances -treeToJson :: Object -> String -treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\"" -treeToJson (Sequence l) = - "[" ++ intercalate "," (map treeToJson l) ++ "]" -treeToJson (Mapping m) = - "{" ++ intercalate "," (map helper m) ++ "}" where - helper (k, v) = - treeToJson (Scalar k) ++ - ":" ++ - treeToJson v - -treeToHtml :: Object -> String -treeToHtml (Scalar s) = encodeHtml $ fromStrictByteString s -treeToHtml (Sequence l) = - "
            " ++ concatMap (\e -> "
          • " ++ treeToHtml e ++ "
            • ") l ++ - "
          " -treeToHtml (Mapping m) = - "
          " ++ - concatMap (\(k, v) -> "
          " ++ - encodeHtml (fromStrictByteString k) ++ - "
          " ++ - "
          " ++ - treeToHtml v ++ - "
          ") m ++ - "
          " - -instance Response Object where - reps tree = - [ ("text/html", response 200 [] $ treeToHtml tree) - , ("application/json", response 200 [] $ treeToJson tree) +instance HasReps Object where + reps o = + [ ("text/html", unHtml $ safeFromObject o) + , ("application/json", unJson $ safeFromObject o) + , ("text/yaml", unYaml $ safeFromObject o) ] -instance Response [(String, Hack.Response)] where +instance HasReps [(ContentType, B.ByteString)] where reps = id -- FIXME put in a separate module (maybe Web.Encodings) diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index c79d9d3b..8f093a49 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -19,10 +19,9 @@ module Web.Restful.Response.AtomFeed import Web.Restful.Response -import Data.Time.Format import Data.Time.Clock import Web.Encodings -import System.Locale +import Data.ByteString.Class data AtomFeed = AtomFeed { atomTitle :: String @@ -31,9 +30,9 @@ data AtomFeed = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance Response AtomFeed where +instance HasReps AtomFeed where reps e = - [ ("application/atom+xml", response 200 [] $ show e) + [ ("application/atom+xml", toLazyByteString $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 0167a9f5..92f2566a 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -23,6 +23,8 @@ import Web.Restful.Response import Web.Encodings import qualified Hack import Web.Restful.Request +import Data.ByteString.Class +import Data.Time (UTCTime) data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always @@ -79,12 +81,12 @@ instance Show SitemapResponse where showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s -instance Response SitemapResponse where +instance HasReps SitemapResponse where reps res = - [ ("text/xml", response 200 [] $ show res) + [ ("text/xml", toLazyByteString $ show res) ] -sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse +sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse sitemap urls' req = do - urls <- urls' + urls <- liftIO urls' return $ SitemapResponse req urls diff --git a/restful.cabal b/restful.cabal index 4c28e492..a2f3f781 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.1 +version: 0.1.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From c75c72d9cb21d12042afe2fe9cce33896bf26f45 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 18 Sep 2009 09:36:47 +0300 Subject: [PATCH 017/624] Response wrapping and error handling done properly --- Web/Restful/Application.hs | 48 ++++++++++++++++++-------------------- Web/Restful/Request.hs | 4 ++++ Web/Restful/Response.hs | 32 ++++++++++++------------- 3 files changed, 42 insertions(+), 42 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 529910ba..0ac40106 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,8 +23,8 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.ByteString.Class import qualified Data.ByteString.Lazy as B +import Data.Object import qualified Hack import Hack.Middleware.CleanPath @@ -59,15 +59,19 @@ class ResourceName a b => RestfulApp a b | a -> b where , methodOverride ] - -- | How to generate 404 pages. FIXME make more user-friendly. - response404 :: a -> Hack.Env -> IO Hack.Response - response404 _ = default404 - -- | Wrappers for cleaning up responses. Especially intended for -- beautifying static HTML. FIXME more user friendly. responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString responseWrapper _ _ = return + -- | Output error response pages. + errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW + errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr + errorHandler _ _ (Redirect url) = + HasRepsW $ toObject $ "Redirect to: " ++ url + errorHandler _ _ (InternalError e) = + HasRepsW $ toObject $ "Internal server error: " ++ e + -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. toHackApp :: RestfulApp resourceName modelType @@ -107,19 +111,20 @@ toHackApplication :: RestfulApp resourceName model -> Hack.Application toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env - case findResourceNames resource of - [] -> response404 sampleRN $ env - [(rn, urlParams')] -> do - let verb :: Verb - verb = toVerb $ Hack.requestMethod env - rr :: RawRequest - rr = envToRawRequest urlParams' env - handler :: Handler - handler = hm rn verb - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - runResponse (handler rr) ctypes' - x -> error $ "Invalid matches: " ++ show x + let (handler, urlParams') = + case findResourceNames resource of + [] -> (noHandler, []) + [(rn, urlParams'')] -> + let verb = toVerb $ Hack.requestMethod env + in (hm rn verb, urlParams'') + x -> error $ "Invalid findResourceNames: " ++ show x + let rr = envToRawRequest urlParams' env + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + runResponse (errorHandler sampleRN rr) + (responseWrapper sampleRN) + ctypes' + (handler rr) envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = @@ -132,10 +137,3 @@ envToRawRequest urlParams' env = rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] in RawRequest rawPieces urlParams' gets' posts cookies' files env - -default404 :: Hack.Env -> IO Hack.Response -default404 env = return $ - Hack.Response - 404 - [("Content-Type", "text/plain")] - $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 4596458b..789de3ec 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------- -- -- Module : Web.Restful.Request @@ -210,6 +211,9 @@ data RawRequest = RawRequest , rawFiles :: [(ParamName, FileInfo)] , rawEnv :: Hack.Env } + deriving Show + +deriving instance Show FileInfo -- | All GET paramater values with the given name. getParams :: RawRequest -> ParamName -> [ParamValue] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 19db94d4..98fc13d8 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -29,6 +29,8 @@ module Web.Restful.Response , header , GenResponse (..) , liftIO + , ErrorResult (..) + , HasRepsW (..) ) where import Data.ByteString.Class @@ -61,47 +63,43 @@ data HasRepsW = forall a. HasReps a => HasRepsW a instance HasReps HasRepsW where reps (HasRepsW r) = reps r --- | The result of a request. This does not include possible headers. -data Result = +data ErrorResult = Redirect String | NotFound | InternalError String - | Content HasRepsW -instance HasReps Result where - reps (Redirect s) = [("text/plain", toLazyByteString s)] - reps NotFound = [("text/plain", toLazyByteString "not found")] -- FIXME use the real 404 page - reps (InternalError s) = [("text/plain", toLazyByteString s)] - reps (Content r) = reps r - -getStatus :: Result -> Int +getStatus :: ErrorResult -> Int getStatus (Redirect _) = 303 getStatus NotFound = 404 getStatus (InternalError _) = 500 -getStatus (Content _) = 200 -getHeaders :: Result -> [Header] +getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] getHeaders _ = [] -newtype ResponseT m a = ResponseT (m (Either Result a, [Header])) +newtype ResponseT m a = ResponseT (m (Either ErrorResult a, [Header])) type ResponseIO = ResponseT IO type Response = ResponseIO HasRepsW -runResponse :: Response -> [ContentType] -> IO Hack.Response -runResponse (ResponseT inside) ctypesAll = do +runResponse :: (ErrorResult -> HasRepsW) + -> (ContentType -> B.ByteString -> IO B.ByteString) + -> [ContentType] + -> Response + -> IO Hack.Response +runResponse eh wrapper ctypesAll (ResponseT inside) = do (x, headers') <- inside let extraHeaders = case x of Left r -> getHeaders r Right _ -> [] headers <- mapM toPair (headers' ++ extraHeaders) - let outReps = either reps reps x + let outReps = either (reps . eh) reps x let statusCode = case x of Left r -> getStatus r Right _ -> 200 - (ctype, finalRep) <- chooseRep outReps ctypesAll + (ctype, selectedRep) <- chooseRep outReps ctypesAll + finalRep <- wrapper ctype selectedRep let headers'' = ("Content-Type", ctype) : headers return $! Hack.Response statusCode headers'' finalRep From 649661e13351ce8d9ebfedc6c89508ca93ddfc3e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 18 Sep 2009 13:29:08 +0300 Subject: [PATCH 018/624] Added ByteStringResponse and TODO list --- TODO | 2 ++ Web/Restful/Response.hs | 6 ++++++ 2 files changed, 8 insertions(+) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 00000000..7fb61ea3 --- /dev/null +++ b/TODO @@ -0,0 +1,2 @@ +Static files and directories +Better error handling for invalid arguments (currently 500 error) diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 98fc13d8..f0db694b 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -31,6 +31,7 @@ module Web.Restful.Response , liftIO , ErrorResult (..) , HasRepsW (..) + , byteStringResponse ) where import Data.ByteString.Class @@ -185,11 +186,16 @@ instance HasReps () where data GenResponse = HtmlResponse String | ObjectResponse Object | HtmlOrObjectResponse String Object + | ByteStringResponse ContentType B.ByteString instance HasReps GenResponse where reps (HtmlResponse h) = [("text/html", toLazyByteString h)] reps (ObjectResponse t) = reps t reps (HtmlOrObjectResponse h t) = ("text/html", toLazyByteString h) : reps t + reps (ByteStringResponse ct con) = [(ct, con)] + +byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse +byteStringResponse ct = ByteStringResponse ct . toLazyByteString instance HasReps Object where reps o = From 4a0d7baa68ec3d1e62b7a811d4831b980b976101 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 20 Sep 2009 23:26:30 +0300 Subject: [PATCH 019/624] Slurp paths and static helper --- TODO | 1 + Web/Restful/Helpers/Auth.hs | 2 +- Web/Restful/Helpers/Static.hs | 54 +++++++++++++++++++++++++++++++++++ Web/Restful/Resource.hs | 25 +++++++++++++--- Web/Restful/Response.hs | 6 +++- restful.cabal | 1 + 6 files changed, 83 insertions(+), 6 deletions(-) create mode 100644 Web/Restful/Helpers/Static.hs diff --git a/TODO b/TODO index 7fb61ea3..443e2ed8 100644 --- a/TODO +++ b/TODO @@ -1,2 +1,3 @@ Static files and directories Better error handling for invalid arguments (currently 500 error) +Include request getting in Response monad. diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 7844e2c9..067cd551 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do case dest of Just dest' -> addCookie 20 "DEST" dest' Nothing -> return () - return $! HtmlResponse html + return $! htmlResponse html data OIDFReq = OIDFReq String String instance Request OIDFReq where diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs new file mode 100644 index 00000000..9d88131c --- /dev/null +++ b/Web/Restful/Helpers/Static.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Helpers.Static +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Serve static files from a Restful app. +-- +--------------------------------------------------------- +module Web.Restful.Helpers.Static + ( serveStatic + , FileLookup + ) where + +import qualified Data.ByteString as B + +import Web.Restful + +type FileLookup = FilePath -> IO (Maybe B.ByteString) + +serveStatic :: FileLookup -> Verb -> Handler +serveStatic fl Get = liftHandler $ getStatic fl +serveStatic _ _ = noHandler + +newtype StaticReq = StaticReq FilePath +instance Request StaticReq where + parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for .. + +getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse +getStatic fl (StaticReq fp) = do + content <- liftIO $ fl fp + case content of + Nothing -> notFound + Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs + +mimeType :: String -> String +mimeType "jpg" = "image/jpeg" +mimeType "jpeg" = "image/jpeg" +mimeType "js" = "text/javascript" +mimeType "css" = "text/css" +mimeType "html" = "text/html" +mimeType "png" = "image/png" +mimeType "gif" = "image/gif" +mimeType "txt" = "text/plain" +mimeType _ = "application/octet-stream" + +ext :: String -> String +ext = reverse . fst . break (== '.') . reverse diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 2470c70d..d253edb3 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -22,12 +22,18 @@ module Web.Restful.Resource import Data.List.Split (splitOn) import Web.Restful.Definitions import Web.Restful.Handler +import Data.List (intercalate) data ResourcePatternPiece = Static String | Dynamic String + | Slurp String -- ^ take up the rest of the pieces. must be last deriving Show +isSlurp :: ResourcePatternPiece -> Bool +isSlurp (Slurp _) = True +isSlurp _ = False + type ResourcePattern = [ResourcePatternPiece] fromString :: String -> ResourcePattern @@ -35,12 +41,16 @@ fromString = map fromString' . filter (not . null) . splitOn "/" fromString' :: String -> ResourcePatternPiece fromString' ('$':rest) = Dynamic rest +fromString' ('*':rest) = Slurp rest fromString' x = Static x class Show a => ResourceName a b | a -> b where -- | Get the URL pattern for each different resource name. -- Something like /foo/$bar/baz/ will match the regular expression -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. + -- + -- Also, /foo/*bar/ will match /foo/[anything else], capturing the value + -- into the bar urlParam. resourcePattern :: a -> String -- | Get all possible values for resource names. @@ -58,14 +68,21 @@ type SMap = [(String, String)] data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch checkPattern :: ResourcePattern -> Resource -> Maybe SMap -checkPattern rp r = - if length rp /= length r - then Nothing - else combine [] $ zipWith checkPattern' rp r +checkPattern rp r + | length rp /= 0 && isSlurp (last rp) = do + let rp' = init rp + (r1, r2) = splitAt (length rp') r + smap <- checkPattern rp' r1 + let slurpValue = intercalate "/" r2 + Slurp slurpKey = last rp + return $ (slurpKey, slurpValue) : smap + | length rp /= length r = Nothing + | otherwise = combine [] $ zipWith checkPattern' rp r checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch checkPattern' (Dynamic x) y = DynamicMatch (x, y) +checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" combine :: SMap -> [CheckPatternReturn] -> Maybe SMap combine s [] = Just $ reverse s diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index f0db694b..5336bfb9 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -32,6 +32,7 @@ module Web.Restful.Response , ErrorResult (..) , HasRepsW (..) , byteStringResponse + , htmlResponse ) where import Data.ByteString.Class @@ -183,7 +184,7 @@ addHeader h = ResponseT (return (Right (), [h])) instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] -data GenResponse = HtmlResponse String +data GenResponse = HtmlResponse B.ByteString | ObjectResponse Object | HtmlOrObjectResponse String Object | ByteStringResponse ContentType B.ByteString @@ -197,6 +198,9 @@ instance HasReps GenResponse where byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse byteStringResponse ct = ByteStringResponse ct . toLazyByteString +htmlResponse :: LazyByteString lbs => lbs -> GenResponse +htmlResponse = HtmlResponse . toLazyByteString + instance HasReps Object where reps o = [ ("text/html", unHtml $ safeFromObject o) diff --git a/restful.cabal b/restful.cabal index a2f3f781..73dce39d 100644 --- a/restful.cabal +++ b/restful.cabal @@ -43,6 +43,7 @@ library Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth, + Web.Restful.Helpers.Static, Web.Restful.Response.AtomFeed, Web.Restful.Response.Sitemap, Web.Restful.Generic.ListDetail From f4dc87bab6430d782474fa0b0e84c076d1f67ed7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Sep 2009 00:02:38 +0300 Subject: [PATCH 020/624] getRequest for the Response monad --- TODO | 2 -- Web/Restful/Application.hs | 3 ++- Web/Restful/Handler.hs | 14 +++++-------- Web/Restful/Response.hs | 40 ++++++++++++++++++++++++++------------ 4 files changed, 35 insertions(+), 24 deletions(-) diff --git a/TODO b/TODO index 443e2ed8..052dfd91 100644 --- a/TODO +++ b/TODO @@ -1,3 +1 @@ -Static files and directories Better error handling for invalid arguments (currently 500 error) -Include request getting in Response monad. diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 0ac40106..3c61f556 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -124,7 +124,8 @@ toHackApplication sampleRN hm env = do runResponse (errorHandler sampleRN rr) (responseWrapper sampleRN) ctypes' - (handler rr) + handler + rr envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 074240b6..bcfd86f9 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -23,18 +23,14 @@ module Web.Restful.Handler import Web.Restful.Request import Web.Restful.Response -type Handler = RawRequest -> Response +type Handler = Response -- FIXME maybe move some stuff around now... liftHandler :: (Request req, HasReps rep) => (req -> ResponseIO rep) -> Handler -liftHandler f req = liftRequest req >>= wrapResponse . f - -liftRequest :: (Request req, Monad m) => RawRequest -> m req -liftRequest r = - case runRequestParser parseRequest r of - Left errors -> fail $ unlines errors -- FIXME - Right req -> return req +liftHandler f = do + req <- getRequest + wrapResponse $ f req noHandler :: Handler -noHandler = const notFound +noHandler = notFound diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 5336bfb9..b5d1c1fb 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -33,6 +33,7 @@ module Web.Restful.Response , HasRepsW (..) , byteStringResponse , htmlResponse + , getRequest ) where import Data.ByteString.Class @@ -44,7 +45,10 @@ import qualified Data.ByteString.Lazy as B import Data.Object.Instances import Data.Maybe (fromJust) +import Web.Restful.Request + import Control.Monad.Trans +import Control.Monad (liftM) import qualified Hack @@ -79,7 +83,8 @@ getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] getHeaders _ = [] -newtype ResponseT m a = ResponseT (m (Either ErrorResult a, [Header])) +newtype ResponseT m a = + ResponseT (RawRequest -> m (Either ErrorResult a, [Header])) type ResponseIO = ResponseT IO type Response = ResponseIO HasRepsW @@ -87,9 +92,10 @@ runResponse :: (ErrorResult -> HasRepsW) -> (ContentType -> B.ByteString -> IO B.ByteString) -> [ContentType] -> Response + -> RawRequest -> IO Hack.Response -runResponse eh wrapper ctypesAll (ResponseT inside) = do - (x, headers') <- inside +runResponse eh wrapper ctypesAll (ResponseT inside) rr = do + (x, headers') <- inside rr let extraHeaders = case x of Left r -> getHeaders r @@ -135,7 +141,7 @@ wrapResponse :: (Monad m, HasReps rep) wrapResponse = fmap HasRepsW instance MonadTrans ResponseT where - lift ma = ResponseT $ do + lift ma = ResponseT $ const $ do a <- ma return (Right a, []) @@ -143,24 +149,24 @@ instance MonadIO ResponseIO where liftIO = lift redirect :: Monad m => String -> ResponseT m a -redirect s = ResponseT (return (Left $ Redirect s, [])) +redirect s = ResponseT (const $ return (Left $ Redirect s, [])) notFound :: Monad m => ResponseT m a -notFound = ResponseT (return (Left NotFound, [])) +notFound = ResponseT (const $ return (Left NotFound, [])) instance Monad m => Functor (ResponseT m) where - fmap f x = x >>= return . f + fmap = liftM instance Monad m => Monad (ResponseT m) where return = lift . return - fail s = ResponseT (return (Left $ InternalError s, [])) - (ResponseT mx) >>= f = ResponseT $ do - (x, hs1) <- mx + fail s = ResponseT (const $ return (Left $ InternalError s, [])) + (ResponseT mx) >>= f = ResponseT $ \rr -> do + (x, hs1) <- mx rr case x of Left x' -> return (Left x', hs1) Right a -> do let (ResponseT b') = f a - (b, hs2) <- b' + (b, hs2) <- b' rr return (b, hs1 ++ hs2) -- | Headers to be added to a 'Result'. @@ -179,7 +185,7 @@ header :: Monad m => String -> String -> ResponseT m () header a b = addHeader $ Header a b addHeader :: Monad m => Header -> ResponseT m () -addHeader h = ResponseT (return (Right (), [h])) +addHeader h = ResponseT (const $ return (Right (), [h])) instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] @@ -214,3 +220,13 @@ instance HasReps [(ContentType, B.ByteString)] where -- FIXME put in a separate module (maybe Web.Encodings) formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" + +getRequest :: (Monad m, Request r) => ResponseT m r +getRequest = ResponseT $ \rr -> return (helper rr, []) where + helper :: Request r + => RawRequest + -> Either ErrorResult r + helper rr = + case runRequestParser parseRequest rr of + Left errors -> Left $ InternalError $ unlines errors -- FIXME better error output + Right r -> Right r From 2a958c1a8f0a7479287376630f03c6c6884f3178 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Sep 2009 01:00:04 +0300 Subject: [PATCH 021/624] Better error handling for invalid arguments --- TODO | 1 - Web/Restful/Application.hs | 5 +++++ Web/Restful/Request.hs | 15 +++++++-------- Web/Restful/Response.hs | 4 +++- 4 files changed, 15 insertions(+), 10 deletions(-) diff --git a/TODO b/TODO index 052dfd91..e69de29b 100644 --- a/TODO +++ b/TODO @@ -1 +0,0 @@ -Better error handling for invalid arguments (currently 500 error) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 3c61f556..017824f2 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -71,6 +71,11 @@ class ResourceName a b => RestfulApp a b | a -> b where HasRepsW $ toObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = HasRepsW $ toObject $ "Internal server error: " ++ e + errorHandler _ _ (InvalidArgs ia) = + HasRepsW $ toObject $ + [ ("errorMsg", toObject "Invalid arguments") + , ("messages", toObject ia) + ] -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 789de3ec..30a13770 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -109,7 +109,7 @@ tryReadParams:: Parameter a tryReadParams name params = case readParams params of Left s -> do - tell [name ++ ": " ++ s] + tell [(name, s)] return $ error $ "Trying to evaluate nonpresent parameter " ++ @@ -185,16 +185,15 @@ requestPath = do q' -> q' return $! Hack.pathInfo env ++ q -type RequestParser a = WriterT [ParamError] (Reader RawRequest) a -instance Applicative (WriterT [ParamError] (Reader RawRequest)) where +type RequestParser a = WriterT [(ParamName, ParamError)] (Reader RawRequest) a +instance Applicative (WriterT [(ParamName, ParamError)] (Reader RawRequest)) where pure = return - f <*> a = do - f' <- f - a' <- a - return $! f' a' + (<*>) = ap -- | Parse a request into either the desired 'Request' or a list of errors. -runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a +runRequestParser :: RequestParser a + -> RawRequest + -> Either [(ParamName, ParamError)] a runRequestParser p req = let (val, errors) = (runReader (runWriterT p)) req in case errors of diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index b5d1c1fb..4fbdfa3f 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -73,11 +73,13 @@ data ErrorResult = Redirect String | NotFound | InternalError String + | InvalidArgs [(String, String)] getStatus :: ErrorResult -> Int getStatus (Redirect _) = 303 getStatus NotFound = 404 getStatus (InternalError _) = 500 +getStatus (InvalidArgs _) = 400 getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] @@ -228,5 +230,5 @@ getRequest = ResponseT $ \rr -> return (helper rr, []) where -> Either ErrorResult r helper rr = case runRequestParser parseRequest rr of - Left errors -> Left $ InternalError $ unlines errors -- FIXME better error output + Left errors -> Left $ InvalidArgs errors -- FIXME better error output Right r -> Right r From 0519b99fedb9c05123f394cd03e466e8819e9e07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Sep 2009 22:21:21 +0300 Subject: [PATCH 022/624] Refactored and documented Response and Handler --- Web/Restful/Application.hs | 14 +-- Web/Restful/Handler.hs | 135 +++++++++++++++++++-- Web/Restful/Helpers/Auth.hs | 61 +++++----- Web/Restful/Helpers/Static.hs | 11 +- Web/Restful/Response.hs | 196 +++++++------------------------ Web/Restful/Response/AtomFeed.hs | 1 + Web/Restful/Response/Sitemap.hs | 6 +- Web/Restful/Utils.hs | 18 ++- 8 files changed, 230 insertions(+), 212 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 017824f2..6f4f72ac 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -65,14 +65,14 @@ class ResourceName a b => RestfulApp a b | a -> b where responseWrapper _ _ = return -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW - errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr + errorHandler :: a -> RawRequest -> ErrorResult -> Reps + errorHandler _ rr NotFound = reps $ toObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = - HasRepsW $ toObject $ "Redirect to: " ++ url + reps $ toObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = - HasRepsW $ toObject $ "Internal server error: " ++ e + reps $ toObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - HasRepsW $ toObject $ + reps $ toObject $ [ ("errorMsg", toObject "Invalid arguments") , ("messages", toObject ia) ] @@ -118,7 +118,7 @@ toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env let (handler, urlParams') = case findResourceNames resource of - [] -> (noHandler, []) + [] -> (notFound, []) [(rn, urlParams'')] -> let verb = toVerb $ Hack.requestMethod env in (hm rn verb, urlParams'') @@ -126,7 +126,7 @@ toHackApplication sampleRN hm env = do let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - runResponse (errorHandler sampleRN rr) + runHandler (errorHandler sampleRN rr) (responseWrapper sampleRN) ctypes' handler diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index bcfd86f9..3a9454cf 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -15,22 +17,133 @@ -- --------------------------------------------------------- module Web.Restful.Handler - ( Handler - , liftHandler - , noHandler + ( -- * Handler monad + HandlerT + , HandlerIO + , Handler + , runHandler + , getRequest + , liftIO + -- * Special handlers + , redirect + , notFound + -- * Setting headers + , addCookie + , deleteCookie + , header ) where import Web.Restful.Request import Web.Restful.Response -type Handler = Response -- FIXME maybe move some stuff around now... +import Control.Monad.Trans +import Control.Monad (liftM) -liftHandler :: (Request req, HasReps rep) - => (req -> ResponseIO rep) +import Data.Maybe (fromJust) +import qualified Data.ByteString.Lazy as B +import qualified Hack + +------ Handler monad +newtype HandlerT m a = + HandlerT (RawRequest -> m (Either ErrorResult a, [Header])) +type HandlerIO = HandlerT IO +type Handler = HandlerIO Reps + +runHandler :: (ErrorResult -> Reps) + -> (ContentType -> B.ByteString -> IO B.ByteString) + -> [ContentType] -> Handler -liftHandler f = do - req <- getRequest - wrapResponse $ f req + -> RawRequest + -> IO Hack.Response +runHandler eh wrapper ctypesAll (HandlerT inside) rr = do + (x, headers') <- inside rr + let extraHeaders = + case x of + Left r -> getHeaders r + Right _ -> [] + headers <- mapM toPair (headers' ++ extraHeaders) + let outReps = either (reps . eh) reps x + let statusCode = + case x of + Left r -> getStatus r + Right _ -> 200 + (ctype, selectedRep) <- chooseRep outReps ctypesAll + finalRep <- wrapper ctype selectedRep + let headers'' = ("Content-Type", ctype) : headers + return $! Hack.Response statusCode headers'' finalRep -noHandler :: Handler -noHandler = notFound +chooseRep :: Monad m + => [(ContentType, B.ByteString)] + -> [ContentType] + -> m (ContentType, B.ByteString) +chooseRep rs cs + | length rs == 0 = fail "All reps must have at least one value" + | otherwise = do + let availCs = map fst rs + case filter (`elem` availCs) cs of + [] -> return $ head rs + [ctype] -> return (ctype, fromJust $ lookup ctype rs) + _ -> fail "Overlapping representations" + +instance MonadTrans HandlerT where + lift ma = HandlerT $ const $ do + a <- ma + return (Right a, []) + +instance MonadIO HandlerIO where + liftIO = lift + +instance Monad m => Functor (HandlerT m) where + fmap = liftM + +instance Monad m => Monad (HandlerT m) where + return = lift . return + fail s = HandlerT (const $ return (Left $ InternalError s, [])) + (HandlerT mx) >>= f = HandlerT $ \rr -> do + (x, hs1) <- mx rr + case x of + Left x' -> return (Left x', hs1) + Right a -> do + let (HandlerT b') = f a + (b, hs2) <- b' rr + return (b, hs1 ++ hs2) + +-- | Parse a request in the Handler monad. On failure, return a 400 error. +getRequest :: (Monad m, Request r) => HandlerT m r +getRequest = HandlerT $ \rr -> return (helper rr, []) where + helper :: Request r + => RawRequest + -> Either ErrorResult r + helper rr = + case runRequestParser parseRequest rr of + Left errors -> Left $ InvalidArgs errors + Right r -> Right r + +------ Special handlers +-- | Redirect to the given URL. +redirect :: Monad m => String -> HandlerT m a +redirect s = HandlerT (const $ return (Left $ Redirect s, [])) + +-- | Return a 404 not found page. Also denotes no handler available. +notFound :: Monad m => HandlerT m a +notFound = HandlerT (const $ return (Left NotFound, [])) + +------- Headers +-- | Set the cookie on the client. +addCookie :: Monad m + => Int -- ^ minutes to timeout + -> String -- ^ key + -> String -- ^ value + -> HandlerT m () +addCookie a b c = addHeader $ AddCookie a b c + +-- | Unset the cookie on the client. +deleteCookie :: Monad m => String -> HandlerT m () +deleteCookie = addHeader . DeleteCookie + +-- | Set an arbitrary header on the client. +header :: Monad m => String -> String -> HandlerT m () +header a b = addHeader $ Header a b + +addHeader :: Monad m => Header -> HandlerT m () +addHeader h = HandlerT (const $ return (Right (), [h])) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 067cd551..fec60a3d 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -28,7 +28,6 @@ import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) import Control.Monad.Reader -import Data.Object import Data.Maybe (fromMaybe) data AuthResource = @@ -42,13 +41,13 @@ data AuthResource = type RpxnowApiKey = String -- FIXME newtype instance ResourceName AuthResource (Maybe RpxnowApiKey) where - getHandler _ Check Get = liftHandler authCheck - getHandler _ Logout Get = liftHandler authLogout - getHandler _ Openid Get = liftHandler authOpenidForm - getHandler _ OpenidForward Get = liftHandler authOpenidForward - getHandler _ OpenidComplete Get = liftHandler authOpenidComplete - getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key - getHandler _ _ _ = noHandler + getHandler _ Check Get = authCheck + getHandler _ Logout Get = authLogout + getHandler _ Openid Get = authOpenidForm + getHandler _ OpenidForward Get = authOpenidForward + getHandler _ OpenidComplete Get = authOpenidComplete + getHandler (Just key) LoginRpxnow Get = rpxnowLogin key + getHandler _ _ _ = notFound allValues = Check @@ -75,8 +74,9 @@ instance Show OIDFormReq where show (OIDFormReq (Just s) _) = "

          " ++ encodeHtml s ++ "

          " -authOpenidForm :: OIDFormReq -> ResponseIO GenResponse -authOpenidForm m@(OIDFormReq _ dest) = do +authOpenidForm :: Handler +authOpenidForm = do + m@(OIDFormReq _ dest) <- getRequest let html = show m ++ "
          " ++ @@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do case dest of Just dest' -> addCookie 20 "DEST" dest' Nothing -> return () - return $! htmlResponse html + htmlResponse html data OIDFReq = OIDFReq String String instance Request OIDFReq where @@ -97,8 +97,9 @@ instance Request OIDFReq where show (Hack.serverPort env) ++ "/auth/openid/complete/" return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> Response -authOpenidForward (OIDFReq oid complete) = do +authOpenidForward :: Handler +authOpenidForward = do + OIDFReq oid complete <- getRequest res <- liftIO $ OpenId.getForwardUrl oid complete case res of Left err -> redirect $ "/auth/openid/?message=" @@ -113,8 +114,9 @@ instance Request OIDComp where dest <- cookieParam "DEST" return $! OIDComp gets dest -authOpenidComplete :: OIDComp -> Response -authOpenidComplete (OIDComp gets' dest) = do +authOpenidComplete :: Handler +authOpenidComplete = do + OIDComp gets' dest <- getRequest res <- liftIO $ OpenId.authenticate gets' case res of Left err -> redirect $ "/auth/openid/?message=" @@ -137,9 +139,9 @@ chopHash ('#':rest) = rest chopHash x = x rpxnowLogin :: String -- ^ api key - -> RpxnowRequest - -> Response -rpxnowLogin apiKey (RpxnowRequest token dest') = do + -> Handler +rpxnowLogin apiKey = do + RpxnowRequest token dest' <- getRequest let dest = case dest' of Nothing -> "/" Just "" -> "/" @@ -154,16 +156,17 @@ data AuthRequest = AuthRequest (Maybe String) instance Request AuthRequest where parseRequest = AuthRequest `fmap` identifier -authCheck :: AuthRequest -> ResponseIO Object -authCheck (AuthRequest Nothing) = - return $ toObject [("status", "notloggedin")] -authCheck (AuthRequest (Just i)) = - return $ toObject - [ ("status", "loggedin") - , ("ident", i) - ] +authCheck :: Handler +authCheck = do + req <- getRequest + case req of + AuthRequest Nothing -> objectResponse[("status", "notloggedin")] + AuthRequest (Just i) -> objectResponse + [ ("status", "loggedin") + , ("ident", i) + ] -authLogout :: () -> ResponseIO Object -authLogout _ = do +authLogout :: Handler +authLogout = do deleteCookie authCookieName - return $ toObject [("status", "loggedout")] + objectResponse [("status", "loggedout")] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 9d88131c..d2e46614 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -25,19 +25,20 @@ import Web.Restful type FileLookup = FilePath -> IO (Maybe B.ByteString) serveStatic :: FileLookup -> Verb -> Handler -serveStatic fl Get = liftHandler $ getStatic fl -serveStatic _ _ = noHandler +serveStatic fl Get = getStatic fl +serveStatic _ _ = notFound newtype StaticReq = StaticReq FilePath instance Request StaticReq where parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for .. -getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse -getStatic fl (StaticReq fp) = do +getStatic :: FileLookup -> Handler +getStatic fl = do + StaticReq fp <- getRequest content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs + Just bs -> genResponse (mimeType $ ext fp) bs mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 4fbdfa3f..d8f15dce 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -15,45 +13,36 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( formatW3 + ( -- * Representations + Reps , HasReps (..) - , notFound - , wrapResponse - , ResponseIO - , ResponseT - , Response - , runResponse - , deleteCookie - , redirect - , addCookie - , header - , GenResponse (..) - , liftIO + , ContentType + -- * Abnormal responses , ErrorResult (..) - , HasRepsW (..) - , byteStringResponse + , getHeaders + , getStatus + -- * Header + , Header (..) + , toPair + -- * Generic responses + , response + , genResponse , htmlResponse - , getRequest + , objectResponse ) where import Data.ByteString.Class -import Data.Time.Format import Data.Time.Clock -import System.Locale import Data.Object import qualified Data.ByteString.Lazy as B import Data.Object.Instances -import Data.Maybe (fromJust) -import Web.Restful.Request - -import Control.Monad.Trans -import Control.Monad (liftM) - -import qualified Hack +import Web.Restful.Utils (formatW3) type ContentType = String +type Reps = [(ContentType, B.ByteString)] + -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. class HasReps a where @@ -61,14 +50,9 @@ class HasReps a where -- content type. If the user asked for a specific response type (like -- text/html), then that will get priority. If not, then the first -- element in this list will be used. - reps :: a -> [(ContentType, B.ByteString)] - --- | Wrap up any instance of 'HasReps'. -data HasRepsW = forall a. HasReps a => HasRepsW a - -instance HasReps HasRepsW where - reps (HasRepsW r) = reps r + reps :: a -> Reps +-- | Abnormal return codes. data ErrorResult = Redirect String | NotFound @@ -85,47 +69,14 @@ getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] getHeaders _ = [] -newtype ResponseT m a = - ResponseT (RawRequest -> m (Either ErrorResult a, [Header])) -type ResponseIO = ResponseT IO -type Response = ResponseIO HasRepsW - -runResponse :: (ErrorResult -> HasRepsW) - -> (ContentType -> B.ByteString -> IO B.ByteString) - -> [ContentType] - -> Response - -> RawRequest - -> IO Hack.Response -runResponse eh wrapper ctypesAll (ResponseT inside) rr = do - (x, headers') <- inside rr - let extraHeaders = - case x of - Left r -> getHeaders r - Right _ -> [] - headers <- mapM toPair (headers' ++ extraHeaders) - let outReps = either (reps . eh) reps x - let statusCode = - case x of - Left r -> getStatus r - Right _ -> 200 - (ctype, selectedRep) <- chooseRep outReps ctypesAll - finalRep <- wrapper ctype selectedRep - let headers'' = ("Content-Type", ctype) : headers - return $! Hack.Response statusCode headers'' finalRep - -chooseRep :: Monad m - => [(ContentType, B.ByteString)] - -> [ContentType] - -> m (ContentType, B.ByteString) -chooseRep rs cs - | length rs == 0 = fail "All reps must have at least one value" - | otherwise = do - let availCs = map fst rs - case filter (`elem` availCs) cs of - [] -> return $ head rs - [ctype] -> return (ctype, fromJust $ lookup ctype rs) - _ -> fail "Overlapping representations" +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int String String + | DeleteCookie String + | Header String String +-- | Convert Header to a key/value pair. toPair :: Header -> IO (String, String) toPair (AddCookie minutes key value) = do now <- getCurrentTime @@ -137,78 +88,29 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) -wrapResponse :: (Monad m, HasReps rep) - => ResponseT m rep - -> ResponseT m HasRepsW -wrapResponse = fmap HasRepsW +------ Generic responses +-- | Lifts a 'HasReps' into a monad. +response :: (Monad m, HasReps reps) => reps -> m Reps +response = return . reps -instance MonadTrans ResponseT where - lift ma = ResponseT $ const $ do - a <- ma - return (Right a, []) +-- | Return a response with an arbitrary content type. +genResponse :: (Monad m, LazyByteString lbs) + => ContentType + -> lbs + -> m Reps +genResponse ct lbs = return [(ct, toLazyByteString lbs)] -instance MonadIO ResponseIO where - liftIO = lift +-- | Return a response with a text/html content type. +htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps +htmlResponse = genResponse "text/html" -redirect :: Monad m => String -> ResponseT m a -redirect s = ResponseT (const $ return (Left $ Redirect s, [])) - -notFound :: Monad m => ResponseT m a -notFound = ResponseT (const $ return (Left NotFound, [])) - -instance Monad m => Functor (ResponseT m) where - fmap = liftM - -instance Monad m => Monad (ResponseT m) where - return = lift . return - fail s = ResponseT (const $ return (Left $ InternalError s, [])) - (ResponseT mx) >>= f = ResponseT $ \rr -> do - (x, hs1) <- mx rr - case x of - Left x' -> return (Left x', hs1) - Right a -> do - let (ResponseT b') = f a - (b, hs2) <- b' rr - return (b, hs1 ++ hs2) - --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - -addCookie :: Monad m => Int -> String -> String -> ResponseT m () -addCookie a b c = addHeader $ AddCookie a b c - -deleteCookie :: Monad m => String -> ResponseT m () -deleteCookie = addHeader . DeleteCookie - -header :: Monad m => String -> String -> ResponseT m () -header a b = addHeader $ Header a b - -addHeader :: Monad m => Header -> ResponseT m () -addHeader h = ResponseT (const $ return (Right (), [h])) +-- | Return a response from an Object. +objectResponse :: (Monad m, ToObject o) => o -> m Reps +objectResponse = return . reps . toObject +-- HasReps instances instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] - -data GenResponse = HtmlResponse B.ByteString - | ObjectResponse Object - | HtmlOrObjectResponse String Object - | ByteStringResponse ContentType B.ByteString -instance HasReps GenResponse where - reps (HtmlResponse h) = [("text/html", toLazyByteString h)] - reps (ObjectResponse t) = reps t - reps (HtmlOrObjectResponse h t) = - ("text/html", toLazyByteString h) : reps t - reps (ByteStringResponse ct con) = [(ct, con)] - -byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse -byteStringResponse ct = ByteStringResponse ct . toLazyByteString - -htmlResponse :: LazyByteString lbs => lbs -> GenResponse -htmlResponse = HtmlResponse . toLazyByteString - instance HasReps Object where reps o = [ ("text/html", unHtml $ safeFromObject o) @@ -218,17 +120,3 @@ instance HasReps Object where instance HasReps [(ContentType, B.ByteString)] where reps = id - --- FIXME put in a separate module (maybe Web.Encodings) -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" - -getRequest :: (Monad m, Request r) => ResponseT m r -getRequest = ResponseT $ \rr -> return (helper rr, []) where - helper :: Request r - => RawRequest - -> Either ErrorResult r - helper rr = - case runRequestParser parseRequest rr of - Left errors -> Left $ InvalidArgs errors -- FIXME better error output - Right r -> Right r diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 8f093a49..323c0676 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -18,6 +18,7 @@ module Web.Restful.Response.AtomFeed ) where import Web.Restful.Response +import Web.Restful.Utils import Data.Time.Clock import Web.Encodings diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 92f2566a..7bce9561 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -19,7 +19,9 @@ module Web.Restful.Response.Sitemap , SitemapChangeFreq (..) ) where +import Web.Restful.Handler import Web.Restful.Response +import Web.Restful.Utils import Web.Encodings import qualified Hack import Web.Restful.Request @@ -86,7 +88,7 @@ instance HasReps SitemapResponse where [ ("text/xml", toLazyByteString $ show res) ] -sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse +sitemap :: IO [SitemapUrl] -> SitemapRequest -> Handler sitemap urls' req = do urls <- liftIO urls' - return $ SitemapResponse req urls + return $ reps $ SitemapResponse req urls diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 605a9c99..43a62179 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -9,15 +9,23 @@ -- Portability : portable -- -- Utility functions for Restful. +-- These are all functions which could be exported to another library. -- --------------------------------------------------------- module Web.Restful.Utils ( parseHttpAccept , tryLookup + , formatW3 ) where import Data.List.Split (splitOneOf) +import Data.Maybe (fromMaybe) +import Data.Time.Clock +import System.Locale +import Data.Time.Format + +-- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: String -> [String] parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," @@ -26,8 +34,10 @@ specialHttpAccept ('q':'=':_) = True specialHttpAccept ('*':_) = True specialHttpAccept _ = False +-- | Attempt a lookup, returning a default value on failure. tryLookup :: Eq k => v -> k -> [(k, v)] -> v -tryLookup v _ [] = v -tryLookup v k ((k', v'):rest) - | k == k' = v' - | otherwise = tryLookup v k rest +tryLookup def key = fromMaybe def . lookup key + +-- | Format a 'UTCTime' in W3 format; useful for setting cookies. +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone? From 85249b64e15dea5b329a79985db59399b6927535 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Sep 2009 23:26:43 +0300 Subject: [PATCH 023/624] Minor bug fixes --- Web/Restful/Application.hs | 14 +++++++------- Web/Restful/Response/Sitemap.hs | 5 +++-- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 6f4f72ac..8236b97a 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -116,21 +116,21 @@ toHackApplication :: RestfulApp resourceName model -> Hack.Application toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env - let (handler, urlParams') = + let (handler, urlParams', wrapper) = case findResourceNames resource of - [] -> (notFound, []) + [] -> (notFound, [], const return) [(rn, urlParams'')] -> let verb = toVerb $ Hack.requestMethod env - in (hm rn verb, urlParams'') + in (hm rn verb, urlParams'', responseWrapper rn) x -> error $ "Invalid findResourceNames: " ++ show x let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept runHandler (errorHandler sampleRN rr) - (responseWrapper sampleRN) - ctypes' - handler - rr + wrapper + ctypes' + handler + rr envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 7bce9561..e2e9a736 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -88,7 +88,8 @@ instance HasReps SitemapResponse where [ ("text/xml", toLazyByteString $ show res) ] -sitemap :: IO [SitemapUrl] -> SitemapRequest -> Handler -sitemap urls' req = do +sitemap :: IO [SitemapUrl] -> Handler +sitemap urls' = do + req <- getRequest urls <- liftIO urls' return $ reps $ SitemapResponse req urls From b7c07c88add519a75373c03b90c0c87c08eb6af1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Sep 2009 00:58:55 +0300 Subject: [PATCH 024/624] Test framework; overlap checking --- Setup.lhs | 6 +- Test.hs | 11 ++++ Web/Restful.hs | 4 +- Web/Restful/Application.hs | 1 + Web/Restful/Request.hs | 2 - Web/Restful/Resource.hs | 111 ++++++++++++++++++++++++++++++++++--- Web/Restful/Response.hs | 10 ++++ Web/Restful/Utils.hs | 18 ++++++ restful.cabal | 11 +++- 9 files changed, 159 insertions(+), 15 deletions(-) create mode 100644 Test.hs diff --git a/Setup.lhs b/Setup.lhs index 06e2708f..d9014a88 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -2,6 +2,10 @@ > module Main where > import Distribution.Simple +> import System.Cmd (system) > main :: IO () -> main = defaultMain +> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) + +> runTests' :: a -> b -> c -> d -> IO () +> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return () diff --git a/Test.hs b/Test.hs new file mode 100644 index 00000000..3ca5e328 --- /dev/null +++ b/Test.hs @@ -0,0 +1,11 @@ +import Test.Framework (defaultMain) + +import qualified Web.Restful.Response +import qualified Web.Restful.Utils +import qualified Web.Restful.Resource + +main = defaultMain + [ Web.Restful.Response.testSuite + , Web.Restful.Utils.testSuite + , Web.Restful.Resource.testSuite + ] diff --git a/Web/Restful.hs b/Web/Restful.hs index 47ac2fbc..1f591eb4 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -24,8 +24,8 @@ module Web.Restful import Data.Object import Web.Restful.Request -import Web.Restful.Response +import Web.Restful.Response hiding (testSuite) import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler -import Web.Restful.Resource +import Web.Restful.Resource hiding (testSuite) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 8236b97a..6903b3f2 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -83,6 +83,7 @@ toHackApp :: RestfulApp resourceName modelType => resourceName -> IO Hack.Application toHackApp a = do + checkResourceName a -- FIXME maybe this should be done compile-time? model <- getModel a key <- encryptKey a let handlers = getHandler model diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 30a13770..6a8d9ee4 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -212,8 +212,6 @@ data RawRequest = RawRequest } deriving Show -deriving instance Show FileInfo - -- | All GET paramater values with the given name. getParams :: RawRequest -> ParamName -> [ParamValue] getParams rr name = map snd diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index d253edb3..2415f776 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -1,5 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------- -- -- Module : Web.Restful.Resource @@ -17,6 +20,10 @@ module Web.Restful.Resource ( ResourceName (..) , fromString , checkPattern + , validatePatterns + , checkResourceName + -- * Testing + , testSuite ) where import Data.List.Split (splitOn) @@ -24,20 +31,33 @@ import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.HUnit hiding (Test) +import Test.QuickCheck + data ResourcePatternPiece = Static String | Dynamic String | Slurp String -- ^ take up the rest of the pieces. must be last - deriving Show + deriving Eq +instance Show ResourcePattern where + show = concatMap helper . unRP where + helper (Static s) = '/' : s + helper (Dynamic s) = '/' : '$' : s + helper (Slurp s) = '/' : '*' : s isSlurp :: ResourcePatternPiece -> Bool isSlurp (Slurp _) = True isSlurp _ = False -type ResourcePattern = [ResourcePatternPiece] +newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } + deriving (Eq, Arbitrary) fromString :: String -> ResourcePattern -fromString = map fromString' . filter (not . null) . splitOn "/" +fromString = ResourcePattern + . map fromString' . filter (not . null) . splitOn "/" fromString' :: String -> ResourcePatternPiece fromString' ('$':rest) = Dynamic rest @@ -61,18 +81,19 @@ class Show a => ResourceName a b | a -> b where -- | Find the handler for each resource name/verb pattern. getHandler :: b -> a -> Verb -> Handler --- FIXME add some overlap checking functions - type SMap = [(String, String)] data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch checkPattern :: ResourcePattern -> Resource -> Maybe SMap -checkPattern rp r +checkPattern rp r = checkPattern'' (unRP rp) r + +checkPattern'' :: [ResourcePatternPiece] -> Resource -> Maybe SMap +checkPattern'' rp r | length rp /= 0 && isSlurp (last rp) = do let rp' = init rp (r1, r2) = splitAt (length rp') r - smap <- checkPattern rp' r1 + smap <- checkPattern'' rp' r1 let slurpValue = intercalate "/" r2 Slurp slurpKey = last rp return $ (slurpKey, slurpValue) : smap @@ -89,3 +110,79 @@ combine s [] = Just $ reverse s combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest combine s (DynamicMatch x:rest) = combine (x:s) rest + +overlaps :: [ResourcePatternPiece] -> [ResourcePatternPiece] -> Bool +overlaps [] [] = True +overlaps [] _ = False +overlaps _ [] = False +overlaps (Slurp _:_) _ = True +overlaps _ (Slurp _:_) = True +overlaps (Dynamic _:x) (_:y) = overlaps x y +overlaps (_:x) (Dynamic _:y) = overlaps x y +overlaps (Static a:x) (Static b:y) = a == b && overlaps x y + +checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () +checkResourceName rn = do + let avs@(y:_) = allValues + _ignore = asTypeOf rn y + let patterns = map (fromString . resourcePattern) avs + case validatePatterns patterns of + [] -> return () + x -> fail $ "Overlapping patterns:\n" ++ unlines (map show x) + +validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] +validatePatterns [] = [] +validatePatterns (x:xs) = + concatMap (validatePatterns' x) xs ++ validatePatterns xs where + validatePatterns' :: ResourcePattern + -> ResourcePattern + -> [(ResourcePattern, ResourcePattern)] + validatePatterns' a b = + if overlaps (unRP a) (unRP b) + then [(a, b)] + else [] +---- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Resource" + [ testCase "non-overlap" case_overlap1 + , testCase "overlap" case_overlap2 + , testCase "overlap-slurp" case_overlap3 + , testCase "validatePatterns" case_validatePatterns + , testProperty "show pattern" prop_showPattern + ] + +case_overlap1 :: Assertion +case_overlap1 = assert $ not $ overlaps + (unRP $ fromString "/foo/$bar/") + (unRP $ fromString "/foo/baz/$bin") +case_overlap2 :: Assertion +case_overlap2 = assert $ overlaps + (unRP $ fromString "/foo/bar") + (unRP $ fromString "/foo/$baz") +case_overlap3 :: Assertion +case_overlap3 = assert $ overlaps + (unRP $ fromString "/foo/bar/baz/$bin") + (unRP $ fromString "*slurp") + +case_validatePatterns :: Assertion +case_validatePatterns = + let p1 = fromString "/foo/bar/baz" + p2 = fromString "/foo/$bar/baz" + p3 = fromString "/bin" + p4 = fromString "/bin/boo" + p5 = fromString "/bin/*slurp" + in validatePatterns [p1, p2, p3, p4, p5] @?= + [ (p1, p2) + , (p4, p5) + ] + +prop_showPattern :: ResourcePattern -> Bool +prop_showPattern p = fromString (show p) == p + +instance Arbitrary ResourcePatternPiece where + arbitrary = do + constr <- elements [Static, Dynamic, Slurp] + size <- elements [1..10] + s <- sequence (replicate size $ elements ['a'..'z']) + return $ constr s + coarbitrary = undefined diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index d8f15dce..c5db6c1d 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -29,6 +29,8 @@ module Web.Restful.Response , genResponse , htmlResponse , objectResponse + -- * Tests + , testSuite ) where import Data.ByteString.Class @@ -39,6 +41,8 @@ import Data.Object.Instances import Web.Restful.Utils (formatW3) +import Test.Framework (testGroup, Test) + type ContentType = String type Reps = [(ContentType, B.ByteString)] @@ -120,3 +124,9 @@ instance HasReps Object where instance HasReps [(ContentType, B.ByteString)] where reps = id + +----- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Response" + [ + ] diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 43a62179..66e36db7 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -16,6 +16,7 @@ module Web.Restful.Utils ( parseHttpAccept , tryLookup , formatW3 + , testSuite ) where import Data.List.Split (splitOneOf) @@ -25,6 +26,10 @@ import Data.Time.Clock import System.Locale import Data.Time.Format +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: String -> [String] parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," @@ -41,3 +46,16 @@ tryLookup def key = fromMaybe def . lookup key -- | Format a 'UTCTime' in W3 format; useful for setting cookies. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone? + +----- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Response" + [ testCase "tryLookup1" test_tryLookup1 + , testCase "tryLookup2" test_tryLookup2 + ] + +test_tryLookup1 :: Assertion +test_tryLookup1 = tryLookup "default" "foo" [] @?= "default" + +test_tryLookup2 :: Assertion +test_tryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" diff --git a/restful.cabal b/restful.cabal index 73dce39d..029211bb 100644 --- a/restful.cabal +++ b/restful.cabal @@ -27,10 +27,15 @@ library predicates >= 0.1, bytestring >= 0.9.1.4, bytestring-class, - web-encodings, + web-encodings >= 0.0.1, mtl >= 1.1.0.2, data-object, - yaml >= 0.0.1 + yaml >= 0.0.1, + test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck == 1.* exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -47,4 +52,4 @@ library Web.Restful.Response.AtomFeed, Web.Restful.Response.Sitemap, Web.Restful.Generic.ListDetail - ghc-options: -Wall + ghc-options: -Wall -Werror From 5addbf8465eb7816b348c548ff349c1511a59cd3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Sep 2009 01:28:38 +0300 Subject: [PATCH 025/624] Scalar changes in data-object --- Data/Object/Instances.hs | 9 ++++----- Web/Restful/Response.hs | 1 + 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 3bb2f241..3f6d21f5 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -21,7 +21,6 @@ module Data.Object.Instances import Data.Object import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString as BS import Data.ByteString.Class import Web.Encodings (encodeJson) import Text.Yaml (encode) @@ -35,7 +34,7 @@ instance SafeFromObject Json where helper :: Object -> B.ByteString helper (Scalar s) = B.concat [ toLazyByteString "\"" - , encodeJson $ fromStrictByteString s + , encodeJson $ fromLazyByteString s , toLazyByteString "\"" ] helper (Sequence s) = B.concat @@ -48,10 +47,10 @@ instance SafeFromObject Json where , B.intercalate (toLazyByteString ",") $ map helper2 m , toLazyByteString "}" ] - helper2 :: (BS.ByteString, Object) -> B.ByteString + helper2 :: (B.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat [ toLazyByteString "\"" - , encodeJson $ fromStrictByteString k + , encodeJson $ fromLazyByteString k , toLazyByteString "\":" , helper v ] @@ -89,7 +88,7 @@ instance SafeFromObject Html where toLazyByteString "
          " : map helper2 m ++ [ toLazyByteString "
          " ] - helper2 :: (BS.ByteString, Object) -> B.ByteString + helper2 :: (B.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat $ [ toLazyByteString "
          " , toLazyByteString k diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index c5db6c1d..fc0fd5ce 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response From e2f217f9811904b00d13618689be2d50517ab59b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 30 Sep 2009 22:22:53 +0200 Subject: [PATCH 026/624] Switched to Enumerable --- TODO | 1 + Web/Restful/Application.hs | 3 ++- Web/Restful/Helpers/Auth.hs | 28 +++++++++++++++------------- Web/Restful/Resource.hs | 10 +++------- restful.cabal | 5 +++-- 5 files changed, 24 insertions(+), 23 deletions(-) diff --git a/TODO b/TODO index e69de29b..b74fc905 100644 --- a/TODO +++ b/TODO @@ -0,0 +1 @@ +Catch exceptions and return as 500 errors diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 6903b3f2..eb287784 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -25,6 +25,7 @@ module Web.Restful.Application import Web.Encodings import qualified Data.ByteString.Lazy as B import Data.Object +import Data.Enumerable import qualified Hack import Hack.Middleware.CleanPath @@ -95,7 +96,7 @@ toHackApp a = do findResourceNames :: ResourceName a model => Resource -> [(a, [(String, String)])] -findResourceNames r = takeJusts $ map (checkPatternHelper r) allValues +findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate checkPatternHelper :: ResourceName a model => Resource diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index fec60a3d..82b3114a 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -21,6 +21,7 @@ import qualified Hack import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId +import Data.Enumerable import Web.Restful import Web.Restful.Constants @@ -39,17 +40,8 @@ data AuthResource = | LoginRpxnow deriving Show -type RpxnowApiKey = String -- FIXME newtype -instance ResourceName AuthResource (Maybe RpxnowApiKey) where - getHandler _ Check Get = authCheck - getHandler _ Logout Get = authLogout - getHandler _ Openid Get = authOpenidForm - getHandler _ OpenidForward Get = authOpenidForward - getHandler _ OpenidComplete Get = authOpenidComplete - getHandler (Just key) LoginRpxnow Get = rpxnowLogin key - getHandler _ _ _ = notFound - - allValues = +instance Enumerable AuthResource where + enumerate = Check : Logout : Openid @@ -58,6 +50,16 @@ instance ResourceName AuthResource (Maybe RpxnowApiKey) where : LoginRpxnow : [] +type RpxnowApiKey = String -- FIXME newtype +instance ResourceName AuthResource (Maybe RpxnowApiKey) where + getHandler _ Check Get = authCheck + getHandler _ Logout Get = authLogout + getHandler _ Openid Get = authOpenidForm + getHandler _ OpenidForward Get = authOpenidForward + getHandler _ OpenidComplete Get = authOpenidComplete + getHandler (Just key) LoginRpxnow Post = rpxnowLogin key + getHandler _ _ _ = notFound + resourcePattern Check = "/auth/check/" resourcePattern Logout = "/auth/logout/" resourcePattern Openid = "/auth/openid/" @@ -130,8 +132,8 @@ authOpenidComplete = do data RpxnowRequest = RpxnowRequest String (Maybe String) instance Request RpxnowRequest where parseRequest = do - token <- getParam "token" - dest <- getParam "dest" + token <- postParam "token" + dest <- postParam "dest" return $! RpxnowRequest token $ chopHash `fmap` dest chopHash :: String -> String diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 2415f776..5c47dc34 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -30,6 +30,7 @@ import Data.List.Split (splitOn) import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) +import Data.Enumerable import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit @@ -64,7 +65,7 @@ fromString' ('$':rest) = Dynamic rest fromString' ('*':rest) = Slurp rest fromString' x = Static x -class Show a => ResourceName a b | a -> b where +class (Show a, Enumerable a) => ResourceName a b | a -> b where -- | Get the URL pattern for each different resource name. -- Something like /foo/$bar/baz/ will match the regular expression -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. @@ -73,11 +74,6 @@ class Show a => ResourceName a b | a -> b where -- into the bar urlParam. resourcePattern :: a -> String - -- | Get all possible values for resource names. - -- Remember, if you use variables ($foo) in your resourcePatterns you - -- can get an unlimited number of resources for each resource name. - allValues :: [a] - -- | Find the handler for each resource name/verb pattern. getHandler :: b -> a -> Verb -> Handler @@ -123,7 +119,7 @@ overlaps (Static a:x) (Static b:y) = a == b && overlaps x y checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () checkResourceName rn = do - let avs@(y:_) = allValues + let avs@(y:_) = enumerate _ignore = asTypeOf rn y let patterns = map (fromString . resourcePattern) avs case validatePatterns patterns of diff --git a/restful.cabal b/restful.cabal index 029211bb..68a5a6e6 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.2 +version: 0.1.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -35,7 +35,8 @@ library test-framework-quickcheck, test-framework-hunit, HUnit, - QuickCheck == 1.* + QuickCheck == 1.*, + enumerable >= 0.0.3 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, From a607da06d31ec7359580636a13ce6b3246e6c359 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 1 Oct 2009 15:59:55 +0200 Subject: [PATCH 027/624] Minor fixes, bool parameter instance --- TODO | 2 ++ Web/Restful/Helpers/Auth.hs | 2 +- Web/Restful/Request.hs | 8 +++++++- Web/Restful/Utils.hs | 2 +- 4 files changed, 11 insertions(+), 3 deletions(-) diff --git a/TODO b/TODO index b74fc905..c3062510 100644 --- a/TODO +++ b/TODO @@ -1 +1,3 @@ Catch exceptions and return as 500 errors +approot +Request parameters without a request object? diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 82b3114a..50cb23e7 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -86,7 +86,7 @@ authOpenidForm = do "" ++ "" case dest of - Just dest' -> addCookie 20 "DEST" dest' + Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () htmlResponse html diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 6a8d9ee4..50886fc4 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -160,7 +160,7 @@ hackHeaderParam name = do -- | Extract the cookie which specifies the identifier for a logged in -- user. identifier :: Parameter a => RequestParser a -identifier = hackHeaderParam authCookieName +identifier = hackHeaderParam authCookieName -- FIXME better error message -- | Get the raw 'Hack.Env' value. parseEnv :: RequestParser Hack.Env @@ -278,6 +278,12 @@ instance Parameter Day where then Right $ fromGregorian y m d else Left $ "Invalid date: " ++ s +-- for checkboxes; checks for presence +instance Parameter Bool where + readParams [] = Right False + readParams [_] = Right True + readParams x = Left $ "Invalid Bool parameter: " ++ show x + -- | The input for a resource. -- -- Each resource can define its own instance of 'Request' and then more diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 66e36db7..2862fa2c 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -45,7 +45,7 @@ tryLookup def key = fromMaybe def . lookup key -- | Format a 'UTCTime' in W3 format; useful for setting cookies. formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone? +formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" ----- Testing testSuite :: Test From 7df28f4f30c2c385f0f97830403153300c0a7fe0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 1 Oct 2009 21:24:41 +0200 Subject: [PATCH 028/624] Moved formatW3 to web-encodings package --- Web/Restful/Response.hs | 2 +- Web/Restful/Response/AtomFeed.hs | 1 - Web/Restful/Response/Sitemap.hs | 1 - Web/Restful/Utils.hs | 9 --------- restful.cabal | 4 ++-- 5 files changed, 3 insertions(+), 14 deletions(-) diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index fc0fd5ce..dff158b9 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -40,7 +40,7 @@ import Data.Object import qualified Data.ByteString.Lazy as B import Data.Object.Instances -import Web.Restful.Utils (formatW3) +import Web.Encodings (formatW3) import Test.Framework (testGroup, Test) diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 323c0676..8f093a49 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -18,7 +18,6 @@ module Web.Restful.Response.AtomFeed ) where import Web.Restful.Response -import Web.Restful.Utils import Data.Time.Clock import Web.Encodings diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index e2e9a736..54d8a169 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -21,7 +21,6 @@ module Web.Restful.Response.Sitemap import Web.Restful.Handler import Web.Restful.Response -import Web.Restful.Utils import Web.Encodings import qualified Hack import Web.Restful.Request diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 2862fa2c..19053d68 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -15,17 +15,12 @@ module Web.Restful.Utils ( parseHttpAccept , tryLookup - , formatW3 , testSuite ) where import Data.List.Split (splitOneOf) import Data.Maybe (fromMaybe) -import Data.Time.Clock -import System.Locale -import Data.Time.Format - import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) @@ -43,10 +38,6 @@ specialHttpAccept _ = False tryLookup :: Eq k => v -> k -> [(k, v)] -> v tryLookup def key = fromMaybe def . lookup key --- | Format a 'UTCTime' in W3 format; useful for setting cookies. -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" - ----- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Response" diff --git a/restful.cabal b/restful.cabal index 68a5a6e6..f88a2904 100644 --- a/restful.cabal +++ b/restful.cabal @@ -29,8 +29,8 @@ library bytestring-class, web-encodings >= 0.0.1, mtl >= 1.1.0.2, - data-object, - yaml >= 0.0.1, + data-object >= 0.0.2, + yaml >= 0.0.4, test-framework, test-framework-quickcheck, test-framework-hunit, From 5231da57a365e23ef1dd94686881c0dbb672c437 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 4 Oct 2009 20:25:06 +0200 Subject: [PATCH 029/624] Built in function for statics from dir --- TODO | 1 + Web/Restful/Helpers/Static.hs | 12 ++++++++++++ restful.cabal | 3 ++- 3 files changed, 15 insertions(+), 1 deletion(-) diff --git a/TODO b/TODO index c3062510..cabb808c 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,4 @@ Catch exceptions and return as 500 errors approot Request parameters without a request object? +More checking on parameters (minimum length etc) diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index d2e46614..3b84d2e3 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -16,14 +16,26 @@ module Web.Restful.Helpers.Static ( serveStatic , FileLookup + , fileLookupDir ) where import qualified Data.ByteString as B +import System.Directory (doesFileExist) +import Control.Applicative ((<$>)) import Web.Restful type FileLookup = FilePath -> IO (Maybe B.ByteString) +-- | A 'FileLookup' for files in a directory. +fileLookupDir :: FilePath -> FileLookup +fileLookupDir dir fp = do + let fp' = dir ++ '/' : fp -- FIXME incredibly insecure... + exists <- doesFileExist fp' + if exists + then Just <$> B.readFile fp' + else return Nothing + serveStatic :: FileLookup -> Verb -> Handler serveStatic fl Get = getStatic fl serveStatic _ _ = notFound diff --git a/restful.cabal b/restful.cabal index f88a2904..7005f940 100644 --- a/restful.cabal +++ b/restful.cabal @@ -36,7 +36,8 @@ library test-framework-hunit, HUnit, QuickCheck == 1.*, - enumerable >= 0.0.3 + enumerable >= 0.0.3, + directory >= 1 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, From ab49c1e0faa1bbe4f149c2e891e6b2f7fea19bb6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 4 Oct 2009 20:25:20 +0200 Subject: [PATCH 030/624] Rpxnow supporting GET and POST --- Web/Restful/Helpers/Auth.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 50cb23e7..14b12067 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -57,6 +57,8 @@ instance ResourceName AuthResource (Maybe RpxnowApiKey) where getHandler _ Openid Get = authOpenidForm getHandler _ OpenidForward Get = authOpenidForward getHandler _ OpenidComplete Get = authOpenidComplete + -- two different versions of RPX protocol apparently... + getHandler (Just key) LoginRpxnow Get = rpxnowLogin key getHandler (Just key) LoginRpxnow Post = rpxnowLogin key getHandler _ _ _ = notFound @@ -132,8 +134,8 @@ authOpenidComplete = do data RpxnowRequest = RpxnowRequest String (Maybe String) instance Request RpxnowRequest where parseRequest = do - token <- postParam "token" - dest <- postParam "dest" + token <- anyParam "token" + dest <- anyParam "dest" return $! RpxnowRequest token $ chopHash `fmap` dest chopHash :: String -> String From 45bd3dca6601832f5ff121669b66a4f52f6a8943 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 4 Oct 2009 22:32:23 +0200 Subject: [PATCH 031/624] Massive overhaul of Request system --- Web/Restful/Application.hs | 2 + Web/Restful/Handler.hs | 30 +++--- Web/Restful/Helpers/Auth.hs | 53 ++++------ Web/Restful/Helpers/Static.hs | 6 +- Web/Restful/Request.hs | 172 +++++++++++++++++--------------- Web/Restful/Response.hs | 2 + Web/Restful/Response/Sitemap.hs | 9 +- restful.cabal | 2 +- 8 files changed, 138 insertions(+), 138 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index eb287784..035101ce 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -77,6 +77,8 @@ class ResourceName a b => RestfulApp a b | a -> b where [ ("errorMsg", toObject "Invalid arguments") , ("messages", toObject ia) ] + errorHandler _ _ PermissionDenied = + reps $ toObject $ "Permission denied" -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 3a9454cf..043fb109 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -22,7 +22,6 @@ module Web.Restful.Handler , HandlerIO , Handler , runHandler - , getRequest , liftIO -- * Special handlers , redirect @@ -37,7 +36,8 @@ import Web.Restful.Request import Web.Restful.Response import Control.Monad.Trans -import Control.Monad (liftM) +import Control.Monad (liftM, ap) +import Control.Applicative import Data.Maybe (fromJust) import qualified Data.ByteString.Lazy as B @@ -108,25 +108,27 @@ instance Monad m => Monad (HandlerT m) where (b, hs2) <- b' rr return (b, hs1 ++ hs2) --- | Parse a request in the Handler monad. On failure, return a 400 error. -getRequest :: (Monad m, Request r) => HandlerT m r -getRequest = HandlerT $ \rr -> return (helper rr, []) where - helper :: Request r - => RawRequest - -> Either ErrorResult r - helper rr = - case runRequestParser parseRequest rr of - Left errors -> Left $ InvalidArgs errors - Right r -> Right r +instance Monad m => Applicative (HandlerT m) where + pure = return + (<*>) = ap + +instance Monad m => MonadRequestReader (HandlerT m) where + askRawRequest = HandlerT $ \rr -> return (Right rr, []) + invalidParam ptype name msg = + errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] + authRequired = errorResult PermissionDenied ------ Special handlers +errorResult :: Monad m => ErrorResult -> HandlerT m a +errorResult er = HandlerT (const $ return (Left er, [])) + -- | Redirect to the given URL. redirect :: Monad m => String -> HandlerT m a -redirect s = HandlerT (const $ return (Left $ Redirect s, [])) +redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. notFound :: Monad m => HandlerT m a -notFound = HandlerT (const $ return (Left NotFound, [])) +notFound = errorResult NotFound ------- Headers -- | Set the cookie on the client. diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 14b12067..83c909ca 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -80,7 +80,7 @@ instance Show OIDFormReq where authOpenidForm :: Handler authOpenidForm = do - m@(OIDFormReq _ dest) <- getRequest + m@(OIDFormReq _ dest) <- parseRequest let html = show m ++ "
          " ++ @@ -92,35 +92,23 @@ authOpenidForm = do Nothing -> return () htmlResponse html -data OIDFReq = OIDFReq String String -instance Request OIDFReq where - parseRequest = do - oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" - return $! OIDFReq oid complete authOpenidForward :: Handler authOpenidForward = do - OIDFReq oid complete <- getRequest + oid <- getParam "openid" + env <- parseEnv + let complete = "http://" ++ Hack.serverName env ++ ":" ++ + show (Hack.serverPort env) ++ + "/auth/openid/complete/" res <- liftIO $ OpenId.getForwardUrl oid complete case res of Left err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (err :: String) Right url -> redirect url -data OIDComp = OIDComp [(String, String)] (Maybe String) -instance Request OIDComp where - parseRequest = do - rr <- ask - let gets = rawGetParams rr - dest <- cookieParam "DEST" - return $! OIDComp gets dest - authOpenidComplete :: Handler authOpenidComplete = do - OIDComp gets' dest <- getRequest + gets' <- rawGetParams <$> askRawRequest + dest <- cookieParam "DEST" res <- liftIO $ OpenId.authenticate gets' case res of Left err -> redirect $ "/auth/openid/?message=" @@ -145,27 +133,26 @@ chopHash x = x rpxnowLogin :: String -- ^ api key -> Handler rpxnowLogin apiKey = do - RpxnowRequest token dest' <- getRequest + token <- anyParam "token" + postDest <- postParam "dest" + dest' <- case postDest of + Nothing -> getParam "dest" + Just d -> return d let dest = case dest' of Nothing -> "/" Just "" -> "/" + Just ('#':rest) -> rest Just s -> s - ident' <- liftIO $ Rpxnow.authenticate apiKey token - case ident' of - Nothing -> return () - Just ident -> header authCookieName $ Rpxnow.identifier ident + ident <- join $ liftIO $ Rpxnow.authenticate apiKey token + header authCookieName $ Rpxnow.identifier ident redirect dest -data AuthRequest = AuthRequest (Maybe String) -instance Request AuthRequest where - parseRequest = AuthRequest `fmap` identifier - authCheck :: Handler authCheck = do - req <- getRequest - case req of - AuthRequest Nothing -> objectResponse[("status", "notloggedin")] - AuthRequest (Just i) -> objectResponse + ident <- maybeIdentifier + case ident of + Nothing -> objectResponse [("status", "notloggedin")] + Just i -> objectResponse [ ("status", "loggedin") , ("ident", i) ] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 3b84d2e3..8e43925a 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -40,13 +40,9 @@ serveStatic :: FileLookup -> Verb -> Handler serveStatic fl Get = getStatic fl serveStatic _ _ = notFound -newtype StaticReq = StaticReq FilePath -instance Request StaticReq where - parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for .. - getStatic :: FileLookup -> Handler getStatic fl = do - StaticReq fp <- getRequest + fp <- urlParam "filepath" -- FIXME check for .. content <- liftIO $ fl fp case content of Nothing -> notFound diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 50886fc4..610126cc 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -17,38 +17,38 @@ --------------------------------------------------------- module Web.Restful.Request ( - -- * Request parsing + -- * Parameter -- $param_overview - - -- ** Types - ParamError + Parameter (..) + , ParamError + , ParamType , ParamName , ParamValue - -- ** Parameter type class - , Parameter (..) - -- ** RequestParser helpers + -- * RawRequest + , RawRequest (..) + , PathInfo + -- * Parameter type class + -- * MonadRequestReader type class and helpers + , MonadRequestReader (..) , getParam , postParam , urlParam , anyParam , cookieParam , identifier + , maybeIdentifier , acceptedLanguages , requestPath - -- ** Building actual request + , parseEnv + -- * Building actual request , Request (..) , Hack.RequestMethod (..) - -- ** FIXME - , parseEnv - , RawRequest (..) - , PathInfo - , runRequestParser + -- * Parameter restrictions + , notBlank ) where import qualified Hack import Data.Function.Predicate (equals) -import Control.Monad.Reader -import Control.Monad.Writer import Control.Monad.Error () import Web.Restful.Constants import Web.Restful.Utils @@ -67,6 +67,14 @@ import Data.Char (isDigit) -- That is what the parameter concept is for. A 'Parameter' is any value -- which can be converted from a 'String', or list of 'String's. +-- | Where this parameter came from. +data ParamType = + GetParam + | PostParam + | UrlParam + | CookieParam + deriving (Eq, Show) + -- | Any kind of error message generated in the parsing stage. type ParamError = String @@ -77,6 +85,12 @@ type ParamName = String -- | The 'String' value of a parameter, such as cookie content. type ParamValue = String +data RawParam = RawParam + { paramType :: ParamType + , paramName :: ParamName + , paramValue :: ParamValue + } + -- | Anything which can be converted from a 'String' or list of 'String's. -- -- The default implementation of 'readParams' will error out if given @@ -86,97 +100,105 @@ type ParamValue = String class Parameter a where -- | Convert a string into the desired value, or explain why that can't -- happen. - readParam :: ParamValue -> Either ParamError a + readParam :: RawParam -> Either ParamError a readParam = readParams . return -- | Convert a list of strings into the desired value, or explain why -- that can't happen. - readParams :: [ParamValue] -> Either ParamError a + readParams :: [RawParam] -> Either ParamError a readParams [x] = readParam x readParams [] = Left "Missing parameter" readParams xs = Left $ "Given " ++ show (length xs) ++ " values, expecting 1" +instance Parameter RawParam where + readParam = Right + +class (Monad m, Functor m, Applicative m) => MonadRequestReader m where + askRawRequest :: m RawRequest + invalidParam :: ParamType -> ParamName -> ParamError -> m a + authRequired :: m a + -- | Attempt to parse a list of param values using 'readParams'. -- If that fails, return an error message and an undefined value. This way, -- we can process all of the parameters and get all of the error messages. -- Be careful not to use the value inside until you can be certain the -- reading succeeded. -tryReadParams:: Parameter a - => ParamName - -> [ParamValue] - -> RequestParser a -tryReadParams name params = +tryReadParams:: (Parameter a, MonadRequestReader m) + => ParamType + -> ParamName + -> [RawParam] + -> m a +tryReadParams ptype name params = case readParams params of - Left s -> do - tell [(name, s)] - return $ - error $ - "Trying to evaluate nonpresent parameter " ++ - name + Left s -> invalidParam ptype name s Right x -> return x -- | Helper function for generating 'RequestParser's from various -- 'ParamValue' lists. -genParam :: Parameter a +genParam :: (Parameter a, MonadRequestReader m) => (RawRequest -> ParamName -> [ParamValue]) + -> ParamType -> ParamName - -> RequestParser a -genParam f name = do - req <- ask - tryReadParams name $ f req name + -> m a +genParam f ptype name = do + req <- askRawRequest + tryReadParams ptype name $ map (RawParam ptype name) $ f req name -- | Parse a value passed as a GET parameter. -getParam :: Parameter a => ParamName -> RequestParser a -getParam = genParam getParams +getParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +getParam = genParam getParams GetParam -- | Parse a value passed as a POST parameter. -postParam :: Parameter a => ParamName -> RequestParser a -postParam = genParam postParams +postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +postParam = genParam postParams PostParam -- | Parse a value passed in the URL and extracted using rewrite. -- (FIXME: link to rewrite section.) -urlParam :: Parameter a => ParamName -> RequestParser a -urlParam = genParam urlParams +urlParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +urlParam = genParam urlParams UrlParam -- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: Parameter a => ParamName -> RequestParser a -anyParam = genParam anyParams +anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +anyParam = genParam anyParams PostParam -- FIXME -- | Parse a value passed as a raw cookie. -cookieParam :: Parameter a => ParamName -> RequestParser a -cookieParam = genParam cookies - --- | Parse a value in the hackHeader field. -hackHeaderParam :: Parameter a => ParamName -> RequestParser a -hackHeaderParam name = do - env <- parseEnv - let vals' = lookup name $ Hack.hackHeaders env - vals = case vals' of - Nothing -> [] - Just x -> [x] - tryReadParams name vals +cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +cookieParam = genParam cookies CookieParam -- | Extract the cookie which specifies the identifier for a logged in -- user. -identifier :: Parameter a => RequestParser a -identifier = hackHeaderParam authCookieName -- FIXME better error message +identifier :: MonadRequestReader m => m String +identifier = do + mi <- maybeIdentifier + case mi of + Nothing -> authRequired + Just x -> return x + +-- | Extract the cookie which specifies the identifier for a logged in +-- user, if available. +maybeIdentifier :: MonadRequestReader m => m (Maybe String) +maybeIdentifier = do + env <- parseEnv + case lookup authCookieName $ Hack.hackHeaders env of + Nothing -> return Nothing + Just x -> return (Just x) -- | Get the raw 'Hack.Env' value. -parseEnv :: RequestParser Hack.Env -parseEnv = rawEnv `fmap` ask +parseEnv :: MonadRequestReader m => m Hack.Env +parseEnv = rawEnv `fmap` askRawRequest -- | Determine the ordered list of language preferences. -- -- FIXME: Future versions should account for some cookie. -acceptedLanguages :: RequestParser [String] +acceptedLanguages :: MonadRequestReader m => m [String] acceptedLanguages = do env <- parseEnv let rawLang = tryLookup "" "Accept-Language" $ Hack.http env return $! parseHttpAccept rawLang -- | Determinge the path requested by the user (ie, the path info). -requestPath :: RequestParser String +requestPath :: MonadRequestReader m => m String requestPath = do env <- parseEnv let q = case Hack.queryString env of @@ -185,20 +207,7 @@ requestPath = do q' -> q' return $! Hack.pathInfo env ++ q -type RequestParser a = WriterT [(ParamName, ParamError)] (Reader RawRequest) a -instance Applicative (WriterT [(ParamName, ParamError)] (Reader RawRequest)) where - pure = return - (<*>) = ap - --- | Parse a request into either the desired 'Request' or a list of errors. -runRequestParser :: RequestParser a - -> RawRequest - -> Either [(ParamName, ParamError)] a -runRequestParser p req = - let (val, errors) = (runReader (runWriterT p)) req - in case errors of - [] -> Right val - x -> Left x +type PathInfo = [String] -- | The raw information passed through Hack, cleaned up a bit. data RawRequest = RawRequest @@ -253,15 +262,15 @@ instance Parameter a => Parameter [a] where readParams = mapM readParam instance Parameter String where - readParam = Right + readParam = Right . paramValue instance Parameter Int where - readParam s = case reads s of + readParam (RawParam _ _ s) = case reads s of ((x, _):_) -> Right x _ -> Left $ "Invalid integer: " ++ s instance Parameter Day where - readParam s = + readParam (RawParam _ _ s) = let t1 = length s == 10 t2 = s !! 4 == '-' t3 = s !! 7 == '-' @@ -282,7 +291,7 @@ instance Parameter Day where instance Parameter Bool where readParams [] = Right False readParams [_] = Right True - readParams x = Left $ "Invalid Bool parameter: " ++ show x + readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x) -- | The input for a resource. -- @@ -290,9 +299,14 @@ instance Parameter Bool where -- easily ensure that it received the correct input (ie, correct variables, -- properly typed). class Request a where - parseRequest :: RequestParser a + parseRequest :: MonadRequestReader m => m a instance Request () where parseRequest = return () -type PathInfo = [String] +-- | Unsures that a String parameter is not blank. +notBlank :: MonadRequestReader m => RawParam -> m String +notBlank rp = + case paramValue rp of + "" -> invalidParam (paramType rp) (paramName rp) "Required field" + s -> return s diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index dff158b9..05b6746a 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -63,12 +63,14 @@ data ErrorResult = | NotFound | InternalError String | InvalidArgs [(String, String)] + | PermissionDenied getStatus :: ErrorResult -> Int getStatus (Redirect _) = 303 getStatus NotFound = 404 getStatus (InternalError _) = 500 getStatus (InvalidArgs _) = 400 +getStatus PermissionDenied = 403 getHeaders :: ErrorResult -> [Header] getHeaders (Redirect s) = [Header "Location" s] diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 54d8a169..40334a6c 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -51,11 +51,6 @@ data SitemapUrl = SitemapUrl , priority :: Double } data SitemapRequest = SitemapRequest String Int -instance Request SitemapRequest where - parseRequest = do - env <- parseEnv - return $! SitemapRequest (Hack.serverName env) - (Hack.serverPort env) data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] instance Show SitemapResponse where show (SitemapResponse (SitemapRequest host port) urls) = @@ -89,6 +84,8 @@ instance HasReps SitemapResponse where sitemap :: IO [SitemapUrl] -> Handler sitemap urls' = do - req <- getRequest + env <- parseEnv + -- FIXME + let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env) urls <- liftIO urls' return $ reps $ SitemapResponse req urls diff --git a/restful.cabal b/restful.cabal index 7005f940..e97d62ed 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.3 +version: 0.1.4 license: BSD3 license-file: LICENSE author: Michael Snoyman From 1a997621e82be69397af93d2d98f7d08c7c1c51f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 5 Oct 2009 06:23:10 +0200 Subject: [PATCH 032/624] hlinted --- Web/Restful/Application.hs | 4 +-- Web/Restful/Handler.hs | 7 +++--- Web/Restful/Helpers/Auth.hs | 14 +++++------ Web/Restful/Request.hs | 3 +-- Web/Restful/Resource.hs | 43 ++++++++++++++++----------------- Web/Restful/Response/Sitemap.hs | 2 +- Web/Restful/Utils.hs | 12 ++++----- 7 files changed, 41 insertions(+), 44 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 035101ce..0fe3dbcd 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -73,12 +73,12 @@ class ResourceName a b => RestfulApp a b | a -> b where errorHandler _ _ (InternalError e) = reps $ toObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - reps $ toObject $ + reps $ toObject [ ("errorMsg", toObject "Invalid arguments") , ("messages", toObject ia) ] errorHandler _ _ PermissionDenied = - reps $ toObject $ "Permission denied" + reps $ toObject "Permission denied" -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 043fb109..847928ee 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- @@ -77,7 +76,7 @@ chooseRep :: Monad m -> [ContentType] -> m (ContentType, B.ByteString) chooseRep rs cs - | length rs == 0 = fail "All reps must have at least one value" + | null rs = fail "All reps must have at least one representation" | otherwise = do let availCs = map fst rs case filter (`elem` availCs) cs of @@ -137,7 +136,7 @@ addCookie :: Monad m -> String -- ^ key -> String -- ^ value -> HandlerT m () -addCookie a b c = addHeader $ AddCookie a b c +addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. deleteCookie :: Monad m => String -> HandlerT m () @@ -145,7 +144,7 @@ deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. header :: Monad m => String -> String -> HandlerT m () -header a b = addHeader $ Header a b +header a = addHeader . Header a addHeader :: Monad m => Header -> HandlerT m () addHeader h = HandlerT (const $ return (Right (), [h])) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 83c909ca..272fc656 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -42,13 +42,13 @@ data AuthResource = instance Enumerable AuthResource where enumerate = - Check - : Logout - : Openid - : OpenidForward - : OpenidComplete - : LoginRpxnow - : [] + [ Check + , Logout + , Openid + , OpenidForward + , OpenidComplete + , LoginRpxnow + ] type RpxnowApiKey = String -- FIXME newtype instance ResourceName AuthResource (Maybe RpxnowApiKey) where diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 610126cc..2d77324a 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------- -- -- Module : Web.Restful.Request @@ -254,7 +253,7 @@ cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr instance Parameter a => Parameter (Maybe a) where readParams [] = Right Nothing - readParams [x] = readParam x >>= return . Just + readParams [x] = Just `fmap` readParam x readParams xs = Left $ "Given " ++ show (length xs) ++ " values, expecting 0 or 1" diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 5c47dc34..05677ae7 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -31,6 +31,7 @@ import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) import Data.Enumerable +import Control.Monad (replicateM) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit @@ -82,14 +83,14 @@ type SMap = [(String, String)] data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch checkPattern :: ResourcePattern -> Resource -> Maybe SMap -checkPattern rp r = checkPattern'' (unRP rp) r +checkPattern = checkPatternPieces . unRP -checkPattern'' :: [ResourcePatternPiece] -> Resource -> Maybe SMap -checkPattern'' rp r - | length rp /= 0 && isSlurp (last rp) = do +checkPatternPieces :: [ResourcePatternPiece] -> Resource -> Maybe SMap +checkPatternPieces rp r + | not (null rp) && isSlurp (last rp) = do let rp' = init rp (r1, r2) = splitAt (length rp') r - smap <- checkPattern'' rp' r1 + smap <- checkPatternPieces rp' r1 let slurpValue = intercalate "/" r2 Slurp slurpKey = last rp return $ (slurpKey, slurpValue) : smap @@ -133,35 +134,33 @@ validatePatterns (x:xs) = validatePatterns' :: ResourcePattern -> ResourcePattern -> [(ResourcePattern, ResourcePattern)] - validatePatterns' a b = - if overlaps (unRP a) (unRP b) - then [(a, b)] - else [] + validatePatterns' a b = [(a, b) | overlaps (unRP a) (unRP b)] + ---- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Resource" - [ testCase "non-overlap" case_overlap1 - , testCase "overlap" case_overlap2 - , testCase "overlap-slurp" case_overlap3 - , testCase "validatePatterns" case_validatePatterns + [ testCase "non-overlap" caseOverlap1 + , testCase "overlap" caseOverlap2 + , testCase "overlap-slurp" caseOverlap3 + , testCase "validatePatterns" caseValidatePatterns , testProperty "show pattern" prop_showPattern ] -case_overlap1 :: Assertion -case_overlap1 = assert $ not $ overlaps +caseOverlap1 :: Assertion +caseOverlap1 = assert $ not $ overlaps (unRP $ fromString "/foo/$bar/") (unRP $ fromString "/foo/baz/$bin") -case_overlap2 :: Assertion -case_overlap2 = assert $ overlaps +caseOverlap2 :: Assertion +caseOverlap2 = assert $ overlaps (unRP $ fromString "/foo/bar") (unRP $ fromString "/foo/$baz") -case_overlap3 :: Assertion -case_overlap3 = assert $ overlaps +caseOverlap3 :: Assertion +caseOverlap3 = assert $ overlaps (unRP $ fromString "/foo/bar/baz/$bin") (unRP $ fromString "*slurp") -case_validatePatterns :: Assertion -case_validatePatterns = +caseValidatePatterns :: Assertion +caseValidatePatterns = let p1 = fromString "/foo/bar/baz" p2 = fromString "/foo/$bar/baz" p3 = fromString "/bin" @@ -179,6 +178,6 @@ instance Arbitrary ResourcePatternPiece where arbitrary = do constr <- elements [Static, Dynamic, Slurp] size <- elements [1..10] - s <- sequence (replicate size $ elements ['a'..'z']) + s <- replicateM size $ elements ['a'..'z'] return $ constr s coarbitrary = undefined diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 40334a6c..fd86adde 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -62,7 +62,7 @@ instance Show SitemapResponse where prefix = "http://" ++ host ++ case port of 80 -> "" - _ -> ":" ++ show port + _ -> ':' : show port helper (SitemapUrl loc modTime freq pri) = concat [ "" , encodeHtml $ showLoc loc diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 19053d68..e4a43309 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -41,12 +41,12 @@ tryLookup def key = fromMaybe def . lookup key ----- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Response" - [ testCase "tryLookup1" test_tryLookup1 - , testCase "tryLookup2" test_tryLookup2 + [ testCase "tryLookup1" caseTryLookup1 + , testCase "tryLookup2" caseTryLookup2 ] -test_tryLookup1 :: Assertion -test_tryLookup1 = tryLookup "default" "foo" [] @?= "default" +caseTryLookup1 :: Assertion +caseTryLookup1 = tryLookup "default" "foo" [] @?= "default" -test_tryLookup2 :: Assertion -test_tryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" +caseTryLookup2 :: Assertion +caseTryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" From 9f399d0eeaf94ed24fc5f5eb20a2609a9c7518ae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 7 Oct 2009 17:49:29 +0200 Subject: [PATCH 033/624] Exposing RawParam --- Web/Restful/Request.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 2d77324a..37ea98bd 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -23,6 +23,7 @@ module Web.Restful.Request , ParamType , ParamName , ParamValue + , RawParam (..) -- * RawRequest , RawRequest (..) , PathInfo @@ -303,7 +304,7 @@ class Request a where instance Request () where parseRequest = return () --- | Unsures that a String parameter is not blank. +-- | Ensures that a String parameter is not blank. notBlank :: MonadRequestReader m => RawParam -> m String notBlank rp = case paramValue rp of From 7addde1ec4840e9c5ab1cfbaa4091affca9c1883 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 8 Oct 2009 13:11:49 +0200 Subject: [PATCH 034/624] jsonp dep; TODO updates; video mime types --- TODO | 4 ++-- Web/Restful/Helpers/Static.hs | 2 ++ restful.cabal | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/TODO b/TODO index cabb808c..c1392343 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ Catch exceptions and return as 500 errors approot -Request parameters without a request object? -More checking on parameters (minimum length etc) +remove listDetail? +int patterns (#name) diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 8e43925a..de7a0a19 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -57,6 +57,8 @@ mimeType "html" = "text/html" mimeType "png" = "image/png" mimeType "gif" = "image/gif" mimeType "txt" = "text/plain" +mimeType "flv" = "video/x-flv" +mimeType "ogv" = "video/ogg" mimeType _ = "application/octet-stream" ext :: String -> String diff --git a/restful.cabal b/restful.cabal index e97d62ed..9981621f 100644 --- a/restful.cabal +++ b/restful.cabal @@ -16,7 +16,7 @@ library old-locale >= 1.0.0.1, time >= 1.1.3, hack-middleware-clientsession, - hack-middleware-jsonp >= 0.0.1, + hack-middleware-jsonp >= 0.0.2, hack-middleware-cleanpath >= 0.0.1, hack-middleware-gzip, hack-handler-cgi >= 0.0.2, From 16d9c062795273bcaa579d2796612c0fdadb44e8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 8 Oct 2009 20:50:14 +0200 Subject: [PATCH 035/624] data-object 0.2.0 --- Data/Object/Instances.hs | 10 +++--- TODO | 1 - Web/Restful/Application.hs | 14 ++++---- Web/Restful/Generic/ListDetail.hs | 55 ------------------------------- Web/Restful/Response.hs | 8 ++--- restful.cabal | 9 +++-- 6 files changed, 20 insertions(+), 77 deletions(-) delete mode 100644 Web/Restful/Generic/ListDetail.hs diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 3f6d21f5..13402e71 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -26,12 +26,12 @@ import Web.Encodings (encodeJson) import Text.Yaml (encode) class SafeFromObject a where - safeFromObject :: Object -> a + safeFromObject :: RawObject -> a newtype Json = Json { unJson :: B.ByteString } instance SafeFromObject Json where safeFromObject = Json . helper where - helper :: Object -> B.ByteString + helper :: RawObject -> B.ByteString helper (Scalar s) = B.concat [ toLazyByteString "\"" , encodeJson $ fromLazyByteString s @@ -47,7 +47,7 @@ instance SafeFromObject Json where , B.intercalate (toLazyByteString ",") $ map helper2 m , toLazyByteString "}" ] - helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 :: (B.ByteString, RawObject) -> B.ByteString helper2 (k, v) = B.concat [ toLazyByteString "\"" , encodeJson $ fromLazyByteString k @@ -72,7 +72,7 @@ instance SafeFromObject Html where , helper o , toLazyByteString "" ] where - helper :: Object -> B.ByteString + helper :: RawObject -> B.ByteString helper (Scalar s) = B.concat [ toLazyByteString "

          " , toLazyByteString s @@ -88,7 +88,7 @@ instance SafeFromObject Html where toLazyByteString "

          " : map helper2 m ++ [ toLazyByteString "
          " ] - helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 :: (B.ByteString, RawObject) -> B.ByteString helper2 (k, v) = B.concat $ [ toLazyByteString "
          " , toLazyByteString k diff --git a/TODO b/TODO index c1392343..8b7003ca 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,3 @@ Catch exceptions and return as 500 errors approot -remove listDetail? int patterns (#name) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 0fe3dbcd..a847a09a 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -67,18 +67,18 @@ class ResourceName a b => RestfulApp a b | a -> b where -- | Output error response pages. errorHandler :: a -> RawRequest -> ErrorResult -> Reps - errorHandler _ rr NotFound = reps $ toObject $ "Not found: " ++ show rr + errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = - reps $ toObject $ "Redirect to: " ++ url + reps $ toRawObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = - reps $ toObject $ "Internal server error: " ++ e + reps $ toRawObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - reps $ toObject - [ ("errorMsg", toObject "Invalid arguments") - , ("messages", toObject ia) + reps $ toRawObject + [ ("errorMsg", toRawObject "Invalid arguments") + , ("messages", toRawObject ia) ] errorHandler _ _ PermissionDenied = - reps $ toObject "Permission denied" + reps $ toRawObject "Permission denied" -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. diff --git a/Web/Restful/Generic/ListDetail.hs b/Web/Restful/Generic/ListDetail.hs deleted file mode 100644 index 6c4c45e7..00000000 --- a/Web/Restful/Generic/ListDetail.hs +++ /dev/null @@ -1,55 +0,0 @@ ---------------------------------------------------------- --- --- Module : Web.Restful.Generic.ListDetail --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generic responses for listing items and then detailing them. --- ---------------------------------------------------------- -module Web.Restful.Generic.ListDetail - ( ListDetail (..) - , ItemList (..) - , ItemDetail (..) - ) where - -import Web.Restful.Response -import Web.Encodings -import Data.Object -import Data.Object.Instances -import Data.ByteString.Class - -class ToObject a => ListDetail a where - htmlDetail :: a -> String - htmlDetail = fromLazyByteString . unHtml . safeFromObject . toObject - detailTitle :: a -> String - detailUrl :: a -> String - htmlList :: [a] -> String - htmlList l = "
            " ++ concatMap helper l ++ "
          " - where - helper i = "
        • " ++ encodeHtml (detailTitle i) ++ - "
          • " - -- | Often times for the JSON response of the list, we don't need all - -- the information. - treeList :: [a] -> Object -- FIXME - treeList = Sequence . map treeListSingle - treeListSingle :: a -> Object - treeListSingle = toObject - -newtype ItemList a = ItemList [a] -instance ListDetail a => HasReps (ItemList a) where - reps (ItemList l) = - [ ("text/html", toLazyByteString $ htmlList l) - , ("application/json", unJson $ safeFromObject $ treeList l) - ] -newtype ItemDetail a = ItemDetail a -instance ListDetail a => HasReps (ItemDetail a) where - reps (ItemDetail i) = - [ ("text/html", toLazyByteString $ htmlDetail i) - , ("application/json", unJson $ safeFromObject $ toObject i) - ] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 05b6746a..b7db0128 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -36,7 +36,7 @@ module Web.Restful.Response import Data.ByteString.Class import Data.Time.Clock -import Data.Object +import Data.Object hiding (testSuite) import qualified Data.ByteString.Lazy as B import Data.Object.Instances @@ -112,13 +112,13 @@ htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps htmlResponse = genResponse "text/html" -- | Return a response from an Object. -objectResponse :: (Monad m, ToObject o) => o -> m Reps -objectResponse = return . reps . toObject +objectResponse :: (Monad m, ToRawObject o) => o -> m Reps +objectResponse = return . reps . toRawObject -- HasReps instances instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] -instance HasReps Object where +instance HasReps RawObject where reps o = [ ("text/html", unHtml $ safeFromObject o) , ("application/json", unJson $ safeFromObject o) diff --git a/restful.cabal b/restful.cabal index 9981621f..fe8e7e91 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.4 +version: 0.1.5 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -29,8 +29,8 @@ library bytestring-class, web-encodings >= 0.0.1, mtl >= 1.1.0.2, - data-object >= 0.0.2, - yaml >= 0.0.4, + data-object >= 0.2.0, + yaml >= 0.2.0, test-framework, test-framework-quickcheck, test-framework-hunit, @@ -52,6 +52,5 @@ library Web.Restful.Helpers.Auth, Web.Restful.Helpers.Static, Web.Restful.Response.AtomFeed, - Web.Restful.Response.Sitemap, - Web.Restful.Generic.ListDetail + Web.Restful.Response.Sitemap ghc-options: -Wall -Werror From 43b0185049ca0709e9176a1ed807fd3cc461262a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 8 Oct 2009 20:56:19 +0200 Subject: [PATCH 036/624] Implemented approot --- TODO | 1 - Web/Restful/Request.hs | 16 ++++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/TODO b/TODO index 8b7003ca..4755fbb2 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,2 @@ Catch exceptions and return as 500 errors -approot int patterns (#name) diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 37ea98bd..46446b89 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -40,6 +40,7 @@ module Web.Restful.Request , acceptedLanguages , requestPath , parseEnv + , approot -- * Building actual request , Request (..) , Hack.RequestMethod (..) @@ -188,6 +189,21 @@ maybeIdentifier = do parseEnv :: MonadRequestReader m => m Hack.Env parseEnv = rawEnv `fmap` askRawRequest +-- | The URL to the application root (ie, the URL with pathInfo /). +approot :: MonadRequestReader m => m String +approot = do + env <- parseEnv + let (scheme, defPort) = + case Hack.hackUrlScheme env of + Hack.HTTP -> ("http://", 80) + Hack.HTTPS -> ("https://", 443) + let sn = Hack.serverName env + let portSuffix = + if Hack.serverPort env == defPort + then "" + else ':' : show (Hack.serverPort env) + return $! scheme ++ sn ++ portSuffix ++ "/" + -- | Determine the ordered list of language preferences. -- -- FIXME: Future versions should account for some cookie. From f232ae6fd9ea3ecd57325ea3bb038e201ec09a84 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 8 Oct 2009 21:09:53 +0200 Subject: [PATCH 037/624] Int patterns --- TODO | 1 - Web/Restful/Resource.hs | 42 ++++++++++++++++++++++++++++++++++++++--- 2 files changed, 39 insertions(+), 4 deletions(-) diff --git a/TODO b/TODO index 4755fbb2..b74fc905 100644 --- a/TODO +++ b/TODO @@ -1,2 +1 @@ Catch exceptions and return as 500 errors -int patterns (#name) diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 05677ae7..31a5e18d 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -31,7 +31,8 @@ import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) import Data.Enumerable -import Control.Monad (replicateM) +import Control.Monad (replicateM, when) +import Data.Char (isDigit) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit @@ -42,6 +43,7 @@ import Test.QuickCheck data ResourcePatternPiece = Static String | Dynamic String + | DynInt String | Slurp String -- ^ take up the rest of the pieces. must be last deriving Eq instance Show ResourcePattern where @@ -49,6 +51,7 @@ instance Show ResourcePattern where helper (Static s) = '/' : s helper (Dynamic s) = '/' : '$' : s helper (Slurp s) = '/' : '*' : s + helper (DynInt s) = '/' : '#' : s isSlurp :: ResourcePatternPiece -> Bool isSlurp (Slurp _) = True @@ -64,6 +67,7 @@ fromString = ResourcePattern fromString' :: String -> ResourcePatternPiece fromString' ('$':rest) = Dynamic rest fromString' ('*':rest) = Slurp rest +fromString' ('#':rest) = DynInt rest fromString' x = Static x class (Show a, Enumerable a) => ResourceName a b | a -> b where @@ -80,7 +84,10 @@ class (Show a, Enumerable a) => ResourceName a b | a -> b where type SMap = [(String, String)] -data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch +data CheckPatternReturn = + StaticMatch + | DynamicMatch (String, String) + | NoMatch checkPattern :: ResourcePattern -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP @@ -116,6 +123,13 @@ overlaps (Slurp _:_) _ = True overlaps _ (Slurp _:_) = True overlaps (Dynamic _:x) (_:y) = overlaps x y overlaps (_:x) (Dynamic _: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 checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () @@ -144,6 +158,7 @@ testSuite = testGroup "Web.Restful.Resource" , testCase "overlap-slurp" caseOverlap3 , testCase "validatePatterns" caseValidatePatterns , testProperty "show pattern" prop_showPattern + , testCase "integers" caseIntegers ] caseOverlap1 :: Assertion @@ -174,9 +189,30 @@ caseValidatePatterns = prop_showPattern :: ResourcePattern -> Bool prop_showPattern p = fromString (show p) == 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 + let res1 = overlaps (unRP $ fromString a) (unRP $ fromString b) + let res2 = overlaps (unRP $ fromString b) (unRP $ fromString a) + 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 ResourcePatternPiece where arbitrary = do - constr <- elements [Static, Dynamic, Slurp] + constr <- elements [Static, Dynamic, Slurp, DynInt] size <- elements [1..10] s <- replicateM size $ elements ['a'..'z'] return $ constr s From ec355d581103765404b6b06c2d40822e855fa22e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 9 Oct 2009 00:30:01 +0200 Subject: [PATCH 038/624] Added missing DynInt checkPattern clause --- Web/Restful/Resource.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 31a5e18d..a0fa555d 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -108,6 +108,9 @@ checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch checkPattern' (Dynamic x) y = DynamicMatch (x, y) checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" +checkPattern' (DynInt x) y + | all isDigit y = DynamicMatch (x, y) + | otherwise = NoMatch combine :: SMap -> [CheckPatternReturn] -> Maybe SMap combine s [] = Just $ reverse s From 1b643b93e47453f265a08ef6b0adab30c1135a92 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 9 Oct 2009 14:17:09 +0200 Subject: [PATCH 039/624] I18N and exception catching --- TODO | 1 - Web/Restful/Handler.hs | 12 ++++--- Web/Restful/I18N.hs | 58 ++++++++++++++++++++++++++++++++ Web/Restful/Response.hs | 22 +++++++----- Web/Restful/Response/AtomFeed.hs | 3 +- Web/Restful/Response/Sitemap.hs | 3 +- restful.cabal | 3 +- 7 files changed, 83 insertions(+), 19 deletions(-) create mode 100644 Web/Restful/I18N.hs diff --git a/TODO b/TODO index b74fc905..e69de29b 100644 --- a/TODO +++ b/TODO @@ -1 +0,0 @@ -Catch exceptions and return as 500 errors diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 847928ee..ba0da8f7 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -41,6 +41,7 @@ import Control.Applicative import Data.Maybe (fromJust) import qualified Data.ByteString.Lazy as B import qualified Hack +import qualified Control.OldException ------ Handler monad newtype HandlerT m a = @@ -55,7 +56,9 @@ runHandler :: (ErrorResult -> Reps) -> RawRequest -> IO Hack.Response runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - (x, headers') <- inside rr + (x, headers') <- Control.OldException.catch + (inside rr) + (\e -> return (Left $ InternalError $ show e, [])) let extraHeaders = case x of Left r -> getHeaders r @@ -67,14 +70,15 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do Left r -> getStatus r Right _ -> 200 (ctype, selectedRep) <- chooseRep outReps ctypesAll - finalRep <- wrapper ctype selectedRep + let languages = [] -- FIXME + finalRep <- wrapper ctype $ selectedRep languages let headers'' = ("Content-Type", ctype) : headers return $! Hack.Response statusCode headers'' finalRep chooseRep :: Monad m - => [(ContentType, B.ByteString)] + => Reps -> [ContentType] - -> m (ContentType, B.ByteString) + -> m Rep chooseRep rs cs | null rs = fail "All reps must have at least one representation" | otherwise = do diff --git a/Web/Restful/I18N.hs b/Web/Restful/I18N.hs new file mode 100644 index 00000000..945cf4d6 --- /dev/null +++ b/Web/Restful/I18N.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.I18N +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Simple method for internationalization. +-- +--------------------------------------------------------- +module Web.Restful.I18N + ( Language + , Translator + , I18N (..) + , toTranslator + ) where + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as BS +import Data.ByteString.Class + +type Language = String +type Translator = [Language] -> B.ByteString + +class I18N a where + translate :: a -> Translator + +instance I18NString a => I18N a where + translate a langs = toLazyByteString $ helper langs where + helper [] = defTrans a + helper (l:ls) = + case tryTranslate a l of + Nothing -> helper ls + Just s -> s + +class I18NString a where + defTrans :: a -> String + tryTranslate :: a -> Language -> Maybe String + +toTranslator :: LazyByteString lbs => lbs -> Translator +toTranslator = translate . toLazyByteString + +instance I18N B.ByteString where + translate = const + +instance I18N BS.ByteString where + translate bs _ = toLazyByteString bs + +instance I18NString String where + defTrans = id + tryTranslate = const . Just diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index b7db0128..e56f84c4 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -15,7 +15,8 @@ --------------------------------------------------------- module Web.Restful.Response ( -- * Representations - Reps + Rep + , Reps , HasReps (..) , ContentType -- * Abnormal responses @@ -32,21 +33,24 @@ module Web.Restful.Response , objectResponse -- * Tests , testSuite + -- * Re-export + , module Web.Restful.I18N ) where import Data.ByteString.Class import Data.Time.Clock import Data.Object hiding (testSuite) -import qualified Data.ByteString.Lazy as B import Data.Object.Instances import Web.Encodings (formatW3) +import Web.Restful.I18N import Test.Framework (testGroup, Test) type ContentType = String -type Reps = [(ContentType, B.ByteString)] +type Rep = (ContentType, Translator) +type Reps = [Rep] -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. @@ -105,7 +109,7 @@ genResponse :: (Monad m, LazyByteString lbs) => ContentType -> lbs -> m Reps -genResponse ct lbs = return [(ct, toLazyByteString lbs)] +genResponse ct lbs = return [(ct, toTranslator lbs)] -- | Return a response with a text/html content type. htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps @@ -117,15 +121,15 @@ objectResponse = return . reps . toRawObject -- HasReps instances instance HasReps () where - reps _ = [("text/plain", toLazyByteString "")] + reps _ = [("text/plain", translate "")] instance HasReps RawObject where reps o = - [ ("text/html", unHtml $ safeFromObject o) - , ("application/json", unJson $ safeFromObject o) - , ("text/yaml", unYaml $ safeFromObject o) + [ ("text/html", translate $ unHtml $ safeFromObject o) + , ("application/json", translate $ unJson $ safeFromObject o) + , ("text/yaml", translate $ unYaml $ safeFromObject o) ] -instance HasReps [(ContentType, B.ByteString)] where +instance HasReps Reps where reps = id ----- Testing diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 8f093a49..2efed8bf 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -21,7 +21,6 @@ import Web.Restful.Response import Data.Time.Clock import Web.Encodings -import Data.ByteString.Class data AtomFeed = AtomFeed { atomTitle :: String @@ -32,7 +31,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps e = - [ ("application/atom+xml", toLazyByteString $ show e) + [ ("application/atom+xml", translate $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index fd86adde..9e28a9ed 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -24,7 +24,6 @@ import Web.Restful.Response import Web.Encodings import qualified Hack import Web.Restful.Request -import Data.ByteString.Class import Data.Time (UTCTime) data SitemapLoc = AbsLoc String | RelLoc String @@ -79,7 +78,7 @@ instance Show SitemapResponse where instance HasReps SitemapResponse where reps res = - [ ("text/xml", toLazyByteString $ show res) + [ ("text/xml", translate $ show res) ] sitemap :: IO [SitemapUrl] -> Handler diff --git a/restful.cabal b/restful.cabal index fe8e7e91..e2e2bc47 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.5 +version: 0.1.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -47,6 +47,7 @@ library Web.Restful.Handler, Web.Restful.Application, Web.Restful.Resource, + Web.Restful.I18N, Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth, From 7b3743932571dbcb9ebae76e023695479f5c2462 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Oct 2009 11:19:14 +0200 Subject: [PATCH 040/624] checkOverlaps and robots --- Web/Restful/Application.hs | 10 +++++++--- Web/Restful/Response/Sitemap.hs | 6 ++++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index a847a09a..561632e8 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -26,6 +26,7 @@ import Web.Encodings import qualified Data.ByteString.Lazy as B import Data.Object import Data.Enumerable +import Control.Monad (when) import qualified Hack import Hack.Middleware.CleanPath @@ -80,13 +81,17 @@ class ResourceName a b => RestfulApp a b | a -> b where errorHandler _ _ PermissionDenied = reps $ toRawObject "Permission denied" + -- | Whether or not we should check for overlapping resource names. + checkOverlaps :: a -> Bool + checkOverlaps = const True + -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. toHackApp :: RestfulApp resourceName modelType => resourceName -> IO Hack.Application toHackApp a = do - checkResourceName a -- FIXME maybe this should be done compile-time? + when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? model <- getModel a key <- encryptKey a let handlers = getHandler model @@ -123,10 +128,9 @@ toHackApplication sampleRN hm env = do let (handler, urlParams', wrapper) = case findResourceNames resource of [] -> (notFound, [], const return) - [(rn, urlParams'')] -> + ((rn, urlParams''):_) -> let verb = toVerb $ Hack.requestMethod env in (hm rn verb, urlParams'', responseWrapper rn) - x -> error $ "Invalid findResourceNames: " ++ show x let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 9e28a9ed..68e7f13e 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -14,6 +14,7 @@ module Web.Restful.Response.Sitemap ( sitemap + , robots , SitemapUrl (..) , SitemapLoc (..) , SitemapChangeFreq (..) @@ -88,3 +89,8 @@ sitemap urls' = do let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env) urls <- liftIO urls' return $ reps $ SitemapResponse req urls + +robots :: Handler +robots = do + ar <- approot + genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" From ffec788bf7179fff9cb4bc2ed991cb693433665e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 13 Oct 2009 01:50:34 +0200 Subject: [PATCH 041/624] I18N changes; ToHandler --- TODO | 1 + Web/Restful/Handler.hs | 10 ++++++++++ Web/Restful/I18N.hs | 32 ++++++++++++++++++-------------- Web/Restful/Response.hs | 13 ++++++------- 4 files changed, 35 insertions(+), 21 deletions(-) diff --git a/TODO b/TODO index e69de29b..45fb01e7 100644 --- a/TODO +++ b/TODO @@ -0,0 +1 @@ +HTML sitemap generation diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index ba0da8f7..980cfa0d 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -22,6 +22,7 @@ module Web.Restful.Handler , Handler , runHandler , liftIO + , ToHandler (..) -- * Special handlers , redirect , notFound @@ -49,6 +50,15 @@ newtype HandlerT m a = type HandlerIO = HandlerT IO type Handler = HandlerIO Reps +class ToHandler a where + toHandler :: a -> Handler + +instance (Request r, ToHandler h) => ToHandler (r -> h) where + toHandler f = parseRequest >>= toHandler . f + +instance ToHandler Handler where + toHandler = id + runHandler :: (ErrorResult -> Reps) -> (ContentType -> B.ByteString -> IO B.ByteString) -> [ContentType] diff --git a/Web/Restful/I18N.hs b/Web/Restful/I18N.hs index 945cf4d6..9743c8d1 100644 --- a/Web/Restful/I18N.hs +++ b/Web/Restful/I18N.hs @@ -19,7 +19,8 @@ module Web.Restful.I18N ( Language , Translator , I18N (..) - , toTranslator + , translateBS + , NoI18N (..) ) where import qualified Data.ByteString.Lazy as B @@ -31,8 +32,6 @@ type Translator = [Language] -> B.ByteString class I18N a where translate :: a -> Translator - -instance I18NString a => I18N a where translate a langs = toLazyByteString $ helper langs where helper [] = defTrans a helper (l:ls) = @@ -40,19 +39,24 @@ instance I18NString a => I18N a where Nothing -> helper ls Just s -> s -class I18NString a where defTrans :: a -> String tryTranslate :: a -> Language -> Maybe String -toTranslator :: LazyByteString lbs => lbs -> Translator -toTranslator = translate . toLazyByteString - -instance I18N B.ByteString where - translate = const - -instance I18N BS.ByteString where - translate bs _ = toLazyByteString bs - -instance I18NString String where +instance I18N String where defTrans = id tryTranslate = const . Just + +translateBS :: I18N a => a -> Translator +translateBS a = toLazyByteString . translate a + +class NoI18N a where + noTranslate :: a -> Translator + +instance NoI18N B.ByteString where + noTranslate = const + +instance NoI18N BS.ByteString where + noTranslate = const . toLazyByteString + +instance NoI18N String where + noTranslate = const . toLazyByteString diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index e56f84c4..07ad806d 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -37,7 +37,6 @@ module Web.Restful.Response , module Web.Restful.I18N ) where -import Data.ByteString.Class import Data.Time.Clock import Data.Object hiding (testSuite) import Data.Object.Instances @@ -105,14 +104,14 @@ response :: (Monad m, HasReps reps) => reps -> m Reps response = return . reps -- | Return a response with an arbitrary content type. -genResponse :: (Monad m, LazyByteString lbs) +genResponse :: (Monad m, NoI18N lbs) => ContentType -> lbs -> m Reps -genResponse ct lbs = return [(ct, toTranslator lbs)] +genResponse ct lbs = return [(ct, noTranslate lbs)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps +htmlResponse :: (Monad m, NoI18N lbs) => lbs -> m Reps htmlResponse = genResponse "text/html" -- | Return a response from an Object. @@ -124,9 +123,9 @@ instance HasReps () where reps _ = [("text/plain", translate "")] instance HasReps RawObject where reps o = - [ ("text/html", translate $ unHtml $ safeFromObject o) - , ("application/json", translate $ unJson $ safeFromObject o) - , ("text/yaml", translate $ unYaml $ safeFromObject o) + [ ("text/html", noTranslate $ unHtml $ safeFromObject o) + , ("application/json", noTranslate $ unJson $ safeFromObject o) + , ("text/yaml", noTranslate $ unYaml $ safeFromObject o) ] instance HasReps Reps where From 564d1431df5cd0014ab0069ffb07f6f3840c7eae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 14 Oct 2009 00:46:14 +0200 Subject: [PATCH 042/624] Removed model bits --- Data/Object/Instances.hs | 2 +- TODO | 1 + Web/Restful/Application.hs | 18 ++++++----------- Web/Restful/Helpers/Auth.hs | 39 +++++++++++++++++++++---------------- Web/Restful/Resource.hs | 7 +++---- restful.cabal | 2 +- 6 files changed, 34 insertions(+), 35 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 13402e71..3c9ae8ae 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -89,7 +89,7 @@ instance SafeFromObject Html where map helper2 m ++ [ toLazyByteString "" ] helper2 :: (B.ByteString, RawObject) -> B.ByteString - helper2 (k, v) = B.concat $ + helper2 (k, v) = B.concat [ toLazyByteString "
          " , toLazyByteString k , toLazyByteString "
          " diff --git a/TODO b/TODO index 45fb01e7..db5eacf3 100644 --- a/TODO +++ b/TODO @@ -1 +1,2 @@ HTML sitemap generation +Remove model diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 561632e8..dc9f5296 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,10 +43,7 @@ import Web.Restful.Constants import Web.Restful.Resource -- | A data type that can be turned into a Hack application. -class ResourceName a b => RestfulApp a b | a -> b where - -- | Load up the model, ie the data which use passed to each handler. - getModel :: a -> IO b - +class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile @@ -87,25 +83,23 @@ class ResourceName a b => RestfulApp a b | a -> b where -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. -toHackApp :: RestfulApp resourceName modelType +toHackApp :: RestfulApp resourceName => resourceName -> IO Hack.Application toHackApp a = do when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? - model <- getModel a key <- encryptKey a - let handlers = getHandler model - app' = toHackApplication a handlers + let app' = toHackApplication a getHandler clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] return app -findResourceNames :: ResourceName a model +findResourceNames :: ResourceName a => Resource -> [(a, [(String, String)])] findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate -checkPatternHelper :: ResourceName a model +checkPatternHelper :: ResourceName a => Resource -> a -> Maybe (a, [(String, String)]) @@ -119,7 +113,7 @@ takeJusts [] = [] takeJusts (Nothing:rest) = takeJusts rest takeJusts (Just x:rest) = x : takeJusts rest -toHackApplication :: RestfulApp resourceName model +toHackApplication :: RestfulApp resourceName => resourceName -> (resourceName -> Verb -> Handler) -> Hack.Application diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 272fc656..9b3457ec 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -15,6 +15,9 @@ --------------------------------------------------------- module Web.Restful.Helpers.Auth ( AuthResource + , authHandler + , authResourcePattern + , RpxnowApiKey (..) ) where import qualified Hack @@ -50,24 +53,26 @@ instance Enumerable AuthResource where , LoginRpxnow ] -type RpxnowApiKey = String -- FIXME newtype -instance ResourceName AuthResource (Maybe RpxnowApiKey) where - getHandler _ Check Get = authCheck - getHandler _ Logout Get = authLogout - getHandler _ Openid Get = authOpenidForm - getHandler _ OpenidForward Get = authOpenidForward - getHandler _ OpenidComplete Get = authOpenidComplete - -- two different versions of RPX protocol apparently... - getHandler (Just key) LoginRpxnow Get = rpxnowLogin key - getHandler (Just key) LoginRpxnow Post = rpxnowLogin key - getHandler _ _ _ = notFound +newtype RpxnowApiKey = RpxnowApiKey String - resourcePattern Check = "/auth/check/" - resourcePattern Logout = "/auth/logout/" - resourcePattern Openid = "/auth/openid/" - resourcePattern OpenidForward = "/auth/openid/forward/" - resourcePattern OpenidComplete = "/auth/openid/complete/" - resourcePattern LoginRpxnow = "/auth/login/rpxnow/" +authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler +authHandler _ Check Get = authCheck +authHandler _ Logout Get = authLogout +authHandler _ Openid Get = authOpenidForm +authHandler _ OpenidForward Get = authOpenidForward +authHandler _ OpenidComplete Get = authOpenidComplete +-- two different versions of RPX protocol apparently... +authHandler (Just (RpxnowApiKey key)) LoginRpxnow Get = rpxnowLogin key +authHandler (Just (RpxnowApiKey key)) LoginRpxnow Post = rpxnowLogin key +authHandler _ _ _ = notFound + +authResourcePattern :: AuthResource -> String -- FIXME supply prefix as well +authResourcePattern Check = "/auth/check/" +authResourcePattern Logout = "/auth/logout/" +authResourcePattern Openid = "/auth/openid/" +authResourcePattern OpenidForward = "/auth/openid/forward/" +authResourcePattern OpenidComplete = "/auth/openid/complete/" +authResourcePattern LoginRpxnow = "/auth/login/rpxnow/" data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index a0fa555d..3bffbffb 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -70,7 +69,7 @@ fromString' ('*':rest) = Slurp rest fromString' ('#':rest) = DynInt rest fromString' x = Static x -class (Show a, Enumerable a) => ResourceName a b | a -> b where +class (Show a, Enumerable a) => ResourceName a where -- | Get the URL pattern for each different resource name. -- Something like /foo/$bar/baz/ will match the regular expression -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. @@ -80,7 +79,7 @@ class (Show a, Enumerable a) => ResourceName a b | a -> b where resourcePattern :: a -> String -- | Find the handler for each resource name/verb pattern. - getHandler :: b -> a -> Verb -> Handler + getHandler :: a -> Verb -> Handler type SMap = [(String, String)] @@ -135,7 +134,7 @@ overlaps (Static s:x) (DynInt _:y) | otherwise = False overlaps (Static a:x) (Static b:y) = a == b && overlaps x y -checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () +checkResourceName :: (Monad m, ResourceName rn) => rn -> m () checkResourceName rn = do let avs@(y:_) = enumerate _ignore = asTypeOf rn y diff --git a/restful.cabal b/restful.cabal index e2e2bc47..e598a704 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.6 +version: 0.1.7 license: BSD3 license-file: LICENSE author: Michael Snoyman From 32ae0439f76b0dfc6a4315657d1a052411c66796 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 15 Oct 2009 08:58:41 +0200 Subject: [PATCH 043/624] Switch from To/FromRawObjec to To/FromObject --- Data/Object/Instances.hs | 13 +++++++------ Web/Restful/Application.hs | 6 ++++++ Web/Restful/Response.hs | 8 +++++--- 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 3c9ae8ae..60cc6666 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -20,6 +20,7 @@ module Data.Object.Instances ) where import Data.Object +import Data.Object.Raw import qualified Data.ByteString.Lazy as B import Data.ByteString.Class import Web.Encodings (encodeJson) @@ -32,7 +33,7 @@ newtype Json = Json { unJson :: B.ByteString } instance SafeFromObject Json where safeFromObject = Json . helper where helper :: RawObject -> B.ByteString - helper (Scalar s) = B.concat + helper (Scalar (Raw s)) = B.concat [ toLazyByteString "\"" , encodeJson $ fromLazyByteString s , toLazyByteString "\"" @@ -47,8 +48,8 @@ instance SafeFromObject Json where , B.intercalate (toLazyByteString ",") $ map helper2 m , toLazyByteString "}" ] - helper2 :: (B.ByteString, RawObject) -> B.ByteString - helper2 (k, v) = B.concat + helper2 :: (Raw, RawObject) -> B.ByteString + helper2 (Raw k, v) = B.concat [ toLazyByteString "\"" , encodeJson $ fromLazyByteString k , toLazyByteString "\":" @@ -73,7 +74,7 @@ instance SafeFromObject Html where , toLazyByteString "" ] where helper :: RawObject -> B.ByteString - helper (Scalar s) = B.concat + helper (Scalar (Raw s)) = B.concat [ toLazyByteString "

          " , toLazyByteString s , toLazyByteString "

          " @@ -88,8 +89,8 @@ instance SafeFromObject Html where toLazyByteString "
          " : map helper2 m ++ [ toLazyByteString "
          " ] - helper2 :: (B.ByteString, RawObject) -> B.ByteString - helper2 (k, v) = B.concat + helper2 :: (Raw, RawObject) -> B.ByteString + helper2 (Raw k, v) = B.concat [ toLazyByteString "
          " , toLazyByteString k , toLazyByteString "
          " diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index dc9f5296..ce55aa4e 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Restful.Application @@ -24,6 +25,7 @@ module Web.Restful.Application import Web.Encodings import qualified Data.ByteString.Lazy as B import Data.Object +import Data.Object.Raw import Data.Enumerable import Control.Monad (when) @@ -42,6 +44,10 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource +-- FIXME move to Data.Object.Raw +toRawObject :: ToObject o Raw Raw => o -> RawObject +toRawObject = toObject + -- | A data type that can be turned into a Hack application. class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 07ad806d..6ae34e32 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- @@ -38,7 +39,8 @@ module Web.Restful.Response ) where import Data.Time.Clock -import Data.Object hiding (testSuite) +import Data.Object +import Data.Object.Raw import Data.Object.Instances import Web.Encodings (formatW3) @@ -115,8 +117,8 @@ htmlResponse :: (Monad m, NoI18N lbs) => lbs -> m Reps htmlResponse = genResponse "text/html" -- | Return a response from an Object. -objectResponse :: (Monad m, ToRawObject o) => o -> m Reps -objectResponse = return . reps . toRawObject +objectResponse :: (Monad m, ToObject o Raw Raw) => o -> m Reps +objectResponse o = return $ reps $ (toObject o :: RawObject) -- HasReps instances instance HasReps () where From 971d05050c67d79492e69d330d4c59b64a5a4362 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 15 Oct 2009 09:14:21 +0200 Subject: [PATCH 044/624] data-object switch from To/FromRawObject to To/FromObject --- Web/Restful/Application.hs | 5 --- Web/Restful/I18N.hs | 62 -------------------------------- Web/Restful/Response.hs | 25 +++++++++---- Web/Restful/Response/AtomFeed.hs | 2 +- Web/Restful/Response/Sitemap.hs | 2 +- restful.cabal | 3 +- 6 files changed, 21 insertions(+), 78 deletions(-) delete mode 100644 Web/Restful/I18N.hs diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index ce55aa4e..28312cc1 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -24,7 +24,6 @@ module Web.Restful.Application import Web.Encodings import qualified Data.ByteString.Lazy as B -import Data.Object import Data.Object.Raw import Data.Enumerable import Control.Monad (when) @@ -44,10 +43,6 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource --- FIXME move to Data.Object.Raw -toRawObject :: ToObject o Raw Raw => o -> RawObject -toRawObject = toObject - -- | A data type that can be turned into a Hack application. class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. diff --git a/Web/Restful/I18N.hs b/Web/Restful/I18N.hs deleted file mode 100644 index 9743c8d1..00000000 --- a/Web/Restful/I18N.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} ---------------------------------------------------------- --- --- Module : Web.Restful.I18N --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Simple method for internationalization. --- ---------------------------------------------------------- -module Web.Restful.I18N - ( Language - , Translator - , I18N (..) - , translateBS - , NoI18N (..) - ) where - -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString as BS -import Data.ByteString.Class - -type Language = String -type Translator = [Language] -> B.ByteString - -class I18N a where - translate :: a -> Translator - translate a langs = toLazyByteString $ helper langs where - helper [] = defTrans a - helper (l:ls) = - case tryTranslate a l of - Nothing -> helper ls - Just s -> s - - defTrans :: a -> String - tryTranslate :: a -> Language -> Maybe String - -instance I18N String where - defTrans = id - tryTranslate = const . Just - -translateBS :: I18N a => a -> Translator -translateBS a = toLazyByteString . translate a - -class NoI18N a where - noTranslate :: a -> Translator - -instance NoI18N B.ByteString where - noTranslate = const - -instance NoI18N BS.ByteString where - noTranslate = const . toLazyByteString - -instance NoI18N String where - noTranslate = const . toLazyByteString diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 6ae34e32..44691429 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -34,23 +34,34 @@ module Web.Restful.Response , objectResponse -- * Tests , testSuite - -- * Re-export - , module Web.Restful.I18N + -- * Translation + , TranslatorBS + , noTranslate + , translateBS ) where import Data.Time.Clock import Data.Object import Data.Object.Raw +import Data.Object.Translate import Data.Object.Instances +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Class import Web.Encodings (formatW3) -import Web.Restful.I18N import Test.Framework (testGroup, Test) type ContentType = String -type Rep = (ContentType, Translator) +type TranslatorBS = [Language] -> ByteString +noTranslate :: LazyByteString lbs => lbs -> TranslatorBS +noTranslate lbs = const $ toLazyByteString lbs + +translateBS :: CanTranslate t => t -> TranslatorBS +translateBS t langs = toLazyByteString $ translate t langs + +type Rep = (ContentType, TranslatorBS) type Reps = [Rep] -- | Something which can be represented as multiple content types. @@ -106,14 +117,14 @@ response :: (Monad m, HasReps reps) => reps -> m Reps response = return . reps -- | Return a response with an arbitrary content type. -genResponse :: (Monad m, NoI18N lbs) +genResponse :: (Monad m, LazyByteString lbs) => ContentType -> lbs -> m Reps genResponse ct lbs = return [(ct, noTranslate lbs)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, NoI18N lbs) => lbs -> m Reps +htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps htmlResponse = genResponse "text/html" -- | Return a response from an Object. @@ -122,7 +133,7 @@ objectResponse o = return $ reps $ (toObject o :: RawObject) -- HasReps instances instance HasReps () where - reps _ = [("text/plain", translate "")] + reps _ = [("text/plain", noTranslate "")] instance HasReps RawObject where reps o = [ ("text/html", noTranslate $ unHtml $ safeFromObject o) diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index 2efed8bf..fa2ad788 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -31,7 +31,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps e = - [ ("application/atom+xml", translate $ show e) + [ ("application/atom+xml", noTranslate $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 68e7f13e..f75a7601 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -79,7 +79,7 @@ instance Show SitemapResponse where instance HasReps SitemapResponse where reps res = - [ ("text/xml", translate $ show res) + [ ("text/xml", noTranslate $ show res) ] sitemap :: IO [SitemapUrl] -> Handler diff --git a/restful.cabal b/restful.cabal index e598a704..0d989903 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.7 +version: 0.1.8 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -47,7 +47,6 @@ library Web.Restful.Handler, Web.Restful.Application, Web.Restful.Resource, - Web.Restful.I18N, Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth, From d081f6f516a48823297c64b1b407d40cda907d41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 21 Oct 2009 00:57:54 +0200 Subject: [PATCH 045/624] Switched some code to MonadAttempt --- Web/Restful/Handler.hs | 4 ++++ Web/Restful/Helpers/Auth.hs | 20 +++++++++++--------- Web/Restful/Request.hs | 14 ++++++++++---- restful.cabal | 10 ++++++---- 4 files changed, 31 insertions(+), 17 deletions(-) diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 980cfa0d..01c49b87 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -36,6 +36,7 @@ import Web.Restful.Request import Web.Restful.Response import Control.Monad.Trans +import Control.Monad.Attempt.Class import Control.Monad (liftM, ap) import Control.Applicative @@ -131,6 +132,9 @@ instance Monad m => MonadRequestReader (HandlerT m) where errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] authRequired = errorResult PermissionDenied +instance Monad m => MonadAttempt (HandlerT m) where + failure = errorResult . InternalError . show + ------ Special handlers errorResult :: Monad m => ErrorResult -> HandlerT m a errorResult er = HandlerT (const $ return (Left er, [])) diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 9b3457ec..6e3207de 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -31,8 +31,10 @@ import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) import Control.Monad.Reader +import Control.Monad.Attempt import Data.Maybe (fromMaybe) +import Data.Attempt data AuthResource = Check @@ -104,21 +106,21 @@ authOpenidForward = do let complete = "http://" ++ Hack.serverName env ++ ":" ++ show (Hack.serverPort env) ++ "/auth/openid/complete/" - res <- liftIO $ OpenId.getForwardUrl oid complete + res <- runAttemptT $ OpenId.getForwardUrl oid complete case res of - Left err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (err :: String) - Right url -> redirect url + Failure err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (show err) + Success url -> redirect url authOpenidComplete :: Handler authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" - res <- liftIO $ OpenId.authenticate gets' + res <- runAttemptT $ OpenId.authenticate gets' case res of - Left err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (err :: String) - Right (OpenId.Identifier ident) -> do + Failure err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (show err) + Success (OpenId.Identifier ident) -> do deleteCookie "DEST" header authCookieName ident redirect $ fromMaybe "/" dest @@ -148,7 +150,7 @@ rpxnowLogin apiKey = do Just "" -> "/" Just ('#':rest) -> rest Just s -> s - ident <- join $ liftIO $ Rpxnow.authenticate apiKey token + ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident redirect dest diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 46446b89..c2e93460 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} --------------------------------------------------------- -- @@ -50,7 +49,6 @@ module Web.Restful.Request import qualified Hack import Data.Function.Predicate (equals) -import Control.Monad.Error () import Web.Restful.Constants import Web.Restful.Utils import Control.Applicative (Applicative (..)) @@ -275,9 +273,17 @@ instance Parameter a => Parameter (Maybe a) where " values, expecting 0 or 1" instance Parameter a => Parameter [a] where - readParams = mapM readParam + readParams = mapM' readParam where + mapM' f = sequence' . map f + sequence' :: [Either String v] -> Either String [v] + sequence' [] = Right [] + sequence' (Left l:_) = Left l + sequence' (Right r:rest) = + case sequence' rest of + Left l -> Left l + Right rest' -> Right $ r : rest' -instance Parameter String where +instance Parameter [Char] where readParam = Right . paramValue instance Parameter Int where diff --git a/restful.cabal b/restful.cabal index 0d989903..32c3084b 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.8 +version: 0.1.9 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,13 +22,12 @@ library hack-handler-cgi >= 0.0.2, hack >= 2009.5.19, split >= 0.1.1, - authenticate >= 0.0.1, + authenticate >= 0.2.0, data-default >= 0.2, predicates >= 0.1, bytestring >= 0.9.1.4, bytestring-class, web-encodings >= 0.0.1, - mtl >= 1.1.0.2, data-object >= 0.2.0, yaml >= 0.2.0, test-framework, @@ -37,7 +36,10 @@ library HUnit, QuickCheck == 1.*, enumerable >= 0.0.3, - directory >= 1 + directory >= 1, + transformers >= 0.1.4.0, + monads-fd >= 0.0.0.1, + attempt exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, From 8720fcd6efcbf3e854fa6c1fd97e0ac6009843f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 26 Oct 2009 07:31:07 +0200 Subject: [PATCH 046/624] Recent attempt and data-object changes --- TODO | 1 + Web/Restful/Handler.hs | 1 + restful.cabal | 1 + 3 files changed, 3 insertions(+) diff --git a/TODO b/TODO index db5eacf3..09661ca9 100644 --- a/TODO +++ b/TODO @@ -1,2 +1,3 @@ HTML sitemap generation Remove model +Authentication seems broken diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 01c49b87..872c2323 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -134,6 +134,7 @@ instance Monad m => MonadRequestReader (HandlerT m) where instance Monad m => MonadAttempt (HandlerT m) where failure = errorResult . InternalError . show + wrapFailure _ = id -- We don't actually use exception types ------ Special handlers errorResult :: Monad m => ErrorResult -> HandlerT m a diff --git a/restful.cabal b/restful.cabal index 32c3084b..c7f65171 100644 --- a/restful.cabal +++ b/restful.cabal @@ -29,6 +29,7 @@ library bytestring-class, web-encodings >= 0.0.1, data-object >= 0.2.0, + data-object-translate, yaml >= 0.2.0, test-framework, test-framework-quickcheck, From 1decaa742b035fd4ea80aafd6655c07b8858bbac Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Nov 2009 15:17:35 +0200 Subject: [PATCH 047/624] Massive changes to response and handler stuff --- Web/Restful/Application.hs | 50 ++++++++---- Web/Restful/Handler.hs | 136 +++++++++++++++---------------- Web/Restful/Helpers/Auth.hs | 8 +- Web/Restful/Helpers/Static.hs | 2 +- Web/Restful/Request.hs | 2 + Web/Restful/Response.hs | 116 ++++++++++++++++++-------- Web/Restful/Response/AtomFeed.hs | 6 +- Web/Restful/Response/Sitemap.hs | 8 +- restful.cabal | 8 +- 9 files changed, 201 insertions(+), 135 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 28312cc1..d5c01581 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,7 +23,6 @@ module Web.Restful.Application ) where import Web.Encodings -import qualified Data.ByteString.Lazy as B import Data.Object.Raw import Data.Enumerable import Control.Monad (when) @@ -58,13 +57,8 @@ class ResourceName a => RestfulApp a where , methodOverride ] - -- | Wrappers for cleaning up responses. Especially intended for - -- beautifying static HTML. FIXME more user friendly. - responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString - responseWrapper _ _ = return - -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> Reps + errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = reps $ toRawObject $ "Redirect to: " ++ url @@ -119,21 +113,44 @@ toHackApplication :: RestfulApp resourceName -> (resourceName -> Verb -> Handler) -> Hack.Application toHackApplication sampleRN hm env = do + -- The following is safe since we run cleanPath as middleware let (Right resource) = splitPath $ Hack.pathInfo env - let (handler, urlParams', wrapper) = + let (handler :: Handler, urlParams') = case findResourceNames resource of - [] -> (notFound, [], const return) + [] -> (notFound, []) ((rn, urlParams''):_) -> let verb = toVerb $ Hack.requestMethod env - in (hm rn verb, urlParams'', responseWrapper rn) + in (hm rn verb, urlParams'') let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - runHandler (errorHandler sampleRN rr) - wrapper - ctypes' - handler - rr + r <- + runHandler handler rr ctypes' >>= + either (applyErrorHandler sampleRN rr ctypes') return + responseToHackResponse (rawLanguages rr) r + +applyErrorHandler :: (RestfulApp ra, Monad m) + => ra + -> RawRequest + -> [ContentType] + -> ErrorResult + -> m Response +applyErrorHandler ra rr cts er = do + let (ct, c) = chooseRep cts (errorHandler ra rr er) + c' <- c + return $ Response + (getStatus er) + (getHeaders er) + ct + c' + +responseToHackResponse :: [String] -- ^ language list + -> Response -> IO Hack.Response +responseToHackResponse ls (Response sc hs ct c) = do + hs' <- mapM toPair hs + let hs'' = ("Content-Type", ct) : hs' + let asLBS = runContent ls c + return $ Hack.Response sc hs'' asLBS envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = @@ -145,4 +162,5 @@ envToRawRequest urlParams' env = $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest rawPieces urlParams' gets' posts cookies' files env + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 872c2323..4494384b 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Restful.Handler @@ -35,31 +36,78 @@ module Web.Restful.Handler import Web.Restful.Request import Web.Restful.Response -import Control.Monad.Trans -import Control.Monad.Attempt.Class -import Control.Monad (liftM, ap) -import Control.Applicative +import Control.Exception hiding (Handler) -import Data.Maybe (fromJust) -import qualified Data.ByteString.Lazy as B -import qualified Hack -import qualified Control.OldException +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Attempt + +import Data.Typeable ------ Handler monad -newtype HandlerT m a = - HandlerT (RawRequest -> m (Either ErrorResult a, [Header])) +type HandlerT m = + ReaderT RawRequest ( + WriterT [Header] ( + AttemptT m + ) + ) type HandlerIO = HandlerT IO -type Handler = HandlerIO Reps +type Handler = HandlerIO [RepT HandlerIO] + +instance MonadRequestReader HandlerIO where + askRawRequest = ask + invalidParam _pt _pn _pe = error "invalidParam" + authRequired = error "authRequired" +instance Exception e => MonadFailure e HandlerIO where + failure = error "HandlerIO failure" class ToHandler a where toHandler :: a -> Handler +{- FIXME instance (Request r, ToHandler h) => ToHandler (r -> h) where toHandler f = parseRequest >>= toHandler . f +-} instance ToHandler Handler where toHandler = id +{- FIXME +instance HasReps r HandlerIO => ToHandler (HandlerIO r) where + toHandler = fmap reps +-} + +runHandler :: Handler + -> RawRequest + -> [ContentType] + -> IO (Either ErrorResult Response) +runHandler h rr cts = do + let ares = runAttemptT $ runWriterT $ runReaderT (joinHandler cts h) rr + ares' <- takeAllExceptions ares + return $ attempt (Left . toErrorResult) (Right . toResponse) ares' + where + takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) + takeAllExceptions ioa = + Control.Exception.catch ioa (return . Failure) + toErrorResult :: Exception e => e -> ErrorResult + toErrorResult e = + case cast e of + Just x -> x + Nothing -> InternalError $ show e + toResponse :: ((ContentType, Content), [Header]) -> Response + toResponse ((ct, c), hs) = Response 200 hs ct c + +joinHandler :: Monad m + => [ContentType] + -> m [RepT m] + -> m (ContentType, Content) +joinHandler cts rs = do + rs' <- rs + let (ct, c) = chooseRep cts rs' + c' <- c + return (ct, c') + +{- runHandler :: (ErrorResult -> Reps) -> (ContentType -> B.ByteString -> IO B.ByteString) -> [ContentType] @@ -67,9 +115,6 @@ runHandler :: (ErrorResult -> Reps) -> RawRequest -> IO Hack.Response runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - (x, headers') <- Control.OldException.catch - (inside rr) - (\e -> return (Left $ InternalError $ show e, [])) let extraHeaders = case x of Left r -> getHeaders r @@ -85,67 +130,18 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do finalRep <- wrapper ctype $ selectedRep languages let headers'' = ("Content-Type", ctype) : headers return $! Hack.Response statusCode headers'' finalRep - -chooseRep :: Monad m - => Reps - -> [ContentType] - -> m Rep -chooseRep rs cs - | null rs = fail "All reps must have at least one representation" - | otherwise = do - let availCs = map fst rs - case filter (`elem` availCs) cs of - [] -> return $ head rs - [ctype] -> return (ctype, fromJust $ lookup ctype rs) - _ -> fail "Overlapping representations" - -instance MonadTrans HandlerT where - lift ma = HandlerT $ const $ do - a <- ma - return (Right a, []) - -instance MonadIO HandlerIO where - liftIO = lift - -instance Monad m => Functor (HandlerT m) where - fmap = liftM - -instance Monad m => Monad (HandlerT m) where - return = lift . return - fail s = HandlerT (const $ return (Left $ InternalError s, [])) - (HandlerT mx) >>= f = HandlerT $ \rr -> do - (x, hs1) <- mx rr - case x of - Left x' -> return (Left x', hs1) - Right a -> do - let (HandlerT b') = f a - (b, hs2) <- b' rr - return (b, hs1 ++ hs2) - -instance Monad m => Applicative (HandlerT m) where - pure = return - (<*>) = ap - -instance Monad m => MonadRequestReader (HandlerT m) where - askRawRequest = HandlerT $ \rr -> return (Right rr, []) - invalidParam ptype name msg = - errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)] - authRequired = errorResult PermissionDenied - -instance Monad m => MonadAttempt (HandlerT m) where - failure = errorResult . InternalError . show - wrapFailure _ = id -- We don't actually use exception types +-} ------ Special handlers -errorResult :: Monad m => ErrorResult -> HandlerT m a -errorResult er = HandlerT (const $ return (Left er, [])) +errorResult :: ErrorResult -> HandlerIO a +errorResult = lift . lift . failure -- FIXME more instances in Attempt? -- | Redirect to the given URL. -redirect :: Monad m => String -> HandlerT m a +redirect :: String -> HandlerIO a redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. -notFound :: Monad m => HandlerT m a +notFound :: HandlerIO a notFound = errorResult NotFound ------- Headers @@ -166,4 +162,4 @@ header :: Monad m => String -> String -> HandlerT m () header a = addHeader . Header a addHeader :: Monad m => Header -> HandlerT m () -addHeader h = HandlerT (const $ return (Right (), [h])) +addHeader = tell . return diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 6e3207de..accbb097 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -97,7 +97,7 @@ authOpenidForm = do case dest of Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () - htmlResponse html + return $ htmlResponse html authOpenidForward :: Handler authOpenidForward = do @@ -158,8 +158,8 @@ authCheck :: Handler authCheck = do ident <- maybeIdentifier case ident of - Nothing -> objectResponse [("status", "notloggedin")] - Just i -> objectResponse + Nothing -> return $ objectResponse [("status", "notloggedin")] + Just i -> return $ objectResponse [ ("status", "loggedin") , ("ident", i) ] @@ -167,4 +167,4 @@ authCheck = do authLogout :: Handler authLogout = do deleteCookie authCookieName - objectResponse [("status", "loggedout")] + return $ objectResponse [("status", "loggedout")] diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index de7a0a19..7a530998 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -46,7 +46,7 @@ getStatic fl = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> genResponse (mimeType $ ext fp) bs + Just bs -> return $ genResponse (mimeType $ ext fp) bs mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index c2e93460..f89b103f 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -55,6 +55,7 @@ import Control.Applicative (Applicative (..)) import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) +import Data.Object.Translate (Language) -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -232,6 +233,7 @@ data RawRequest = RawRequest , rawCookies :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo)] , rawEnv :: Hack.Env + , rawLanguages :: [Language] } deriving Show diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 44691429..cd768bf9 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -15,11 +17,18 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( -- * Representations - Rep - , Reps + ( Response (..) + -- * Representations + , RepT + , chooseRep , HasReps (..) , ContentType + -- * Content + , Content + , ToContent (..) + , runContent + , lbsContent + , translateContent -- * Abnormal responses , ErrorResult (..) , getHeaders @@ -28,16 +37,11 @@ module Web.Restful.Response , Header (..) , toPair -- * Generic responses - , response , genResponse , htmlResponse , objectResponse -- * Tests , testSuite - -- * Translation - , TranslatorBS - , noTranslate - , translateBS ) where import Data.Time.Clock @@ -45,33 +49,72 @@ import Data.Object import Data.Object.Raw import Data.Object.Translate import Data.Object.Instances -import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Class +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LTE import Web.Encodings (formatW3) import Test.Framework (testGroup, Test) +import Data.Generics +import Control.Exception (Exception) +import Data.Maybe (fromJust) + +data Response = Response Int [Header] ContentType Content + type ContentType = String -type TranslatorBS = [Language] -> ByteString -noTranslate :: LazyByteString lbs => lbs -> TranslatorBS -noTranslate lbs = const $ toLazyByteString lbs +data Content = ByteString LBS.ByteString + | Text LT.Text + | TransText ([Language] -> LT.Text) -translateBS :: CanTranslate t => t -> TranslatorBS -translateBS t langs = toLazyByteString $ translate t langs +runContent :: [Language] -> Content -> LBS.ByteString +runContent _ (ByteString lbs) = lbs +runContent _ (Text lt) = LTE.encodeUtf8 lt +runContent ls (TransText t) = LTE.encodeUtf8 $ t ls -type Rep = (ContentType, TranslatorBS) -type Reps = [Rep] +class ToContent a where + toContent :: a -> Content +instance ToContent LBS.ByteString where + toContent = ByteString +instance ToContent String where + toContent = Text . LT.pack +instance ToContent ([Language] -> String) where + toContent f = TransText $ LT.pack . f +instance ToContent Translator where + toContent = TransText + +lbsContent :: LazyByteString lbs => lbs -> Content +lbsContent = ByteString . toLazyByteString + +translateContent :: CanTranslate t => t -> Content +translateContent t = toContent $ translate t + +type RepT m = (ContentType, m Content) + +chooseRep :: Monad m + => [ContentType] + -> [RepT m] + -> RepT m +chooseRep cs rs + | null rs = error "All reps must have at least one representation" -- FIXME + | otherwise = do + let availCs = map fst rs + case filter (`elem` availCs) cs of + [] -> head rs + [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME + _ -> error "Overlapping representations" -- FIXME just take the first? -- | Something which can be represented as multiple content types. -- Each content type is called a representation of the data. -class HasReps a where +class Monad m => HasReps a m where -- | Provide an ordered list of possible representations, depending on -- content type. If the user asked for a specific response type (like -- text/html), then that will get priority. If not, then the first -- element in this list will be used. - reps :: a -> Reps + reps :: a -> [RepT m] -- | Abnormal return codes. data ErrorResult = @@ -80,6 +123,8 @@ data ErrorResult = | InternalError String | InvalidArgs [(String, String)] | PermissionDenied + deriving (Show, Typeable) +instance Exception ErrorResult getStatus :: ErrorResult -> Int getStatus (Redirect _) = 303 @@ -112,37 +157,36 @@ toPair (DeleteCookie key) = return toPair (Header key value) = return (key, value) ------ Generic responses --- | Lifts a 'HasReps' into a monad. -response :: (Monad m, HasReps reps) => reps -> m Reps -response = return . reps - +-- FIXME move these to Handler? -- | Return a response with an arbitrary content type. genResponse :: (Monad m, LazyByteString lbs) => ContentType -> lbs - -> m Reps -genResponse ct lbs = return [(ct, noTranslate lbs)] + -> [RepT m] +genResponse ct lbs = [(ct, return $ lbsContent lbs)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps +htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m] htmlResponse = genResponse "text/html" --- | Return a response from an Object. -objectResponse :: (Monad m, ToObject o Raw Raw) => o -> m Reps -objectResponse o = return $ reps $ (toObject o :: RawObject) +-- | Return a response from an Object. FIXME use TextObject +objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m] +objectResponse = reps . toRawObject -- HasReps instances -instance HasReps () where - reps _ = [("text/plain", noTranslate "")] -instance HasReps RawObject where +instance Monad m => HasReps () m where + reps _ = [("text/plain", return $ lbsContent "")] +instance Monad m => HasReps RawObject m where -- FIXME TextObject reps o = - [ ("text/html", noTranslate $ unHtml $ safeFromObject o) - , ("application/json", noTranslate $ unJson $ safeFromObject o) - , ("text/yaml", noTranslate $ unYaml $ safeFromObject o) + [ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o) + , ("application/json", return $ lbsContent $ unJson $ safeFromObject o) + , ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o) ] -instance HasReps Reps where +{- FIXME +instance HasReps (Reps m) where reps = id +-} ----- Testing testSuite :: Test diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index fa2ad788..37e6e652 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response.AtomFeed @@ -29,9 +31,9 @@ data AtomFeed = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance HasReps AtomFeed where +instance Monad m => HasReps AtomFeed m where reps e = - [ ("application/atom+xml", noTranslate $ show e) + [ ("application/atom+xml", return $ toContent $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index f75a7601..de9d510b 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response.AtomFeed @@ -77,9 +79,9 @@ instance Show SitemapResponse where showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s -instance HasReps SitemapResponse where +instance Monad m => HasReps SitemapResponse m where reps res = - [ ("text/xml", noTranslate $ show res) + [ ("text/xml", return $ toContent $ show res) ] sitemap :: IO [SitemapUrl] -> Handler @@ -93,4 +95,4 @@ sitemap urls' = do robots :: Handler robots = do ar <- approot - genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" + return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" diff --git a/restful.cabal b/restful.cabal index c7f65171..b7cfd4d9 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.9 +version: 0.1.10 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,7 +22,7 @@ library hack-handler-cgi >= 0.0.2, hack >= 2009.5.19, split >= 0.1.1, - authenticate >= 0.2.0, + authenticate >= 0.2.1, data-default >= 0.2, predicates >= 0.1, bytestring >= 0.9.1.4, @@ -40,7 +40,9 @@ library directory >= 1, transformers >= 0.1.4.0, monads-fd >= 0.0.0.1, - attempt + attempt, + syb, + text >= 0.5 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, From 4262ffb38f0eed4393606ac06057def9c9a391bc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 15 Nov 2009 01:30:45 +0200 Subject: [PATCH 048/624] Completely migrated from Raw to Text --- Data/Object/Instances.hs | 119 ++++++++++++++++++++----------------- Web/Restful/Application.hs | 18 +++--- Web/Restful/Handler.hs | 4 +- Web/Restful/Response.hs | 36 +++++------ restful.cabal | 5 +- 5 files changed, 98 insertions(+), 84 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 60cc6666..609ce8d0 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Data.Object.Instances @@ -16,84 +18,91 @@ module Data.Object.Instances ( Json (..) , Yaml (..) , Html (..) - , SafeFromObject (..) ) where import Data.Object -import Data.Object.Raw +import Data.Object.Text import qualified Data.ByteString.Lazy as B -import Data.ByteString.Class import Web.Encodings (encodeJson) -import Text.Yaml (encode) +import Text.Yaml (encodeText) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy (Text) +import Data.Convertible -class SafeFromObject a where - safeFromObject :: RawObject -> a - -newtype Json = Json { unJson :: B.ByteString } -instance SafeFromObject Json where - safeFromObject = Json . helper where - helper :: RawObject -> B.ByteString - helper (Scalar (Raw s)) = B.concat - [ toLazyByteString "\"" - , encodeJson $ fromLazyByteString s - , toLazyByteString "\"" +newtype Json = Json { unJson :: Text } +instance ConvertAttempt (Object Text Text) Json where + convertAttempt = return . convertSuccess +instance ConvertSuccess (Object Text Text) Json where + convertSuccess = Json . helper where + helper :: TextObject -> Text + helper (Scalar s) = LT.concat + [ LT.pack "\"" + , bsToText $ encodeJson $ convertSuccess s + , LT.pack "\"" ] - helper (Sequence s) = B.concat - [ toLazyByteString "[" - , B.intercalate (toLazyByteString ",") $ map helper s - , toLazyByteString "]" + helper (Sequence s) = LT.concat + [ LT.pack "[" + , LT.intercalate (LT.pack ",") $ map helper s + , LT.pack "]" ] - helper (Mapping m) = B.concat - [ toLazyByteString "{" - , B.intercalate (toLazyByteString ",") $ map helper2 m - , toLazyByteString "}" + helper (Mapping m) = LT.concat + [ LT.pack "{" + , LT.intercalate (LT.pack ",") $ map helper2 m + , LT.pack "}" ] - helper2 :: (Raw, RawObject) -> B.ByteString - helper2 (Raw k, v) = B.concat - [ toLazyByteString "\"" - , encodeJson $ fromLazyByteString k - , toLazyByteString "\":" + helper2 :: (Text, TextObject) -> Text + helper2 (k, v) = LT.concat + [ LT.pack "\"" + , bsToText $ encodeJson $ convertSuccess k + , LT.pack "\":" , helper v ] -newtype Yaml = Yaml { unYaml :: B.ByteString } -instance SafeFromObject Yaml where - safeFromObject = Yaml . encode +bsToText :: B.ByteString -> Text +bsToText = convertSuccess + +newtype Yaml = Yaml { unYaml :: Text } +instance ConvertAttempt (Object Text Text) Yaml where + convertAttempt = return . convertSuccess +instance ConvertSuccess (Object Text Text) Yaml where + convertSuccess = Yaml . encodeText -- | Represents as an entire HTML 5 document by using the following: -- -- * A scalar is a paragraph. -- * A sequence is an unordered list. -- * A mapping is a definition list. -newtype Html = Html { unHtml :: B.ByteString } +newtype Html = Html { unHtml :: Text } -instance SafeFromObject Html where - safeFromObject o = Html $ B.concat - [ toLazyByteString "\n" -- FIXME full doc or just fragment? +instance ConvertAttempt (Object Text Text) Html where + convertAttempt = return . convertSuccess +instance ConvertSuccess (Object Text Text) Html where + convertSuccess o = Html $ LT.concat + [ LT.pack "\n" -- FIXME full doc or just fragment? , helper o - , toLazyByteString "" + , LT.pack "" ] where - helper :: RawObject -> B.ByteString - helper (Scalar (Raw s)) = B.concat - [ toLazyByteString "

          " - , toLazyByteString s - , toLazyByteString "

          " + helper :: TextObject -> Text + helper (Scalar s) = LT.concat + [ LT.pack "

          " + , s + , LT.pack "

          " ] - helper (Sequence []) = toLazyByteString "
            " - helper (Sequence s) = B.concat - [ toLazyByteString "
            • " - , B.intercalate (toLazyByteString "
            • ") $ map helper s - , toLazyByteString "
            " + helper (Sequence []) = LT.pack "
              " + helper (Sequence s) = LT.concat + [ LT.pack "
              • " + , LT.intercalate (LT.pack "
              • ") $ map helper s + , LT.pack "
              " ] - helper (Mapping m) = B.concat $ - toLazyByteString "
              " : + helper (Mapping m) = LT.concat $ + LT.pack "
              " : map helper2 m ++ - [ toLazyByteString "
              " ] - helper2 :: (Raw, RawObject) -> B.ByteString - helper2 (Raw k, v) = B.concat - [ toLazyByteString "
              " - , toLazyByteString k - , toLazyByteString "
              " + [ LT.pack "
              " ] + helper2 :: (Text, TextObject) -> Text + helper2 (k, v) = LT.concat + [ LT.pack "
              " + , k + , LT.pack "
              " , helper v - , toLazyByteString "
              " + , LT.pack "" ] diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index d5c01581..3f1b8a2b 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,9 +23,11 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.Object.Raw +import Data.Object +import Data.Object.Text import Data.Enumerable import Control.Monad (when) +import qualified Data.Text.Lazy as LT import qualified Hack import Hack.Middleware.CleanPath @@ -59,18 +61,18 @@ class ResourceName a => RestfulApp a where -- | Output error response pages. errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? - errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr + errorHandler _ rr NotFound = reps $ toTextObject $ "Not found: " ++ show rr errorHandler _ _ (Redirect url) = - reps $ toRawObject $ "Redirect to: " ++ url + reps $ toTextObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = - reps $ toRawObject $ "Internal server error: " ++ e + reps $ toTextObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - reps $ toRawObject - [ ("errorMsg", toRawObject "Invalid arguments") - , ("messages", toRawObject ia) + reps $ Mapping + [ (LT.pack "errorMsg", toTextObject "Invalid arguments") + , (LT.pack "messages", toTextObject ia) ] errorHandler _ _ PermissionDenied = - reps $ toRawObject "Permission denied" + reps $ toTextObject "Permission denied" -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 4494384b..8b06eebd 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -88,7 +88,9 @@ runHandler h rr cts = do where takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) takeAllExceptions ioa = - Control.Exception.catch ioa (return . Failure) + Control.Exception.catch ioa (return . someFailure) + someFailure :: Control.Exception.SomeException -> Attempt v + someFailure = Failure toErrorResult :: Exception e => e -> ErrorResult toErrorResult e = case cast e of diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index cd768bf9..7f822d09 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -27,7 +27,6 @@ module Web.Restful.Response , Content , ToContent (..) , runContent - , lbsContent , translateContent -- * Abnormal responses , ErrorResult (..) @@ -46,11 +45,10 @@ module Web.Restful.Response import Data.Time.Clock import Data.Object -import Data.Object.Raw +import Data.Object.Text import Data.Object.Translate import Data.Object.Instances import qualified Data.ByteString.Lazy as LBS -import Data.ByteString.Class import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LTE @@ -61,6 +59,9 @@ import Test.Framework (testGroup, Test) import Data.Generics import Control.Exception (Exception) import Data.Maybe (fromJust) +import Data.Convertible + +import Data.Text.Lazy (Text) data Response = Response Int [Header] ContentType Content @@ -81,14 +82,13 @@ instance ToContent LBS.ByteString where toContent = ByteString instance ToContent String where toContent = Text . LT.pack +instance ToContent Text where + toContent = Text instance ToContent ([Language] -> String) where toContent f = TransText $ LT.pack . f instance ToContent Translator where toContent = TransText -lbsContent :: LazyByteString lbs => lbs -> Content -lbsContent = ByteString . toLazyByteString - translateContent :: CanTranslate t => t -> Content translateContent t = toContent $ translate t @@ -159,28 +159,28 @@ toPair (Header key value) = return (key, value) ------ Generic responses -- FIXME move these to Handler? -- | Return a response with an arbitrary content type. -genResponse :: (Monad m, LazyByteString lbs) +genResponse :: (Monad m, ConvertSuccess t Text) => ContentType - -> lbs + -> t -> [RepT m] -genResponse ct lbs = [(ct, return $ lbsContent lbs)] +genResponse ct t = [(ct, return $ Text $ convertSuccess t)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m] +htmlResponse :: (Monad m, ConvertSuccess t Text) => t -> [RepT m] htmlResponse = genResponse "text/html" --- | Return a response from an Object. FIXME use TextObject -objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m] -objectResponse = reps . toRawObject +-- | Return a response from an Object. +objectResponse :: (Monad m, ToObject o Text Text) => o -> [RepT m] +objectResponse = reps . toTextObject -- HasReps instances instance Monad m => HasReps () m where - reps _ = [("text/plain", return $ lbsContent "")] -instance Monad m => HasReps RawObject m where -- FIXME TextObject + reps _ = [("text/plain", return $ toContent "")] +instance Monad m => HasReps TextObject m where reps o = - [ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o) - , ("application/json", return $ lbsContent $ unJson $ safeFromObject o) - , ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o) + [ ("text/html", return $ toContent $ unHtml $ convertSuccess o) + , ("application/json", return $ toContent $ unJson $ convertSuccess o) + , ("text/yaml", return $ toContent $ unYaml $ convertSuccess o) ] {- FIXME diff --git a/restful.cabal b/restful.cabal index b7cfd4d9..12cfd6bb 100644 --- a/restful.cabal +++ b/restful.cabal @@ -40,9 +40,10 @@ library directory >= 1, transformers >= 0.1.4.0, monads-fd >= 0.0.0.1, - attempt, + attempt >= 0.0.2, syb, - text >= 0.5 + text >= 0.5, + convertible >= 1.2.0 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, From 3a7c8037440fffd24e9bb3ec992a0294169e4328 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 17 Nov 2009 01:57:43 +0200 Subject: [PATCH 049/624] Most recent attempt etc changes --- Web/Restful/Application.hs | 12 ++++++------ Web/Restful/Handler.hs | 4 ++-- Web/Restful/Helpers/Auth.hs | 14 +++++++------- Web/Restful/Helpers/Static.hs | 2 +- Web/Restful/Response.hs | 3 +++ 5 files changed, 19 insertions(+), 16 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 3f1b8a2b..b1cb0cac 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,11 +23,10 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.Object import Data.Object.Text +import Data.Object.String import Data.Enumerable import Control.Monad (when) -import qualified Data.Text.Lazy as LT import qualified Hack import Hack.Middleware.CleanPath @@ -61,15 +60,16 @@ class ResourceName a => RestfulApp a where -- | Output error response pages. errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? - errorHandler _ rr NotFound = reps $ toTextObject $ "Not found: " ++ show rr + errorHandler _ rr NotFound = reps $ toTextObject $ + "Not found: " ++ show rr errorHandler _ _ (Redirect url) = reps $ toTextObject $ "Redirect to: " ++ url errorHandler _ _ (InternalError e) = reps $ toTextObject $ "Internal server error: " ++ e errorHandler _ _ (InvalidArgs ia) = - reps $ Mapping - [ (LT.pack "errorMsg", toTextObject "Invalid arguments") - , (LT.pack "messages", toTextObject ia) + reps $ toTextObject $ toStringObject + [ ("errorMsg", toStringObject "Invalid arguments") + , ("messages", toStringObject ia) ] errorHandler _ _ PermissionDenied = reps $ toTextObject "Permission denied" diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 8b06eebd..5d8b2feb 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -89,8 +89,8 @@ runHandler h rr cts = do takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) takeAllExceptions ioa = Control.Exception.catch ioa (return . someFailure) - someFailure :: Control.Exception.SomeException -> Attempt v - someFailure = Failure + someFailure :: Control.Exception.SomeException -> Attempt v -- FIXME + someFailure = failure toErrorResult :: Exception e => e -> ErrorResult toErrorResult e = case cast e of diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index accbb097..dc372c76 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -107,23 +107,23 @@ authOpenidForward = do show (Hack.serverPort env) ++ "/auth/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete - case res of - Failure err -> redirect $ "/auth/openid/?message=" - ++ encodeUrl (show err) - Success url -> redirect url + attempt + (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err)) + redirect + res authOpenidComplete :: Handler authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' - case res of - Failure err -> redirect $ "/auth/openid/?message=" + let onFailure err = redirect $ "/auth/openid/?message=" ++ encodeUrl (show err) - Success (OpenId.Identifier ident) -> do + let onSuccess (OpenId.Identifier ident) = do deleteCookie "DEST" header authCookieName ident redirect $ fromMaybe "/" dest + attempt onFailure onSuccess res -- | token dest data RpxnowRequest = RpxnowRequest String (Maybe String) diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs index 7a530998..ca933044 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Web/Restful/Helpers/Static.hs @@ -46,7 +46,7 @@ getStatic fl = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return $ genResponse (mimeType $ ext fp) bs + Just bs -> return [(mimeType $ ext fp, return $ toContent bs)] mimeType :: String -> String mimeType "jpg" = "image/jpeg" diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 7f822d09..1fdc2f5a 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -48,6 +48,7 @@ import Data.Object import Data.Object.Text import Data.Object.Translate import Data.Object.Instances +import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LTE @@ -78,6 +79,8 @@ runContent ls (TransText t) = LTE.encodeUtf8 $ t ls class ToContent a where toContent :: a -> Content +instance ToContent SBS.ByteString where + toContent = ByteString . convertSuccess instance ToContent LBS.ByteString where toContent = ByteString instance ToContent String where From 244435bc5252297647ca478218869bb7cc2e9066 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 23 Nov 2009 23:33:57 +0200 Subject: [PATCH 050/624] Error handlers get headers sent along with them. This is a very ugly commit. Code needs massive cleanup. Problem was that redirects could not have headers attached, which broke authentication entirely. Required juggling the HandlerT type. --- Web/Restful/Application.hs | 6 +++--- Web/Restful/Handler.hs | 36 ++++++++++++++++++++++-------------- 2 files changed, 25 insertions(+), 17 deletions(-) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index b1cb0cac..ec69768f 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -135,14 +135,14 @@ applyErrorHandler :: (RestfulApp ra, Monad m) => ra -> RawRequest -> [ContentType] - -> ErrorResult + -> (ErrorResult, [Header]) -> m Response -applyErrorHandler ra rr cts er = do +applyErrorHandler ra rr cts (er, headers) = do let (ct, c) = chooseRep cts (errorHandler ra rr er) c' <- c return $ Response (getStatus er) - (getHeaders er) + (getHeaders er ++ headers) ct c' diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 5d8b2feb..63f1a4c7 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -47,8 +47,8 @@ import Data.Typeable ------ Handler monad type HandlerT m = ReaderT RawRequest ( - WriterT [Header] ( - AttemptT m + AttemptT ( + WriterT [Header] m ) ) type HandlerIO = HandlerT IO @@ -80,24 +80,32 @@ instance HasReps r HandlerIO => ToHandler (HandlerIO r) where runHandler :: Handler -> RawRequest -> [ContentType] - -> IO (Either ErrorResult Response) + -> IO (Either (ErrorResult, [Header]) Response) runHandler h rr cts = do - let ares = runAttemptT $ runWriterT $ runReaderT (joinHandler cts h) rr - ares' <- takeAllExceptions ares - return $ attempt (Left . toErrorResult) (Right . toResponse) ares' + --let (ares, _FIXMEheaders) = + let x :: IO (Attempt (ContentType, Content), [Header]) + x = + runWriterT $ runAttemptT $ runReaderT (joinHandler cts h) rr + y :: IO (Attempt (Attempt (ContentType, Content), [Header])) + y = takeAllExceptions x + z <- y + let z' :: Attempt (Attempt (ContentType, Content), [Header]) + z' = z + a :: (Attempt (ContentType, Content), [Header]) + a = attempt (\e -> (failure e, [])) id z' + (b, headers) = a + return $ attempt (\e -> (Left (toErrorResult e, headers))) (Right . toResponse headers) b where - takeAllExceptions :: IO (Attempt x) -> IO (Attempt x) + takeAllExceptions :: MonadFailure SomeException m => IO x -> IO (m x) takeAllExceptions ioa = - Control.Exception.catch ioa (return . someFailure) - someFailure :: Control.Exception.SomeException -> Attempt v -- FIXME - someFailure = failure + Control.Exception.catch (return `fmap` ioa) (\e -> return $ failure (e :: SomeException)) toErrorResult :: Exception e => e -> ErrorResult toErrorResult e = case cast e of Just x -> x Nothing -> InternalError $ show e - toResponse :: ((ContentType, Content), [Header]) -> Response - toResponse ((ct, c), hs) = Response 200 hs ct c + toResponse :: [Header] -> (ContentType, Content) -> Response + toResponse hs (ct, c) = Response 200 hs ct c joinHandler :: Monad m => [ContentType] @@ -136,7 +144,7 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do ------ Special handlers errorResult :: ErrorResult -> HandlerIO a -errorResult = lift . lift . failure -- FIXME more instances in Attempt? +errorResult = lift . failure -- FIXME more instances in Attempt? -- | Redirect to the given URL. redirect :: String -> HandlerIO a @@ -164,4 +172,4 @@ header :: Monad m => String -> String -> HandlerT m () header a = addHeader . Header a addHeader :: Monad m => Header -> HandlerT m () -addHeader = tell . return +addHeader = lift . lift . tell . return From decdd8c9e2f0e5c35febecae0c8f0877d48504cc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 28 Nov 2009 19:36:04 +0200 Subject: [PATCH 051/624] Build tests only with flag --- Test.hs | 1 + Web/Restful.hs | 4 ++-- Web/Restful/Resource.hs | 16 +++++++++++++--- Web/Restful/Response.hs | 7 +++++++ Web/Restful/Utils.hs | 7 +++++++ restful.cabal | 27 ++++++++++++++++++++++----- 6 files changed, 52 insertions(+), 10 deletions(-) diff --git a/Test.hs b/Test.hs index 3ca5e328..6fdb084b 100644 --- a/Test.hs +++ b/Test.hs @@ -4,6 +4,7 @@ import qualified Web.Restful.Response import qualified Web.Restful.Utils import qualified Web.Restful.Resource +main :: IO () main = defaultMain [ Web.Restful.Response.testSuite , Web.Restful.Utils.testSuite diff --git a/Web/Restful.hs b/Web/Restful.hs index 1f591eb4..47ac2fbc 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -24,8 +24,8 @@ module Web.Restful import Data.Object import Web.Restful.Request -import Web.Restful.Response hiding (testSuite) +import Web.Restful.Response import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler -import Web.Restful.Resource hiding (testSuite) +import Web.Restful.Resource diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 3bffbffb..24602673 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------- -- -- Module : Web.Restful.Resource @@ -21,8 +23,10 @@ module Web.Restful.Resource , checkPattern , validatePatterns , checkResourceName +#if TEST -- * Testing , testSuite +#endif ) where import Data.List.Split (splitOn) @@ -30,14 +34,16 @@ import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) import Data.Enumerable -import Control.Monad (replicateM, when) import Data.Char (isDigit) +#if TEST +import Control.Monad (replicateM, when) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck +#endif data ResourcePatternPiece = Static String @@ -57,7 +63,7 @@ isSlurp (Slurp _) = True isSlurp _ = False newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } - deriving (Eq, Arbitrary) + deriving Eq fromString :: String -> ResourcePattern fromString = ResourcePattern @@ -74,7 +80,7 @@ class (Show a, Enumerable a) => ResourceName a where -- Something like /foo/$bar/baz/ will match the regular expression -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. -- - -- Also, /foo/*bar/ will match /foo/[anything else], capturing the value + -- Also, /foo/\*bar/ will match /foo/, capturing the value -- into the bar urlParam. resourcePattern :: a -> String @@ -152,6 +158,7 @@ validatePatterns (x:xs) = -> [(ResourcePattern, ResourcePattern)] validatePatterns' a b = [(a, b) | overlaps (unRP a) (unRP b)] +#if TEST ---- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Resource" @@ -163,6 +170,8 @@ testSuite = testGroup "Web.Restful.Resource" , testCase "integers" caseIntegers ] +deriving instance Arbitrary ResourcePattern + caseOverlap1 :: Assertion caseOverlap1 = assert $ not $ overlaps (unRP $ fromString "/foo/$bar/") @@ -219,3 +228,4 @@ instance Arbitrary ResourcePatternPiece where s <- replicateM size $ elements ['a'..'z'] return $ constr s coarbitrary = undefined +#endif diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 1fdc2f5a..11a0c3b6 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -39,8 +40,10 @@ module Web.Restful.Response , genResponse , htmlResponse , objectResponse +#if TEST -- * Tests , testSuite +#endif ) where import Data.Time.Clock @@ -55,7 +58,9 @@ import qualified Data.Text.Lazy.Encoding as LTE import Web.Encodings (formatW3) +#if TEST import Test.Framework (testGroup, Test) +#endif import Data.Generics import Control.Exception (Exception) @@ -191,8 +196,10 @@ instance HasReps (Reps m) where reps = id -} +#if TEST ----- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Response" [ ] +#endif diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index e4a43309..aec16186 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Web.Restful.Utils @@ -15,15 +16,19 @@ module Web.Restful.Utils ( parseHttpAccept , tryLookup +#if TEST , testSuite +#endif ) where import Data.List.Split (splitOneOf) import Data.Maybe (fromMaybe) +#if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) +#endif -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: String -> [String] @@ -38,6 +43,7 @@ specialHttpAccept _ = False tryLookup :: Eq k => v -> k -> [(k, v)] -> v tryLookup def key = fromMaybe def . lookup key +#if TEST ----- Testing testSuite :: Test testSuite = testGroup "Web.Restful.Response" @@ -50,3 +56,4 @@ caseTryLookup1 = tryLookup "default" "foo" [] @?= "default" caseTryLookup2 :: Assertion caseTryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" +#endif diff --git a/restful.cabal b/restful.cabal index 12cfd6bb..1ba034ab 100644 --- a/restful.cabal +++ b/restful.cabal @@ -11,7 +11,15 @@ cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/restful/tree/master +flag buildtests + description: Build the executable to run unit tests + default: False + library + if flag(buildtests) + Buildable: False + else + Buildable: True build-depends: base >= 4 && < 5, old-locale >= 1.0.0.1, time >= 1.1.3, @@ -31,11 +39,6 @@ library data-object >= 0.2.0, data-object-translate, yaml >= 0.2.0, - test-framework, - test-framework-quickcheck, - test-framework-hunit, - HUnit, - QuickCheck == 1.*, enumerable >= 0.0.3, directory >= 1, transformers >= 0.1.4.0, @@ -60,3 +63,17 @@ library Web.Restful.Response.AtomFeed, Web.Restful.Response.Sitemap ghc-options: -Wall -Werror + +executable runtests + if flag(buildtests) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck == 1.* + else + Buildable: False + ghc-options: -Wall + main-is: Test.hs From 0a0e7e8f8ac990b64d1d461956c9563268b7d354 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 29 Nov 2009 01:01:21 +0200 Subject: [PATCH 052/624] Content is now strict to fix memory bug --- .gitignore | 2 -- Web/Restful.hs | 2 ++ Web/Restful/Response.hs | 33 +++++++++++++++++---------------- restful.cabal | 2 +- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/.gitignore b/.gitignore index 678893b5..39b806f8 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,2 @@ dist *.swp -*.hi -*.o diff --git a/Web/Restful.hs b/Web/Restful.hs index 47ac2fbc..940e1c27 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -20,6 +20,7 @@ module Web.Restful , module Web.Restful.Definitions , module Web.Restful.Handler , module Web.Restful.Resource + , Application ) where import Data.Object @@ -29,3 +30,4 @@ import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler import Web.Restful.Resource +import Hack (Application) diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 11a0c3b6..ecbd3c02 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -53,8 +53,8 @@ import Data.Object.Translate import Data.Object.Instances import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as ST import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LTE import Web.Encodings (formatW3) @@ -73,29 +73,30 @@ data Response = Response Int [Header] ContentType Content type ContentType = String -data Content = ByteString LBS.ByteString - | Text LT.Text - | TransText ([Language] -> LT.Text) +-- | FIXME: Lazy in theory is better, but kills actual programs +data Content = ByteString SBS.ByteString + | Text ST.Text + | TransText ([Language] -> ST.Text) runContent :: [Language] -> Content -> LBS.ByteString -runContent _ (ByteString lbs) = lbs -runContent _ (Text lt) = LTE.encodeUtf8 lt -runContent ls (TransText t) = LTE.encodeUtf8 $ t ls +runContent _ (ByteString sbs) = convertSuccess sbs +runContent _ (Text lt) = convertSuccess lt +runContent ls (TransText t) = convertSuccess $ t ls class ToContent a where toContent :: a -> Content instance ToContent SBS.ByteString where - toContent = ByteString . convertSuccess -instance ToContent LBS.ByteString where toContent = ByteString +instance ToContent LBS.ByteString where + toContent = ByteString . convertSuccess instance ToContent String where - toContent = Text . LT.pack + toContent = Text . convertSuccess instance ToContent Text where - toContent = Text + toContent = Text . convertSuccess instance ToContent ([Language] -> String) where - toContent f = TransText $ LT.pack . f + toContent f = TransText $ convertSuccess . f instance ToContent Translator where - toContent = TransText + toContent f = TransText $ convertSuccess . f translateContent :: CanTranslate t => t -> Content translateContent t = toContent $ translate t @@ -167,14 +168,14 @@ toPair (Header key value) = return (key, value) ------ Generic responses -- FIXME move these to Handler? -- | Return a response with an arbitrary content type. -genResponse :: (Monad m, ConvertSuccess t Text) +genResponse :: (Monad m, ToContent t) => ContentType -> t -> [RepT m] -genResponse ct t = [(ct, return $ Text $ convertSuccess t)] +genResponse ct t = [(ct, return $ toContent t)] -- | Return a response with a text/html content type. -htmlResponse :: (Monad m, ConvertSuccess t Text) => t -> [RepT m] +htmlResponse :: (Monad m, ToContent t) => t -> [RepT m] htmlResponse = genResponse "text/html" -- | Return a response from an Object. diff --git a/restful.cabal b/restful.cabal index 1ba034ab..a248a91b 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.10 +version: 0.1.11 license: BSD3 license-file: LICENSE author: Michael Snoyman From 9483f6037eaeaabb6948c1391d988c26256d7791 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 5 Dec 2009 22:09:48 +0200 Subject: [PATCH 053/624] Integrated some external packages; web-encodings 0.2.0 --- Data/Object/Translate.hs | 95 ++++++++++++++ Hack/Middleware/CleanPath.hs | 61 +++++++++ Hack/Middleware/ClientSession.hs | 118 ++++++++++++++++++ Hack/Middleware/Gzip.hs | 44 +++++++ Hack/Middleware/Jsonp.hs | 66 ++++++++++ Web/Restful/Application.hs | 11 +- Web/Restful/{Response => Helpers}/AtomFeed.hs | 2 +- Web/Restful/{Response => Helpers}/Sitemap.hs | 2 +- Web/Restful/Request.hs | 3 +- restful.cabal | 54 ++++---- 10 files changed, 425 insertions(+), 31 deletions(-) create mode 100644 Data/Object/Translate.hs create mode 100644 Hack/Middleware/CleanPath.hs create mode 100644 Hack/Middleware/ClientSession.hs create mode 100644 Hack/Middleware/Gzip.hs create mode 100644 Hack/Middleware/Jsonp.hs rename Web/Restful/{Response => Helpers}/AtomFeed.hs (98%) rename Web/Restful/{Response => Helpers}/Sitemap.hs (98%) diff --git a/Data/Object/Translate.hs b/Data/Object/Translate.hs new file mode 100644 index 00000000..70af27dc --- /dev/null +++ b/Data/Object/Translate.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.Translate +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Objects which can be translated into different languages. +--------------------------------------------------------- +module Data.Object.Translate + ( -- * Types + Language + , TranslatedString + , Translator + , TranslateObject + , TranslateKeyObject + -- * Type classes + , CanTranslate (..) + -- * Utilities for objects + , translateObject + , translateKeyObject + -- * Specialized functions + , toTranslateObject + , fromTranslateObject + ) where + +import Data.Maybe (fromMaybe) +import Data.Object +import Data.Attempt +import Data.Object.Text + +-- | Should usually be the well established I18N translation code. Examples +-- include en, en_US, es, and so on. If you use these common codes, you will +-- have easy interop with other systems. +type Language = String +type TranslatedString = Text + +-- | Given a list of destination languages (ordered by preference), generate +-- a translated string. Must return some value. +type Translator = [Language] -> TranslatedString + +-- | Usually you do not need to translate both keys and values, so this should +-- be the more common type. +type TranslateObject = Object Text Translator + +-- | For the occassions when you really need to translate everything. +type TranslateKeyObject = Object Translator Translator + +-- | Anything which can be translated into a different language. +-- +-- Minimal complete definition: translate or (tryTranslate and +-- defaultTranslate). +class CanTranslate a where + translate :: a -> Translator + translate a [] = defaultTranslate a + translate a (lang:langs) = + fromMaybe (translate a langs) $ tryTranslate a lang + + tryTranslate :: a -> Language -> Maybe TranslatedString + tryTranslate a = Just . translate a . return + + defaultTranslate :: a -> TranslatedString + defaultTranslate a = translate a [] + +instance CanTranslate Text where + translate = const + +-- | Generate a 'TextObject' with the translation of the +-- original based on the language list supplied. +translateObject :: [Language] + -> TranslateObject + -> TextObject +translateObject langs = fmap ($ langs) + +-- | Same as 'translateObject', but translate the keys as well as the values. +translateKeyObject :: [Language] + -> TranslateKeyObject + -> TextObject +translateKeyObject langs = mapKeysValues ($ langs) ($ langs) + +-- | 'toObject' specialized for 'TranslateObject's +toTranslateObject :: ToObject a TranslatedString Translator + => a -> TranslateObject +toTranslateObject = toObject + +-- | 'fromObject' specialized for 'TranslateObject's +fromTranslateObject :: FromObject a TranslatedString Translator + => TranslateObject + -> Attempt a +fromTranslateObject = fromObject diff --git a/Hack/Middleware/CleanPath.hs b/Hack/Middleware/CleanPath.hs new file mode 100644 index 00000000..71c6973e --- /dev/null +++ b/Hack/Middleware/CleanPath.hs @@ -0,0 +1,61 @@ +module Hack.Middleware.CleanPath (cleanPath, splitPath) where + +import Hack +import qualified Data.ByteString.Lazy as BS +import Data.List +import Web.Encodings +import Data.List.Split + +-- | Performs redirects as per 'splitPath'. +cleanPath :: Middleware +cleanPath app env = + case splitPath $ pathInfo env of + Left p -> do + -- include the query string if there + let suffix = + case queryString env of + "" -> "" + q@('?':_) -> q + q -> '?' : q + return $! Response 303 [("Location", p ++ suffix)] BS.empty + Right _ -> app env + +-- | Given a certain requested path, return either a corrected path +-- to redirect to or the tokenized path. +-- +-- This code corrects for the following issues: +-- +-- * It is missing a trailing slash, and there is no period after the +-- last slash. +-- +-- * There are any doubled slashes. +splitPath :: String -> Either String [String] +splitPath s = + let corrected = ats $ rds s + in if corrected == s + then Right $ map decodeUrl $ filter (\l -> length l /= 0) + $ splitOneOf "/" s + else Left corrected + +-- | Remove double slashes +rds :: String -> String +rds [] = [] +rds [x] = [x] +rds (a:b:c) + | a == '/' && b == '/' = rds (b:c) + | otherwise = a : rds (b:c) + +-- | Add a trailing slash if it is missing. Empty string is left alone. +ats :: String -> String +ats [] = [] +ats s = + if last s == '/' || dbs (reverse s) + then s + else s ++ "/" + +-- | Is there a period before a slash here? +dbs :: String -> Bool +dbs ('/':_) = False +dbs ('.':_) = True +dbs (_:x) = dbs x +dbs [] = False diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs new file mode 100644 index 00000000..e58a4e99 --- /dev/null +++ b/Hack/Middleware/ClientSession.hs @@ -0,0 +1,118 @@ +module Hack.Middleware.ClientSession + ( clientsession + -- * Generating keys + , Word256 + , defaultKeyFile + , getKey + , getDefaultKey + ) where + +import Prelude hiding (exp) +import Hack +import Web.Encodings +import Data.List (partition, intercalate) +import Data.Function.Predicate (is, isn't, equals) +import Data.Maybe (fromMaybe) +import Web.ClientSession +import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime) +import Data.Time.LocalTime () -- Show instance of UTCTime +import Data.Time.Format (formatTime) -- Read instance of UTCTime +import System.Locale (defaultTimeLocale) +import Control.Monad (guard) + +-- | Automatic encrypting and decrypting of client session data. +-- +-- Using the clientsession package, this middleware handles automatic +-- encryption, decryption, checking, expiration and renewal of whichever +-- cookies you ask it to. For example, if you tell it to deal with the +-- cookie \"IDENTIFIER\", it will do the following: +-- +-- * When you specify an \"IDENTIFIER\" value in your 'Response', it will +-- encrypt the value, along with the session expiration date and the +-- REMOTE_HOST of the user. It will then be set as a cookie on the client. +-- +-- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will +-- decrypt it and check both the expiration date and the REMOTE_HOST. If +-- everything matches up, it will set the \"IDENTIFIER\" value in +-- 'hackHeaders'. +-- +-- * If the client sent an \"IDENTIFIER\" and the application does not set +-- a new value, this will reset the cookie to a new expiration date. This +-- way, you do not have sessions timing out every 20 minutes. +-- +-- As far as security: clientsesion itself handles hashing and encrypting +-- the data to make sure that the user can neither see not tamper with it. +clientsession :: [String] -- ^ list of cookies to intercept + -> Word256 -- ^ encryption key + -> Middleware +clientsession cnames key app env = do + let initCookiesRaw :: String + initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env + nonCookies :: [(String, String)] + nonCookies = filter (fst `isn't` (== "Cookie")) $ http env + initCookies :: [(String, String)] + initCookies = decodeCookies initCookiesRaw + cookies, interceptCookies :: [(String, String)] + (interceptCookies, cookies) = partition (fst `is` (`elem` cnames)) + initCookies + cookiesRaw :: String + cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v) + cookies + remoteHost :: String + remoteHost = fromMaybe "" $ lookup "REMOTE_HOST" $ http env + now <- getCurrentTime + let convertedCookies = + takeJusts $ + map (decodeCookie key now remoteHost) interceptCookies + let env' = env { http = ("Cookie", cookiesRaw) + : filter (fst `equals` "Cookie") (http env) + ++ nonCookies + , hackHeaders = hackHeaders env ++ convertedCookies + } + res <- app env' + let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames)) + $ headers res + let twentyMinutes :: Int + twentyMinutes = 20 * 60 + let exp = fromIntegral twentyMinutes `addUTCTime` now + let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp + let oldCookies = filter (\(k, _) -> not $ k `elem` map fst interceptHeaders) convertedCookies + let newCookies = map (setCookie key exp formattedExp remoteHost) $ + oldCookies ++ interceptHeaders + let res' = res { headers = newCookies ++ headers' } + return res' + +takeJusts :: [Maybe a] -> [a] +takeJusts [] = [] +takeJusts (Just x:rest) = x : takeJusts rest +takeJusts (Nothing:rest) = takeJusts rest + +setCookie :: Word256 + -> UTCTime -- ^ expiration time + -> String -- ^ formatted expiration time + -> String -- ^ remote host + -> (String, String) -> (String, String) +setCookie key exp fexp rhost (cname, cval) = + ("Set-Cookie", cname ++ "=" ++ val ++ "; path=/; expires=" ++ fexp) + where + val = encrypt key $ show $ Cookie exp rhost cval + +data Cookie = Cookie UTCTime String String deriving (Show, Read) +decodeCookie :: Word256 -- ^ key + -> UTCTime -- ^ current time + -> String -- ^ remote host field + -> (String, String) -- ^ cookie pair + -> Maybe (String, String) +decodeCookie key now rhost (cname, encrypted) = do + decrypted <- decrypt key encrypted + (Cookie exp rhost' val) <- mread decrypted + guard $ exp > now + guard $ rhost' == rhost + guard $ val /= "" + return (cname, val) + +mread :: (Monad m, Read a) => String -> m a +mread s = + case reads s of + [] -> fail $ "Reading of " ++ s ++ " failed" + ((x, _):_) -> return x diff --git a/Hack/Middleware/Gzip.hs b/Hack/Middleware/Gzip.hs new file mode 100644 index 00000000..3da4d1a8 --- /dev/null +++ b/Hack/Middleware/Gzip.hs @@ -0,0 +1,44 @@ +--------------------------------------------------------- +-- | +-- Module : Hack.Middleware.Gzip +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Automatic gzip compression of responses. +-- +--------------------------------------------------------- +module Hack.Middleware.Gzip (gzip) where + +import Hack +import Codec.Compression.GZip (compress) +import Data.Maybe (fromMaybe) +import Data.List.Split (splitOneOf) + +-- | Use gzip to compress the body of the response. +-- +-- Analyzes the \"Accept-Encoding\" header from the client to determine +-- if gzip is supported. +-- +-- Possible future enhancements: +-- +-- * Only compress if the response is above a certain size. +-- +-- * Add Content-Length. +-- +-- * I read somewhere that \"the beast\" (MSIE) can\'t support compression +-- for Javascript files.. +gzip :: Middleware +gzip app env = do + res <- app env + let enc = fromMaybe [] $ splitOneOf "," `fmap` lookup "Accept-Encoding" + (http env) + if "gzip" `elem` enc + then return res + { body = compress $ body res + , headers = ("Content-Encoding", "gzip") : headers res + } + else return res diff --git a/Hack/Middleware/Jsonp.hs b/Hack/Middleware/Jsonp.hs new file mode 100644 index 00000000..bf8d8803 --- /dev/null +++ b/Hack/Middleware/Jsonp.hs @@ -0,0 +1,66 @@ +--------------------------------------------------------- +-- | +-- Module : Hack.Middleware.Jsonp +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Automatic wrapping of JSON responses to convert into JSONP. +-- +--------------------------------------------------------- +module Hack.Middleware.Jsonp (jsonp) where + +import Hack +import Web.Encodings (decodeUrlPairs) +import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.Maybe (fromMaybe) +import Data.List (isInfixOf) + +-- | Wrap json responses in a jsonp callback. +-- +-- Basically, if the user requested a \"text\/javascript\" and supplied a +-- \"callback\" GET parameter, ask the application for an +-- \"application/json\" response, then convern that into a JSONP response, +-- having a content type of \"text\/javascript\" and calling the specified +-- callback function. +jsonp :: Middleware +jsonp app env = do + let accept = fromMaybe "" $ lookup "Accept" $ http env + let gets = decodeUrlPairs $ queryString env + let callback :: Maybe String + callback = + if "text/javascript" `isInfixOf` accept + then lookup "callback" gets + else Nothing + let env' = + case callback of + Nothing -> env + Just _ -> env + { http = changeVal "Accept" + "application/json" + $ http env + } + res <- app env' + let ctype = fromMaybe "" $ lookup "Content-Type" $ headers res + case callback of + Nothing -> return res + Just c -> + case ctype of + "application/json" -> return $ res + { headers = changeVal "Content-Type" + "text/javascript" + $ headers res + , body = B8.concat + [ B8.pack c -- NOTE uses Latin-1 encoding. + , B8.singleton '(' + , body res + , B8.singleton ')' + ] + } + _ -> return res + +changeVal :: String -> String -> [(String, String)] -> [(String, String)] +changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index ec69768f..98271329 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -43,6 +43,9 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource +import Data.Convertible +import Control.Arrow ((***)) + -- | A data type that can be turned into a Hack application. class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. @@ -160,9 +163,15 @@ envToRawRequest urlParams' env = gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] clength = tryLookup "0" "Content-Length" $ Hack.http env ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = parsePost ctype clength + (posts, files) = map (convertSuccess *** convertSuccess) *** + map (convertSuccess *** convertFileInfo) + $ parsePost ctype clength $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] langs = ["en"] -- FIXME in RawRequest rawPieces urlParams' gets' posts cookies' files env langs + +convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c +convertFileInfo (FileInfo a b c) = + FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Helpers/AtomFeed.hs similarity index 98% rename from Web/Restful/Response/AtomFeed.hs rename to Web/Restful/Helpers/AtomFeed.hs index 37e6e652..727da65e 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Helpers/AtomFeed.hs @@ -14,7 +14,7 @@ -- --------------------------------------------------------- -module Web.Restful.Response.AtomFeed +module Web.Restful.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) ) where diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Helpers/Sitemap.hs similarity index 98% rename from Web/Restful/Response/Sitemap.hs rename to Web/Restful/Helpers/Sitemap.hs index de9d510b..da291897 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Helpers/Sitemap.hs @@ -14,7 +14,7 @@ -- --------------------------------------------------------- -module Web.Restful.Response.Sitemap +module Web.Restful.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index f89b103f..870d1b27 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -56,6 +56,7 @@ import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) import Data.Object.Translate (Language) +import qualified Data.ByteString.Lazy as BL -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -231,7 +232,7 @@ data RawRequest = RawRequest , rawGetParams :: [(ParamName, ParamValue)] , rawPostParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] - , rawFiles :: [(ParamName, FileInfo)] + , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawEnv :: Hack.Env , rawLanguages :: [Language] } diff --git a/restful.cabal b/restful.cabal index a248a91b..17d71cc6 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.11 +version: 0.1.12 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -21,32 +21,27 @@ library else Buildable: True build-depends: base >= 4 && < 5, - old-locale >= 1.0.0.1, - time >= 1.1.3, - hack-middleware-clientsession, - hack-middleware-jsonp >= 0.0.2, - hack-middleware-cleanpath >= 0.0.1, - hack-middleware-gzip, - hack-handler-cgi >= 0.0.2, + old-locale >= 1.0.0.1 && < 1.1, + time >= 1.1.3 && < 1.2, hack >= 2009.5.19, - split >= 0.1.1, - authenticate >= 0.2.1, - data-default >= 0.2, - predicates >= 0.1, - bytestring >= 0.9.1.4, - bytestring-class, - web-encodings >= 0.0.1, - data-object >= 0.2.0, - data-object-translate, - yaml >= 0.2.0, - enumerable >= 0.0.3, - directory >= 1, - transformers >= 0.1.4.0, - monads-fd >= 0.0.0.1, - attempt >= 0.0.2, + split >= 0.1.1 && < 0.2, + authenticate >= 0.2.1 && < 0.3, + data-default >= 0.2 && < 0.3, + predicates >= 0.1 && < 0.2, + bytestring >= 0.9.1.4 && < 0.10, + web-encodings >= 0.2.0 && < 0.3, + data-object >= 0.2.0 && < 0.3, + yaml >= 0.2.0 && < 0.3, + enumerable >= 0.0.3 && < 0.1, + directory >= 1 && < 1.1, + transformers >= 0.1.4.0 && < 0.2, + monads-fd >= 0.0.0.1 && < 0.1, + attempt >= 0.0.2 && < 0.1, syb, - text >= 0.5, - convertible >= 1.2.0 + text >= 0.5 && < 0.6, + convertible >= 1.2.0 && < 1.3, + clientsession >= 0.0.1 && < 0.1, + zlib >= 0.5.2.0 && < 0.6 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -57,11 +52,16 @@ library Web.Restful.Application, Web.Restful.Resource, Data.Object.Instances, + Data.Object.Translate, Hack.Middleware.MethodOverride, + Hack.Middleware.ClientSession, + Hack.Middleware.Jsonp, + Hack.Middleware.CleanPath, + Hack.Middleware.Gzip, Web.Restful.Helpers.Auth, Web.Restful.Helpers.Static, - Web.Restful.Response.AtomFeed, - Web.Restful.Response.Sitemap + Web.Restful.Helpers.AtomFeed, + Web.Restful.Helpers.Sitemap ghc-options: -Wall -Werror executable runtests From 5cf6a92c02982c829d108a2d06a02a7c541ca9ea Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 6 Dec 2009 00:46:59 +0200 Subject: [PATCH 054/624] convertible-text and attempt package split --- Data/Object/Instances.hs | 2 +- Data/Object/Translate.hs | 2 +- Web/Restful/Application.hs | 2 +- Web/Restful/Handler.hs | 3 ++- Web/Restful/Helpers/Auth.hs | 2 +- Web/Restful/Response.hs | 2 +- restful.cabal | 6 +++--- 7 files changed, 10 insertions(+), 9 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 609ce8d0..248e33fc 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -27,7 +27,7 @@ import Web.Encodings (encodeJson) import Text.Yaml (encodeText) import qualified Data.Text.Lazy as LT import Data.Text.Lazy (Text) -import Data.Convertible +import Data.Convertible.Text newtype Json = Json { unJson :: Text } instance ConvertAttempt (Object Text Text) Json where diff --git a/Data/Object/Translate.hs b/Data/Object/Translate.hs index 70af27dc..15bbda4c 100644 --- a/Data/Object/Translate.hs +++ b/Data/Object/Translate.hs @@ -31,7 +31,7 @@ module Data.Object.Translate import Data.Maybe (fromMaybe) import Data.Object -import Data.Attempt +import Control.Monad.Attempt import Data.Object.Text -- | Should usually be the well established I18N translation code. Examples diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 98271329..211e1b09 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -43,7 +43,7 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource -import Data.Convertible +import Data.Convertible.Text import Control.Arrow ((***)) -- | A data type that can be turned into a Hack application. diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 63f1a4c7..e87ee849 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -54,11 +54,12 @@ type HandlerT m = type HandlerIO = HandlerT IO type Handler = HandlerIO [RepT HandlerIO] +-- FIXME shouldn't call error here... instance MonadRequestReader HandlerIO where askRawRequest = ask invalidParam _pt _pn _pe = error "invalidParam" authRequired = error "authRequired" -instance Exception e => MonadFailure e HandlerIO where +instance Exception e => Failure e HandlerIO where failure = error "HandlerIO failure" class ToHandler a where diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index dc372c76..b9c31a87 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -34,7 +34,7 @@ import Control.Monad.Reader import Control.Monad.Attempt import Data.Maybe (fromMaybe) -import Data.Attempt +import Control.Monad.Attempt data AuthResource = Check diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index ecbd3c02..a8b2a579 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -65,7 +65,7 @@ import Test.Framework (testGroup, Test) import Data.Generics import Control.Exception (Exception) import Data.Maybe (fromJust) -import Data.Convertible +import Data.Convertible.Text import Data.Text.Lazy (Text) diff --git a/restful.cabal b/restful.cabal index 17d71cc6..7314886a 100644 --- a/restful.cabal +++ b/restful.cabal @@ -25,7 +25,7 @@ library time >= 1.1.3 && < 1.2, hack >= 2009.5.19, split >= 0.1.1 && < 0.2, - authenticate >= 0.2.1 && < 0.3, + authenticate >= 0.4.0 && < 0.5, data-default >= 0.2 && < 0.3, predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, @@ -36,10 +36,10 @@ library directory >= 1 && < 1.1, transformers >= 0.1.4.0 && < 0.2, monads-fd >= 0.0.0.1 && < 0.1, - attempt >= 0.0.2 && < 0.1, + control-monad-attempt >= 0.0.0 && < 0.1, syb, text >= 0.5 && < 0.6, - convertible >= 1.2.0 && < 1.3, + convertible-text >= 0.0.0 && < 0.1, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6 exposed-modules: Web.Restful, From 16b854df1a370d876be6bef499a93f5837c9b4da Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 6 Dec 2009 08:21:25 +0200 Subject: [PATCH 055/624] Pegged Hack at 2009.10.30 --- Hack/Middleware/ClientSession.hs | 8 ++++---- restful.cabal | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs index e58a4e99..76a9f8cb 100644 --- a/Hack/Middleware/ClientSession.hs +++ b/Hack/Middleware/ClientSession.hs @@ -58,12 +58,12 @@ clientsession cnames key app env = do cookiesRaw :: String cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v) cookies - remoteHost :: String - remoteHost = fromMaybe "" $ lookup "REMOTE_HOST" $ http env + remoteHost' :: String + remoteHost' = remoteHost env now <- getCurrentTime let convertedCookies = takeJusts $ - map (decodeCookie key now remoteHost) interceptCookies + map (decodeCookie key now remoteHost') interceptCookies let env' = env { http = ("Cookie", cookiesRaw) : filter (fst `equals` "Cookie") (http env) ++ nonCookies @@ -77,7 +77,7 @@ clientsession cnames key app env = do let exp = fromIntegral twentyMinutes `addUTCTime` now let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp let oldCookies = filter (\(k, _) -> not $ k `elem` map fst interceptHeaders) convertedCookies - let newCookies = map (setCookie key exp formattedExp remoteHost) $ + let newCookies = map (setCookie key exp formattedExp remoteHost') $ oldCookies ++ interceptHeaders let res' = res { headers = newCookies ++ headers' } return res' diff --git a/restful.cabal b/restful.cabal index 7314886a..f9cb8a79 100644 --- a/restful.cabal +++ b/restful.cabal @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5, old-locale >= 1.0.0.1 && < 1.1, time >= 1.1.3 && < 1.2, - hack >= 2009.5.19, + hack == 2009.10.30, split >= 0.1.1 && < 0.2, authenticate >= 0.4.0 && < 0.5, data-default >= 0.2 && < 0.3, From b4406b6a8129ff41fca52b01fb944a5cf0f4c506 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 00:04:00 +0200 Subject: [PATCH 056/624] Renamed to Yesod --- Data/Object/Instances.hs | 5 ++-- Data/Object/Translate.hs | 1 - LICENSE | 2 +- Test.hs | 12 -------- Web/Restful.hs => Yesod.hs | 28 ++++++++--------- {Web/Restful => Yesod}/Application.hs | 18 +++++------ {Web/Restful => Yesod}/Constants.hs | 4 +-- {Web/Restful => Yesod}/Definitions.hs | 4 +-- {Web/Restful => Yesod}/Handler.hs | 8 ++--- {Web/Restful => Yesod}/Helpers/AtomFeed.hs | 6 ++-- {Web/Restful => Yesod}/Helpers/Auth.hs | 8 ++--- {Web/Restful => Yesod}/Helpers/Sitemap.hs | 10 +++---- {Web/Restful => Yesod}/Helpers/Static.hs | 6 ++-- {Web/Restful => Yesod}/Request.hs | 8 ++--- {Web/Restful => Yesod}/Resource.hs | 10 +++---- {Web/Restful => Yesod}/Response.hs | 7 ++--- {Web/Restful => Yesod}/Utils.hs | 6 ++-- runtests.hs | 12 ++++++++ restful.cabal => yesod.cabal | 35 +++++++++++----------- 19 files changed, 94 insertions(+), 96 deletions(-) delete mode 100644 Test.hs rename Web/Restful.hs => Yesod.hs (51%) rename {Web/Restful => Yesod}/Application.hs (95%) rename {Web/Restful => Yesod}/Constants.hs (85%) rename {Web/Restful => Yesod}/Definitions.hs (90%) rename {Web/Restful => Yesod}/Handler.hs (97%) rename {Web/Restful => Yesod}/Helpers/AtomFeed.hs (94%) rename {Web/Restful => Yesod}/Helpers/Auth.hs (97%) rename {Web/Restful => Yesod}/Helpers/Sitemap.hs (94%) rename {Web/Restful => Yesod}/Helpers/Static.hs (94%) rename {Web/Restful => Yesod}/Request.hs (98%) rename {Web/Restful => Yesod}/Resource.hs (97%) rename {Web/Restful => Yesod}/Response.hs (97%) rename {Web/Restful => Yesod}/Utils.hs (93%) create mode 100644 runtests.hs rename restful.cabal => yesod.cabal (73%) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 248e33fc..bbda5948 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -20,11 +20,10 @@ module Data.Object.Instances , Html (..) ) where -import Data.Object import Data.Object.Text import qualified Data.ByteString.Lazy as B import Web.Encodings (encodeJson) -import Text.Yaml (encodeText) +import Text.Yaml (encodeText') import qualified Data.Text.Lazy as LT import Data.Text.Lazy (Text) import Data.Convertible.Text @@ -65,7 +64,7 @@ newtype Yaml = Yaml { unYaml :: Text } instance ConvertAttempt (Object Text Text) Yaml where convertAttempt = return . convertSuccess instance ConvertSuccess (Object Text Text) Yaml where - convertSuccess = Yaml . encodeText + convertSuccess = Yaml . convertSuccess . encodeText' -- | Represents as an entire HTML 5 document by using the following: -- diff --git a/Data/Object/Translate.hs b/Data/Object/Translate.hs index 15bbda4c..7ce8c704 100644 --- a/Data/Object/Translate.hs +++ b/Data/Object/Translate.hs @@ -30,7 +30,6 @@ module Data.Object.Translate ) where import Data.Maybe (fromMaybe) -import Data.Object import Control.Monad.Attempt import Data.Object.Text diff --git a/LICENSE b/LICENSE index 11dc17a1..81e3ec6a 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2008, Michael Snoyman. All rights reserved. +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: diff --git a/Test.hs b/Test.hs deleted file mode 100644 index 6fdb084b..00000000 --- a/Test.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Test.Framework (defaultMain) - -import qualified Web.Restful.Response -import qualified Web.Restful.Utils -import qualified Web.Restful.Resource - -main :: IO () -main = defaultMain - [ Web.Restful.Response.testSuite - , Web.Restful.Utils.testSuite - , Web.Restful.Resource.testSuite - ] diff --git a/Web/Restful.hs b/Yesod.hs similarity index 51% rename from Web/Restful.hs rename to Yesod.hs index 940e1c27..d8e46268 100644 --- a/Web/Restful.hs +++ b/Yesod.hs @@ -1,6 +1,6 @@ --------------------------------------------------------- -- --- Module : Web.Restful +-- Module : Yesod -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -11,23 +11,23 @@ -- Lightweight framework for designing RESTful APIs. -- --------------------------------------------------------- -module Web.Restful +module Yesod ( module Data.Object - , module Web.Restful.Request - , module Web.Restful.Response - , module Web.Restful.Application - , module Web.Restful.Definitions - , module Web.Restful.Handler - , module Web.Restful.Resource + , module Yesod.Request + , module Yesod.Response + , module Yesod.Application + , module Yesod.Definitions + , module Yesod.Handler + , module Yesod.Resource , Application ) where import Data.Object -import Web.Restful.Request -import Web.Restful.Response -import Web.Restful.Application -import Web.Restful.Definitions -import Web.Restful.Handler -import Web.Restful.Resource +import Yesod.Request +import Yesod.Response +import Yesod.Application +import Yesod.Definitions +import Yesod.Handler +import Yesod.Resource import Hack (Application) diff --git a/Web/Restful/Application.hs b/Yesod/Application.hs similarity index 95% rename from Web/Restful/Application.hs rename to Yesod/Application.hs index 211e1b09..ba31c79c 100644 --- a/Web/Restful/Application.hs +++ b/Yesod/Application.hs @@ -5,7 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- --- Module : Web.Restful.Application +-- Module : Yesod.Application -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -16,7 +16,7 @@ -- Defining the application. -- --------------------------------------------------------- -module Web.Restful.Application +module Yesod.Application ( toHackApp , RestfulApp (..) @@ -35,13 +35,13 @@ import Hack.Middleware.Gzip import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride -import Web.Restful.Request -import Web.Restful.Response -import Web.Restful.Utils -import Web.Restful.Handler -import Web.Restful.Definitions -import Web.Restful.Constants -import Web.Restful.Resource +import Yesod.Request +import Yesod.Response +import Yesod.Utils +import Yesod.Handler +import Yesod.Definitions +import Yesod.Constants +import Yesod.Resource import Data.Convertible.Text import Control.Arrow ((***)) diff --git a/Web/Restful/Constants.hs b/Yesod/Constants.hs similarity index 85% rename from Web/Restful/Constants.hs rename to Yesod/Constants.hs index e6445b54..09b7ad6d 100644 --- a/Web/Restful/Constants.hs +++ b/Yesod/Constants.hs @@ -1,6 +1,6 @@ --------------------------------------------------------- -- --- Module : Web.Restful.Constants +-- Module : Yesod.Constants -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -11,7 +11,7 @@ -- Constants used throughout Restful. -- --------------------------------------------------------- -module Web.Restful.Constants +module Yesod.Constants ( authCookieName ) where diff --git a/Web/Restful/Definitions.hs b/Yesod/Definitions.hs similarity index 90% rename from Web/Restful/Definitions.hs rename to Yesod/Definitions.hs index 0d21bcd8..97243d06 100644 --- a/Web/Restful/Definitions.hs +++ b/Yesod/Definitions.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- --- Module : Web.Restful.Definitions +-- Module : Yesod.Definitions -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -13,7 +13,7 @@ -- Definitions throughout Restful. -- --------------------------------------------------------- -module Web.Restful.Definitions +module Yesod.Definitions ( Verb (..) , toVerb , Resource diff --git a/Web/Restful/Handler.hs b/Yesod/Handler.hs similarity index 97% rename from Web/Restful/Handler.hs rename to Yesod/Handler.hs index e87ee849..6e199221 100644 --- a/Web/Restful/Handler.hs +++ b/Yesod/Handler.hs @@ -5,7 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- --- Module : Web.Restful.Handler +-- Module : Yesod.Handler -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -16,7 +16,7 @@ -- Define Handler stuff. -- --------------------------------------------------------- -module Web.Restful.Handler +module Yesod.Handler ( -- * Handler monad HandlerT , HandlerIO @@ -33,8 +33,8 @@ module Web.Restful.Handler , header ) where -import Web.Restful.Request -import Web.Restful.Response +import Yesod.Request +import Yesod.Response import Control.Exception hiding (Handler) diff --git a/Web/Restful/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs similarity index 94% rename from Web/Restful/Helpers/AtomFeed.hs rename to Yesod/Helpers/AtomFeed.hs index 727da65e..1690b800 100644 --- a/Web/Restful/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Web.Restful.Response.AtomFeed +-- Module : Yesod.Response.AtomFeed -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -14,12 +14,12 @@ -- --------------------------------------------------------- -module Web.Restful.Helpers.AtomFeed +module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) ) where -import Web.Restful.Response +import Yesod.Response import Data.Time.Clock import Web.Encodings diff --git a/Web/Restful/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs similarity index 97% rename from Web/Restful/Helpers/Auth.hs rename to Yesod/Helpers/Auth.hs index b9c31a87..ba533ee1 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Web.Restful.Helpers.Auth +-- Module : Yesod.Helpers.Auth -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -13,7 +13,7 @@ -- Authentication through the authentication package. -- --------------------------------------------------------- -module Web.Restful.Helpers.Auth +module Yesod.Helpers.Auth ( AuthResource , authHandler , authResourcePattern @@ -26,8 +26,8 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Data.Enumerable -import Web.Restful -import Web.Restful.Constants +import Yesod +import Yesod.Constants import Control.Applicative ((<$>), Applicative (..)) import Control.Monad.Reader diff --git a/Web/Restful/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs similarity index 94% rename from Web/Restful/Helpers/Sitemap.hs rename to Yesod/Helpers/Sitemap.hs index da291897..bf5a1340 100644 --- a/Web/Restful/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Web.Restful.Response.AtomFeed +-- Module : Yesod.Response.AtomFeed -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -14,7 +14,7 @@ -- --------------------------------------------------------- -module Web.Restful.Helpers.Sitemap +module Yesod.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) @@ -22,11 +22,11 @@ module Web.Restful.Helpers.Sitemap , SitemapChangeFreq (..) ) where -import Web.Restful.Handler -import Web.Restful.Response +import Yesod.Handler +import Yesod.Response import Web.Encodings import qualified Hack -import Web.Restful.Request +import Yesod.Request import Data.Time (UTCTime) data SitemapLoc = AbsLoc String | RelLoc String diff --git a/Web/Restful/Helpers/Static.hs b/Yesod/Helpers/Static.hs similarity index 94% rename from Web/Restful/Helpers/Static.hs rename to Yesod/Helpers/Static.hs index ca933044..4468dea7 100644 --- a/Web/Restful/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Web.Restful.Helpers.Static +-- Module : Yesod.Helpers.Static -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -13,7 +13,7 @@ -- Serve static files from a Restful app. -- --------------------------------------------------------- -module Web.Restful.Helpers.Static +module Yesod.Helpers.Static ( serveStatic , FileLookup , fileLookupDir @@ -23,7 +23,7 @@ import qualified Data.ByteString as B import System.Directory (doesFileExist) import Control.Applicative ((<$>)) -import Web.Restful +import Yesod type FileLookup = FilePath -> IO (Maybe B.ByteString) diff --git a/Web/Restful/Request.hs b/Yesod/Request.hs similarity index 98% rename from Web/Restful/Request.hs rename to Yesod/Request.hs index 870d1b27..490611b6 100644 --- a/Web/Restful/Request.hs +++ b/Yesod/Request.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverlappingInstances #-} --------------------------------------------------------- -- --- Module : Web.Restful.Request +-- Module : Yesod.Request -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -13,7 +13,7 @@ -- Code for extracting parameters from requests. -- --------------------------------------------------------- -module Web.Restful.Request +module Yesod.Request ( -- * Parameter -- $param_overview @@ -49,8 +49,8 @@ module Web.Restful.Request import qualified Hack import Data.Function.Predicate (equals) -import Web.Restful.Constants -import Web.Restful.Utils +import Yesod.Constants +import Yesod.Utils import Control.Applicative (Applicative (..)) import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) diff --git a/Web/Restful/Resource.hs b/Yesod/Resource.hs similarity index 97% rename from Web/Restful/Resource.hs rename to Yesod/Resource.hs index 24602673..04c0c746 100644 --- a/Web/Restful/Resource.hs +++ b/Yesod/Resource.hs @@ -6,7 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------- -- --- Module : Web.Restful.Resource +-- Module : Yesod.Resource -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -17,7 +17,7 @@ -- Defines the Resource class. -- --------------------------------------------------------- -module Web.Restful.Resource +module Yesod.Resource ( ResourceName (..) , fromString , checkPattern @@ -30,8 +30,8 @@ module Web.Restful.Resource ) where import Data.List.Split (splitOn) -import Web.Restful.Definitions -import Web.Restful.Handler +import Yesod.Definitions +import Yesod.Handler import Data.List (intercalate) import Data.Enumerable import Data.Char (isDigit) @@ -161,7 +161,7 @@ validatePatterns (x:xs) = #if TEST ---- Testing testSuite :: Test -testSuite = testGroup "Web.Restful.Resource" +testSuite = testGroup "Yesod.Resource" [ testCase "non-overlap" caseOverlap1 , testCase "overlap" caseOverlap2 , testCase "overlap-slurp" caseOverlap3 diff --git a/Web/Restful/Response.hs b/Yesod/Response.hs similarity index 97% rename from Web/Restful/Response.hs rename to Yesod/Response.hs index a8b2a579..4530a78a 100644 --- a/Web/Restful/Response.hs +++ b/Yesod/Response.hs @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} --------------------------------------------------------- -- --- Module : Web.Restful.Response +-- Module : Yesod.Response -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -17,7 +17,7 @@ -- Generating responses. -- --------------------------------------------------------- -module Web.Restful.Response +module Yesod.Response ( Response (..) -- * Representations , RepT @@ -47,7 +47,6 @@ module Web.Restful.Response ) where import Data.Time.Clock -import Data.Object import Data.Object.Text import Data.Object.Translate import Data.Object.Instances @@ -200,7 +199,7 @@ instance HasReps (Reps m) where #if TEST ----- Testing testSuite :: Test -testSuite = testGroup "Web.Restful.Response" +testSuite = testGroup "Yesod.Response" [ ] #endif diff --git a/Web/Restful/Utils.hs b/Yesod/Utils.hs similarity index 93% rename from Web/Restful/Utils.hs rename to Yesod/Utils.hs index aec16186..dc9cde32 100644 --- a/Web/Restful/Utils.hs +++ b/Yesod/Utils.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} --------------------------------------------------------- -- --- Module : Web.Restful.Utils +-- Module : Yesod.Utils -- Copyright : Michael Snoyman -- License : BSD3 -- @@ -13,7 +13,7 @@ -- These are all functions which could be exported to another library. -- --------------------------------------------------------- -module Web.Restful.Utils +module Yesod.Utils ( parseHttpAccept , tryLookup #if TEST @@ -46,7 +46,7 @@ tryLookup def key = fromMaybe def . lookup key #if TEST ----- Testing testSuite :: Test -testSuite = testGroup "Web.Restful.Response" +testSuite = testGroup "Yesod.Response" [ testCase "tryLookup1" caseTryLookup1 , testCase "tryLookup2" caseTryLookup2 ] diff --git a/runtests.hs b/runtests.hs new file mode 100644 index 00000000..a35ea155 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,12 @@ +import Test.Framework (defaultMain) + +import qualified Yesod.Response +import qualified Yesod.Utils +import qualified Yesod.Resource + +main :: IO () +main = defaultMain + [ Yesod.Response.testSuite + , Yesod.Utils.testSuite + , Yesod.Resource.testSuite + ] diff --git a/restful.cabal b/yesod.cabal similarity index 73% rename from restful.cabal rename to yesod.cabal index f9cb8a79..c03fb3aa 100644 --- a/restful.cabal +++ b/yesod.cabal @@ -1,15 +1,16 @@ -name: restful -version: 0.1.12 +name: yesod +version: 0.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: A Restful front controller built on Hack. +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.2 build-type: Simple -homepage: http://github.com/snoyberg/restful/tree/master +homepage: http://github.com/snoyberg/yesod flag buildtests description: Build the executable to run unit tests @@ -42,15 +43,15 @@ library convertible-text >= 0.0.0 && < 0.1, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6 - exposed-modules: Web.Restful, - Web.Restful.Constants, - Web.Restful.Request, - Web.Restful.Response, - Web.Restful.Utils, - Web.Restful.Definitions, - Web.Restful.Handler, - Web.Restful.Application, - Web.Restful.Resource, + exposed-modules: Yesod, + Yesod.Constants, + Yesod.Request, + Yesod.Response, + Yesod.Utils, + Yesod.Definitions, + Yesod.Handler, + Yesod.Application, + Yesod.Resource, Data.Object.Instances, Data.Object.Translate, Hack.Middleware.MethodOverride, @@ -58,10 +59,10 @@ library Hack.Middleware.Jsonp, Hack.Middleware.CleanPath, Hack.Middleware.Gzip, - Web.Restful.Helpers.Auth, - Web.Restful.Helpers.Static, - Web.Restful.Helpers.AtomFeed, - Web.Restful.Helpers.Sitemap + Yesod.Helpers.Auth, + Yesod.Helpers.Static, + Yesod.Helpers.AtomFeed, + Yesod.Helpers.Sitemap ghc-options: -Wall -Werror executable runtests @@ -76,4 +77,4 @@ executable runtests else Buildable: False ghc-options: -Wall - main-is: Test.hs + main-is: runtests.hs From ee64c7e894f1c9b7a5dd8e518facdec0f61e9c1b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 00:12:58 +0200 Subject: [PATCH 057/624] Fixed up Setup test and TODO list --- Setup.lhs | 2 +- TODO | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/Setup.lhs b/Setup.lhs index d9014a88..1125d1d3 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -8,4 +8,4 @@ > main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) > runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return () +> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return () diff --git a/TODO b/TODO index 09661ca9..45fb01e7 100644 --- a/TODO +++ b/TODO @@ -1,3 +1 @@ HTML sitemap generation -Remove model -Authentication seems broken From 0fcfa1b9d8c8646bc2cb92d84e22398a1a8f4df7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 00:35:31 +0200 Subject: [PATCH 058/624] Minor code fixes and massive TODO update --- TODO | 16 ++++++++++++++++ Yesod.hs | 4 +--- Yesod/Constants.hs | 2 +- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Helpers/Static.hs | 5 ++++- Yesod/Request.hs | 16 ---------------- Yesod/Resource.hs | 3 ++- 8 files changed, 26 insertions(+), 24 deletions(-) diff --git a/TODO b/TODO index 45fb01e7..bb7148d8 100644 --- a/TODO +++ b/TODO @@ -1 +1,17 @@ HTML sitemap generation +Cleanup Data.Object.Translate +Remove Data.Object.Instances (Web.Types?) +Possibly unify ResourceName and RestfulApp? +Expand Yesod.Definitions? +Cleanup Parameter stuff. Own module? Interface with formlets? +Merge MonadRequestReader class with other Handler stuff +SitemapLoc: what's the point again? +Authentication via e-mail address built in. (eaut.org) +OpenID 2 stuff (for direct Google login). +Simple model information (settings files, etc) in RestfulApp +Is there a mimetype package on hackage for Yesod.Helpers.Static? +The RepT stuff is hideous. +More than one type of objectResponse? +Native support for HStringTemplate. +Automatic HTML escaping, something smart for templates vs JSON. +Handler should be a better type, do something about ToHandler. diff --git a/Yesod.hs b/Yesod.hs index d8e46268..32272254 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,8 +13,7 @@ --------------------------------------------------------- module Yesod ( - module Data.Object - , module Yesod.Request + module Yesod.Request , module Yesod.Response , module Yesod.Application , module Yesod.Definitions @@ -23,7 +22,6 @@ module Yesod , Application ) where -import Data.Object import Yesod.Request import Yesod.Response import Yesod.Application diff --git a/Yesod/Constants.hs b/Yesod/Constants.hs index 09b7ad6d..3fe16922 100644 --- a/Yesod/Constants.hs +++ b/Yesod/Constants.hs @@ -8,7 +8,7 @@ -- Stability : Stable -- Portability : portable -- --- Constants used throughout Restful. +-- Constants used throughout Yesod. -- --------------------------------------------------------- module Yesod.Constants diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 1690b800..77a35bc4 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Yesod.Response.AtomFeed +-- Module : Yesod.Helpers.AtomFeed -- Copyright : Michael Snoyman -- License : BSD3 -- diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index bf5a1340..bc1455a5 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- --- Module : Yesod.Response.AtomFeed +-- Module : Yesod.Helpers.Sitemap -- Copyright : Michael Snoyman -- License : BSD3 -- diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 4468dea7..dd3d3066 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -10,7 +10,10 @@ -- Stability : Unstable -- Portability : portable -- --- Serve static files from a Restful app. +-- 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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 490611b6..496e6dda 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -39,7 +39,6 @@ module Yesod.Request , acceptedLanguages , requestPath , parseEnv - , approot -- * Building actual request , Request (..) , Hack.RequestMethod (..) @@ -189,21 +188,6 @@ maybeIdentifier = do parseEnv :: MonadRequestReader m => m Hack.Env parseEnv = rawEnv `fmap` askRawRequest --- | The URL to the application root (ie, the URL with pathInfo /). -approot :: MonadRequestReader m => m String -approot = do - env <- parseEnv - let (scheme, defPort) = - case Hack.hackUrlScheme env of - Hack.HTTP -> ("http://", 80) - Hack.HTTPS -> ("https://", 443) - let sn = Hack.serverName env - let portSuffix = - if Hack.serverPort env == defPort - then "" - else ':' : show (Hack.serverPort env) - return $! scheme ++ sn ++ portSuffix ++ "/" - -- | Determine the ordered list of language preferences. -- -- FIXME: Future versions should account for some cookie. diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 04c0c746..05a90be7 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -14,7 +14,7 @@ -- Stability : Stable -- Portability : portable -- --- Defines the Resource class. +-- Defines the ResourceName class. -- --------------------------------------------------------- module Yesod.Resource @@ -65,6 +65,7 @@ isSlurp _ = False newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } deriving Eq +-- | FIXME not a good name for the function. Use convertible fromString :: String -> ResourcePattern fromString = ResourcePattern . map fromString' . filter (not . null) . splitOn "/" From 2eb6f2f05bd71d80c14afd6008f248c87517cc9e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 13:18:50 +0200 Subject: [PATCH 059/624] Added Approot newtype --- Yesod/Definitions.hs | 6 ++++++ Yesod/Helpers/Sitemap.hs | 6 +++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 97243d06..65a726fd 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -17,6 +17,7 @@ module Yesod.Definitions ( Verb (..) , toVerb , Resource + , Approot (..) ) where import qualified Hack @@ -31,3 +32,8 @@ toVerb Hack.POST = Post toVerb _ = Get 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. +newtype Approot = Approot { unApproot :: String } diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index bc1455a5..410cde5c 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -22,6 +22,7 @@ module Yesod.Helpers.Sitemap , SitemapChangeFreq (..) ) where +import Yesod.Definitions import Yesod.Handler import Yesod.Response import Web.Encodings @@ -92,7 +93,6 @@ sitemap urls' = do urls <- liftIO urls' return $ reps $ SitemapResponse req urls -robots :: Handler -robots = do - ar <- approot +robots :: Approot -> Handler +robots (Approot ar) = do return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" From ab65accb44bcd7d367b2e3c20fa7467eb6c88c6f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 13:19:09 +0200 Subject: [PATCH 060/624] Fixed badly named test group in Yesod.Utils --- Yesod/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Utils.hs b/Yesod/Utils.hs index dc9cde32..e8959e88 100644 --- a/Yesod/Utils.hs +++ b/Yesod/Utils.hs @@ -46,7 +46,7 @@ tryLookup def key = fromMaybe def . lookup key #if TEST ----- Testing testSuite :: Test -testSuite = testGroup "Yesod.Response" +testSuite = testGroup "Yesod.Utils" [ testCase "tryLookup1" caseTryLookup1 , testCase "tryLookup2" caseTryLookup2 ] From a70fba9426ea818d2400e7f8db6911dd7006ae99 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 11 Dec 2009 13:19:20 +0200 Subject: [PATCH 061/624] Added Data.Object.Html with main conversions. Has support for raw output, conversion to JSON, and use in HStringTemplate. --- Data/Object/Html.hs | 164 ++++++++++++++++++++++++++++++++++++++++++++ runtests.hs | 2 + yesod.cabal | 6 +- 3 files changed, 171 insertions(+), 1 deletion(-) create mode 100644 Data/Object/Html.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs new file mode 100644 index 00000000..a26c7d20 --- /dev/null +++ b/Data/Object/Html.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +-- | An 'Html' data type and associated 'HtmlObject'. 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 (..) + , HtmlObject +#if TEST + , testSuite +#endif + ) where + +import Data.Generics +import Data.Object.Text +import Data.Object.JSON +import Data.Convertible.Text +import qualified Data.Text.Lazy as TL +import Web.Encodings +import Text.StringTemplate.Classes +import qualified Data.Map as Map +import Control.Arrow (second) + +#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 Text -- ^ Already encoded HTML. + | Text 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. + deriving (Eq, Show, Typeable) + +-- | A full HTML document. +newtype HtmlDoc = HtmlDoc Text + +type HtmlObject = Object String Html + +cs :: ConvertSuccess x y => x -> y +cs = convertSuccess + +instance ConvertSuccess Html Text where + convertSuccess (Html t) = t + convertSuccess (Text t) = encodeHtml t + convertSuccess (Tag n as content) = TL.concat + [ cs "<" + , cs n + , showAttribs as + , cs ">" + , TL.concat $ map convertSuccess content + , cs "" + ] + convertSuccess (EmptyTag n as) = TL.concat + [ cs "<" + , cs n + , showAttribs as + , cs ">" + ] + +instance ConvertSuccess Html HtmlDoc where + convertSuccess h = HtmlDoc $ TL.concat + [ cs "HtmlDoc (autogenerated)" + , cs "" + , cs h + , cs "" + ] + +instance ConvertSuccess HtmlObject Html where + convertSuccess (Scalar h) = h + convertSuccess (Sequence hs) = Tag "ul" [] $ map addLi hs where + addLi h = Tag "li" [] [cs h] + convertSuccess (Mapping pairs) = + Tag "dl" [] $ concatMap addDtDd pairs where + addDtDd (k, v) = + [ Tag "dt" [] [Text $ cs k] + , Tag "dd" [] [cs v] + ] + +instance ConvertSuccess Html JsonScalar where + convertSuccess = cs . (cs :: Html -> Text) +instance ConvertSuccess HtmlObject JsonObject where + convertSuccess = mapKeysValues convertSuccess convertSuccess +instance ConvertSuccess HtmlObject Json where + convertSuccess = cs . (cs :: HtmlObject -> JsonObject) + +instance ToSElem HtmlObject where + toSElem (Scalar h) = STR $ TL.unpack $ cs h + toSElem (Sequence hs) = LI $ map toSElem hs + toSElem (Mapping pairs) = SM $ Map.fromList $ map (second toSElem) pairs + +showAttribs :: [(String, String)] -> Text +showAttribs = TL.concat . map helper where + helper :: (String, String) -> Text + helper (k, v) = TL.concat + [ cs " " + , encodeHtml $ cs k + , cs "=\"" + , encodeHtml $ cs v + , cs "\"" + ] + +#if TEST +caseHtmlToText :: Assertion +caseHtmlToText = do + let actual = Tag "div" [("id", "foo"), ("class", "bar")] + [ Html $ cs "
              Some HTML
              " + , Text $ cs "<'this should be escaped'>" + , EmptyTag "img" [("src", "baz&")] + ] + let expected = + "

              Some HTML
              " ++ + "<'this should be escaped'>" ++ + "
              " + cs actual @?= (cs expected :: Text) + +caseStringTemplate :: Assertion +caseStringTemplate = do + let content = Mapping + [ ("foo", Sequence [ Scalar $ Html $ cs "
              " + , Scalar $ Text $ cs "
              "]) + , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) + ] + let temp = newSTMP "foo:$o.foo$,bar:$o.bar$" + let expected = "foo:
              <hr>,bar:" + expected @=? toString (setAttribute "o" content temp) + +caseJson :: Assertion +caseJson = do + let content = Mapping + [ ("foo", Sequence [ Scalar $ Html $ cs "
              " + , Scalar $ Text $ cs "
              "]) + , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")]) + ] + let expected = "{\"bar\":\"\"" ++ + ",\"foo\":[\"
              \",\"<hr>\"]" ++ + "}" + Json (cs expected) @=? cs content + +testSuite :: Test +testSuite = testGroup "Data.Object.Html" + [ testCase "caseHtmlToText" caseHtmlToText + , testCase "caseStringTemplate" caseStringTemplate + , testCase "caseJson" caseJson + ] + +#endif diff --git a/runtests.hs b/runtests.hs index a35ea155..c2c41b0b 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,10 +3,12 @@ import Test.Framework (defaultMain) import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource +import qualified Data.Object.Html main :: IO () main = defaultMain [ Yesod.Response.testSuite , Yesod.Utils.testSuite , Yesod.Resource.testSuite + , Data.Object.Html.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index c03fb3aa..a3e56004 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -42,7 +42,10 @@ library text >= 0.5 && < 0.6, convertible-text >= 0.0.0 && < 0.1, clientsession >= 0.0.1 && < 0.1, - zlib >= 0.5.2.0 && < 0.6 + zlib >= 0.5.2.0 && < 0.6, + containers >= 0.2.0.1 && < 0.3, + HStringTemplate >= 0.6.2 && < 0.7, + data-object-json >= 0.0.0 && < 0.1 exposed-modules: Yesod, Yesod.Constants, Yesod.Request, @@ -52,6 +55,7 @@ library Yesod.Handler, Yesod.Application, Yesod.Resource, + Data.Object.Html, Data.Object.Instances, Data.Object.Translate, Hack.Middleware.MethodOverride, From da3953c10c1af21ef61e1a12ad3bad8ce051373d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 00:25:46 +0200 Subject: [PATCH 062/624] Beginning of new Rep file --- Data/Object/Html.hs | 27 +++++++--- Yesod/Handler.hs | 7 +++ Yesod/Rep.hs | 127 ++++++++++++++++++++++++++++++++++++++++++++ Yesod/Response.hs | 4 +- Yesod/Yesod.hs | 88 ++++++++++++++++++++++++++++++ runtests.hs | 2 + yesod.cabal | 47 ++++++++-------- 7 files changed, 272 insertions(+), 30 deletions(-) create mode 100644 Yesod/Rep.hs create mode 100644 Yesod/Yesod.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index a26c7d20..beb8e67e 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} -- | An 'Html' data type and associated 'HtmlObject'. This has useful -- conversions in web development: -- @@ -17,6 +18,9 @@ module Data.Object.Html Html (..) , HtmlDoc (..) , HtmlObject + -- * Standard 'Object' functions + , toHtmlObject + , fromHtmlObject #if TEST , testSuite #endif @@ -24,13 +28,14 @@ module Data.Object.Html import Data.Generics import Data.Object.Text -import Data.Object.JSON +import Data.Object.Json import Data.Convertible.Text import qualified Data.Text.Lazy as TL import Web.Encodings import Text.StringTemplate.Classes import qualified Data.Map as Map import Control.Arrow (second) +import Data.Attempt #if TEST import Test.Framework (testGroup, Test) @@ -48,12 +53,15 @@ data Html = deriving (Eq, Show, Typeable) -- | A full HTML document. -newtype HtmlDoc = HtmlDoc Text +newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text } type HtmlObject = Object String Html -cs :: ConvertSuccess x y => x -> y -cs = convertSuccess +toHtmlObject :: ToObject x String Html => x -> HtmlObject +toHtmlObject = toObject + +fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x +fromHtmlObject = fromObject instance ConvertSuccess Html Text where convertSuccess (Html t) = t @@ -94,11 +102,14 @@ instance ConvertSuccess HtmlObject Html where , Tag "dd" [] [cs v] ] +instance ConvertSuccess HtmlObject HtmlDoc where + convertSuccess = cs . (cs :: HtmlObject -> Html) + instance ConvertSuccess Html JsonScalar where convertSuccess = cs . (cs :: Html -> Text) instance ConvertSuccess HtmlObject JsonObject where convertSuccess = mapKeysValues convertSuccess convertSuccess -instance ConvertSuccess HtmlObject Json where +instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) instance ToSElem HtmlObject where @@ -152,7 +163,7 @@ caseJson = do let expected = "{\"bar\":\"\"" ++ ",\"foo\":[\"
              \",\"<hr>\"]" ++ "}" - Json (cs expected) @=? cs content + JsonDoc (cs expected) @=? cs content testSuite :: Test testSuite = testGroup "Data.Object.Html" @@ -162,3 +173,7 @@ testSuite = testGroup "Data.Object.Html" ] #endif + +instance ToObject Char String Html where + toObject c = Scalar $ Text $ cs [c] + listToObject = Scalar . Text . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6e199221..2d9233cc 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -19,6 +19,7 @@ module Yesod.Handler ( -- * Handler monad HandlerT + , HandlerT' -- FIXME , HandlerIO , Handler , runHandler @@ -53,6 +54,12 @@ type HandlerT m = ) type HandlerIO = HandlerT IO type Handler = HandlerIO [RepT HandlerIO] +type HandlerT' m a = + ReaderT RawRequest ( + AttemptT ( + WriterT [Header] m + ) + ) a -- FIXME shouldn't call error here... instance MonadRequestReader HandlerIO where diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs new file mode 100644 index 00000000..926825e1 --- /dev/null +++ b/Yesod/Rep.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Representations of data. A representation is basically how you display +-- information in a certain mime-type. For example, tree-style data can easily +-- be displayed as both JSON and Yaml. +-- +-- To save programmers\' fingers, the name of this module and all data types +-- and classes replaces the full word Representation with Rep. +-- +-- This concept is core to a RESTful framework. For example, if a user goes to +-- /movies/star-wars/, they'll want a HTML page describing the Star Wars movie. +-- However, if you've written an Ajax front-end, they might want than +-- information in XML or JSON format. There could also be another web service +-- that requests this information in a binary format to save on bandwidth. +-- +-- Since the vast majority of information that is dealt with in web +-- applications can be easily displayed using an 'Object', that is probably +-- your best bet on internal data format to use. If you need HTML escaping, +-- then specifically an 'HtmlObject' will be even better. +-- +-- By the way, I said above that the vast majority of information can be +-- contained in an 'Object' easily. The key word here is \"easily\"; in fact, +-- all data can be contained in an 'Object'; however, some of it requires more +-- effort. +module Yesod.Rep + ( + ContentType (..) + , Content + , Rep + , Reps + , HasReps (..) + , chooseRep + -- FIXME TemplateFile or some such... +#if TEST + , testSuite +#endif + ) where + +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import Control.Applicative + +#if TEST +import Data.Object.Html hiding (testSuite) +#else +import Data.Object.Html +#endif + +import Data.Object.Json +import Data.Convertible.Text + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif + +data ContentType = + TypeHtml + | TypeJson + | TypeOther String + deriving Eq +instance Show ContentType where + show TypeHtml = "text/html" + show TypeJson = "application/json" + show (TypeOther s) = s + +newtype Content = Content ByteString + deriving (Eq, Show) + +instance ConvertSuccess Text Content where + convertSuccess = Content . cs +instance ConvertSuccess ByteString Content where + convertSuccess = Content + +type Rep a = (ContentType, a -> Content) +type Reps a = [Rep a] + +-- | Any type which can be converted to representations. There must be at least +-- one representation for each type. +class HasReps a where + reps :: Reps a + +chooseRep :: (Applicative f, HasReps a) + => f a + -> [ContentType] + -> f (ContentType, Content) +chooseRep fa ts = + let choices = rs' ++ rs + helper2 (ct, f) = + let fbs = f `fmap` fa + in pure (\bs -> (ct, bs)) <*> fbs + in if null rs + then error "Invalid empty reps" + else helper2 (head choices) + where + rs = reps + rs' = filter (\r -> fst r `elem` ts) rs + -- for type signature stuff + _ignored = pure (undefined :: Content) `asTypeOf` + (snd (head rs) `fmap` fa) + +-- Useful instances of HasReps +instance HasReps HtmlObject where + reps = + [ (TypeHtml, cs . unHtmlDoc . cs) + , (TypeJson, cs . unJsonDoc . cs) + ] + +#if TEST +caseChooseRep :: Assertion +caseChooseRep = do + let content = "IGNOREME" + a = Just $ toHtmlObject content + htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content + jsonbs = Content . cs $ "\"" ++ content ++ "\"" + chooseRep a [TypeHtml] @?= Just (TypeHtml, htmlbs) + chooseRep a [TypeJson] @?= Just (TypeJson, jsonbs) + chooseRep a [TypeHtml, TypeJson] @?= Just (TypeHtml, htmlbs) + chooseRep a [TypeOther "foo", TypeJson] @?= Just (TypeJson, jsonbs) + +testSuite :: Test +testSuite = testGroup "Yesod.Rep" + [ testCase "caseChooseRep" caseChooseRep + ] +#endif diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 4530a78a..14b3a299 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -106,11 +106,11 @@ chooseRep :: Monad m => [ContentType] -> [RepT m] -> RepT m -chooseRep cs rs +chooseRep cs' rs | null rs = error "All reps must have at least one representation" -- FIXME | otherwise = do let availCs = map fst rs - case filter (`elem` availCs) cs of + case filter (`elem` availCs) cs' of [] -> head rs [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME _ -> error "Overlapping representations" -- FIXME just take the first? diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs new file mode 100644 index 00000000..9cecddeb --- /dev/null +++ b/Yesod/Yesod.hs @@ -0,0 +1,88 @@ +-- | The basic typeclass for a Yesod application. +module Yesod.Yesod + ( Yesod (..) + , Handler + , toHackApp + ) where + +import Yesod.Rep +import Data.Object.Html (toHtmlObject) +import Yesod.Response hiding (reps, ContentType, Content, chooseRep) +import Yesod.Request +import Yesod.Constants +--import Yesod.Definitions +--import Yesod.Resource (checkResourceName) + +import Control.Applicative +--import Control.Monad (when) + +import qualified Hack +import Hack.Middleware.CleanPath +import Hack.Middleware.ClientSession +import Hack.Middleware.Gzip +import Hack.Middleware.Jsonp +import Hack.Middleware.MethodOverride + +type Handler a v = a -> IO v -- FIXME +type HandlerMap a = [(String, [ContentType] -> Handler a Content)] + +class Yesod a where + handlers :: HandlerMap a + + -- | The encryption key to be used for encrypting client sessions. + encryptKey :: a -> IO Word256 + encryptKey _ = getKey defaultKeyFile + + -- | All of the middlewares to install. + hackMiddleware :: a -> [Hack.Middleware] + hackMiddleware _ = + [ gzip + , cleanPath + , jsonp + , methodOverride + ] + + -- | Output error response pages. + errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> MyIdentity (ContentType, Content) -- FIXME better type sig? + errorHandler = defaultErrorHandler + -- | Whether or not we should check for overlapping resource names. + checkOverlaps :: a -> Bool + checkOverlaps = const True + +newtype MyIdentity a = MyIdentity { _unMyIdentity :: a } +instance Functor MyIdentity where + fmap f (MyIdentity a) = MyIdentity $ f a +instance Applicative MyIdentity where + pure = MyIdentity + (MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a + +defaultErrorHandler :: a + -> RawRequest + -> ErrorResult + -> [ContentType] + -> MyIdentity (ContentType, Content) +defaultErrorHandler _ rr NotFound = chooseRep $ pure . toHtmlObject $ + "Not found: " ++ show rr +defaultErrorHandler _ _ (Redirect url) = + chooseRep $ pure . toHtmlObject $ "Redirect to: " ++ url +defaultErrorHandler _ _ (InternalError e) = + chooseRep $ pure . toHtmlObject $ "Internal server error: " ++ e +defaultErrorHandler _ _ (InvalidArgs ia) = + chooseRep $ pure $ toHtmlObject + [ ("errorMsg", toHtmlObject "Invalid arguments") + , ("messages", toHtmlObject ia) + ] +defaultErrorHandler _ _ PermissionDenied = + chooseRep $ pure $ toHtmlObject "Permission denied" + +toHackApp :: Yesod y => y -> Hack.Application +toHackApp a env = do + -- FIXME when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? + key <- encryptKey a + let app' = toHackApp' a + clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... + app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] + app env + +toHackApp' :: Yesod y => y -> Hack.Application +toHackApp' = undefined -- FIXME diff --git a/runtests.hs b/runtests.hs index c2c41b0b..e4a7eaca 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,6 +3,7 @@ import Test.Framework (defaultMain) import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource +import qualified Yesod.Rep import qualified Data.Object.Html main :: IO () @@ -10,5 +11,6 @@ main = defaultMain [ Yesod.Response.testSuite , Yesod.Utils.testSuite , Yesod.Resource.testSuite + , Yesod.Rep.testSuite , Data.Object.Html.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index a3e56004..6c9e3538 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -40,32 +40,35 @@ library control-monad-attempt >= 0.0.0 && < 0.1, syb, text >= 0.5 && < 0.6, - convertible-text >= 0.0.0 && < 0.1, + convertible-text >= 0.0.1 && < 0.1, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6, containers >= 0.2.0.1 && < 0.3, HStringTemplate >= 0.6.2 && < 0.7, - data-object-json >= 0.0.0 && < 0.1 - exposed-modules: Yesod, - Yesod.Constants, - Yesod.Request, - Yesod.Response, - Yesod.Utils, - Yesod.Definitions, - Yesod.Handler, - Yesod.Application, - Yesod.Resource, - Data.Object.Html, - Data.Object.Instances, - Data.Object.Translate, - Hack.Middleware.MethodOverride, - Hack.Middleware.ClientSession, - Hack.Middleware.Jsonp, - Hack.Middleware.CleanPath, - Hack.Middleware.Gzip, - Yesod.Helpers.Auth, - Yesod.Helpers.Static, - Yesod.Helpers.AtomFeed, + data-object-json >= 0.0.0 && < 0.1, + attempt >= 0.2.1 && < 0.3 + exposed-modules: Yesod + Yesod.Constants + Yesod.Rep + Yesod.Request + Yesod.Response + Yesod.Utils + Yesod.Definitions + Yesod.Handler + Yesod.Application + Yesod.Resource + Yesod.Yesod + Data.Object.Html + Data.Object.Instances + Data.Object.Translate + Hack.Middleware.MethodOverride + Hack.Middleware.ClientSession + Hack.Middleware.Jsonp + Hack.Middleware.CleanPath + Hack.Middleware.Gzip + Yesod.Helpers.Auth + Yesod.Helpers.Static + Yesod.Helpers.AtomFeed Yesod.Helpers.Sitemap ghc-options: -Wall -Werror From 00115f02d4369aadc1fe5514630eda523e0cc118 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 00:28:41 +0200 Subject: [PATCH 063/624] Removed Data.Object.Translate --- Data/Object/Translate.hs | 94 ---------------------------------------- Yesod/Definitions.hs | 3 ++ Yesod/Request.hs | 2 +- Yesod/Response.hs | 8 +--- yesod.cabal | 5 --- 5 files changed, 5 insertions(+), 107 deletions(-) delete mode 100644 Data/Object/Translate.hs diff --git a/Data/Object/Translate.hs b/Data/Object/Translate.hs deleted file mode 100644 index 7ce8c704..00000000 --- a/Data/Object/Translate.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} ---------------------------------------------------------- --- --- Module : Data.Object.Translate --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Objects which can be translated into different languages. ---------------------------------------------------------- -module Data.Object.Translate - ( -- * Types - Language - , TranslatedString - , Translator - , TranslateObject - , TranslateKeyObject - -- * Type classes - , CanTranslate (..) - -- * Utilities for objects - , translateObject - , translateKeyObject - -- * Specialized functions - , toTranslateObject - , fromTranslateObject - ) where - -import Data.Maybe (fromMaybe) -import Control.Monad.Attempt -import Data.Object.Text - --- | Should usually be the well established I18N translation code. Examples --- include en, en_US, es, and so on. If you use these common codes, you will --- have easy interop with other systems. -type Language = String -type TranslatedString = Text - --- | Given a list of destination languages (ordered by preference), generate --- a translated string. Must return some value. -type Translator = [Language] -> TranslatedString - --- | Usually you do not need to translate both keys and values, so this should --- be the more common type. -type TranslateObject = Object Text Translator - --- | For the occassions when you really need to translate everything. -type TranslateKeyObject = Object Translator Translator - --- | Anything which can be translated into a different language. --- --- Minimal complete definition: translate or (tryTranslate and --- defaultTranslate). -class CanTranslate a where - translate :: a -> Translator - translate a [] = defaultTranslate a - translate a (lang:langs) = - fromMaybe (translate a langs) $ tryTranslate a lang - - tryTranslate :: a -> Language -> Maybe TranslatedString - tryTranslate a = Just . translate a . return - - defaultTranslate :: a -> TranslatedString - defaultTranslate a = translate a [] - -instance CanTranslate Text where - translate = const - --- | Generate a 'TextObject' with the translation of the --- original based on the language list supplied. -translateObject :: [Language] - -> TranslateObject - -> TextObject -translateObject langs = fmap ($ langs) - --- | Same as 'translateObject', but translate the keys as well as the values. -translateKeyObject :: [Language] - -> TranslateKeyObject - -> TextObject -translateKeyObject langs = mapKeysValues ($ langs) ($ langs) - --- | 'toObject' specialized for 'TranslateObject's -toTranslateObject :: ToObject a TranslatedString Translator - => a -> TranslateObject -toTranslateObject = toObject - --- | 'fromObject' specialized for 'TranslateObject's -fromTranslateObject :: FromObject a TranslatedString Translator - => TranslateObject - -> Attempt a -fromTranslateObject = fromObject diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 65a726fd..e3cc3a12 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -18,6 +18,7 @@ module Yesod.Definitions , toVerb , Resource , Approot (..) + , Language ) where import qualified Hack @@ -37,3 +38,5 @@ type Resource = [String] -- programatically, but due to ambiguities in different ways of doing URL -- rewriting for (fast)cgi applications, it should be supplied by the user. newtype Approot = Approot { unApproot :: String } + +type Language = String diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 496e6dda..a25ed720 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -50,11 +50,11 @@ import qualified Hack import Data.Function.Predicate (equals) import Yesod.Constants import Yesod.Utils +import Yesod.Definitions import Control.Applicative (Applicative (..)) import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) -import Data.Object.Translate (Language) import qualified Data.ByteString.Lazy as BL -- $param_overview diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 14b3a299..753c8649 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -28,7 +28,6 @@ module Yesod.Response , Content , ToContent (..) , runContent - , translateContent -- * Abnormal responses , ErrorResult (..) , getHeaders @@ -46,9 +45,9 @@ module Yesod.Response #endif ) where +import Yesod.Definitions import Data.Time.Clock import Data.Object.Text -import Data.Object.Translate import Data.Object.Instances import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS @@ -94,11 +93,6 @@ instance ToContent Text where toContent = Text . convertSuccess instance ToContent ([Language] -> String) where toContent f = TransText $ convertSuccess . f -instance ToContent Translator where - toContent f = TransText $ convertSuccess . f - -translateContent :: CanTranslate t => t -> Content -translateContent t = toContent $ translate t type RepT m = (ContentType, m Content) diff --git a/yesod.cabal b/yesod.cabal index 6c9e3538..0c15b70a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -17,10 +17,6 @@ flag buildtests default: False library - if flag(buildtests) - Buildable: False - else - Buildable: True build-depends: base >= 4 && < 5, old-locale >= 1.0.0.1 && < 1.1, time >= 1.1.3 && < 1.2, @@ -60,7 +56,6 @@ library Yesod.Yesod Data.Object.Html Data.Object.Instances - Data.Object.Translate Hack.Middleware.MethodOverride Hack.Middleware.ClientSession Hack.Middleware.Jsonp From 002f6ef788a4ac8f536cdbbf9f60dfff8f5091ce Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 00:33:08 +0200 Subject: [PATCH 064/624] Removed Data.Object.Instances --- Data/Object/Instances.hs | 107 --------------------------------------- Yesod/Application.hs | 15 ------ Yesod/Helpers/Auth.hs | 7 +++ Yesod/Response.hs | 22 -------- yesod.cabal | 1 - 5 files changed, 7 insertions(+), 145 deletions(-) delete mode 100644 Data/Object/Instances.hs diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs deleted file mode 100644 index bbda5948..00000000 --- a/Data/Object/Instances.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Data.Object.Instances --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Instances for converting various types of data into Data.Object.Object. --- ---------------------------------------------------------- -module Data.Object.Instances - ( Json (..) - , Yaml (..) - , Html (..) - ) where - -import Data.Object.Text -import qualified Data.ByteString.Lazy as B -import Web.Encodings (encodeJson) -import Text.Yaml (encodeText') -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy (Text) -import Data.Convertible.Text - -newtype Json = Json { unJson :: Text } -instance ConvertAttempt (Object Text Text) Json where - convertAttempt = return . convertSuccess -instance ConvertSuccess (Object Text Text) Json where - convertSuccess = Json . helper where - helper :: TextObject -> Text - helper (Scalar s) = LT.concat - [ LT.pack "\"" - , bsToText $ encodeJson $ convertSuccess s - , LT.pack "\"" - ] - helper (Sequence s) = LT.concat - [ LT.pack "[" - , LT.intercalate (LT.pack ",") $ map helper s - , LT.pack "]" - ] - helper (Mapping m) = LT.concat - [ LT.pack "{" - , LT.intercalate (LT.pack ",") $ map helper2 m - , LT.pack "}" - ] - helper2 :: (Text, TextObject) -> Text - helper2 (k, v) = LT.concat - [ LT.pack "\"" - , bsToText $ encodeJson $ convertSuccess k - , LT.pack "\":" - , helper v - ] - -bsToText :: B.ByteString -> Text -bsToText = convertSuccess - -newtype Yaml = Yaml { unYaml :: Text } -instance ConvertAttempt (Object Text Text) Yaml where - convertAttempt = return . convertSuccess -instance ConvertSuccess (Object Text Text) Yaml where - convertSuccess = Yaml . convertSuccess . encodeText' - --- | Represents as an entire HTML 5 document by using the following: --- --- * A scalar is a paragraph. --- * A sequence is an unordered list. --- * A mapping is a definition list. -newtype Html = Html { unHtml :: Text } - -instance ConvertAttempt (Object Text Text) Html where - convertAttempt = return . convertSuccess -instance ConvertSuccess (Object Text Text) Html where - convertSuccess o = Html $ LT.concat - [ LT.pack "\n" -- FIXME full doc or just fragment? - , helper o - , LT.pack "" - ] where - helper :: TextObject -> Text - helper (Scalar s) = LT.concat - [ LT.pack "

              " - , s - , LT.pack "

              " - ] - helper (Sequence []) = LT.pack "
                " - helper (Sequence s) = LT.concat - [ LT.pack "
                • " - , LT.intercalate (LT.pack "
                • ") $ map helper s - , LT.pack "
                " - ] - helper (Mapping m) = LT.concat $ - LT.pack "
                " : - map helper2 m ++ - [ LT.pack "
                " ] - helper2 :: (Text, TextObject) -> Text - helper2 (k, v) = LT.concat - [ LT.pack "
                " - , k - , LT.pack "
                " - , helper v - , LT.pack "
                " - ] diff --git a/Yesod/Application.hs b/Yesod/Application.hs index ba31c79c..7a562893 100644 --- a/Yesod/Application.hs +++ b/Yesod/Application.hs @@ -23,8 +23,6 @@ module Yesod.Application ) where import Web.Encodings -import Data.Object.Text -import Data.Object.String import Data.Enumerable import Control.Monad (when) @@ -63,19 +61,6 @@ class ResourceName a => RestfulApp a where -- | Output error response pages. errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? - errorHandler _ rr NotFound = reps $ toTextObject $ - "Not found: " ++ show rr - errorHandler _ _ (Redirect url) = - reps $ toTextObject $ "Redirect to: " ++ url - errorHandler _ _ (InternalError e) = - reps $ toTextObject $ "Internal server error: " ++ e - errorHandler _ _ (InvalidArgs ia) = - reps $ toTextObject $ toStringObject - [ ("errorMsg", toStringObject "Invalid arguments") - , ("messages", toStringObject ia) - ] - errorHandler _ _ PermissionDenied = - reps $ toTextObject "Permission denied" -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index ba533ee1..47523fc5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -154,6 +154,12 @@ rpxnowLogin apiKey = do header authCookieName $ Rpxnow.identifier ident redirect dest +authCheck :: Handler +authCheck = error "authCheck" + +authLogout :: Handler +authLogout = error "authLogout" +{- FIXME authCheck :: Handler authCheck = do ident <- maybeIdentifier @@ -168,3 +174,4 @@ authLogout :: Handler authLogout = do deleteCookie authCookieName return $ objectResponse [("status", "loggedout")] +-} diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 753c8649..069f6e26 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -38,7 +38,6 @@ module Yesod.Response -- * Generic responses , genResponse , htmlResponse - , objectResponse #if TEST -- * Tests , testSuite @@ -47,8 +46,6 @@ module Yesod.Response import Yesod.Definitions import Data.Time.Clock -import Data.Object.Text -import Data.Object.Instances import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as ST @@ -171,25 +168,6 @@ genResponse ct t = [(ct, return $ toContent t)] htmlResponse :: (Monad m, ToContent t) => t -> [RepT m] htmlResponse = genResponse "text/html" --- | Return a response from an Object. -objectResponse :: (Monad m, ToObject o Text Text) => o -> [RepT m] -objectResponse = reps . toTextObject - --- HasReps instances -instance Monad m => HasReps () m where - reps _ = [("text/plain", return $ toContent "")] -instance Monad m => HasReps TextObject m where - reps o = - [ ("text/html", return $ toContent $ unHtml $ convertSuccess o) - , ("application/json", return $ toContent $ unJson $ convertSuccess o) - , ("text/yaml", return $ toContent $ unYaml $ convertSuccess o) - ] - -{- FIXME -instance HasReps (Reps m) where - reps = id --} - #if TEST ----- Testing testSuite :: Test diff --git a/yesod.cabal b/yesod.cabal index 0c15b70a..e4982fa0 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -55,7 +55,6 @@ library Yesod.Resource Yesod.Yesod Data.Object.Html - Data.Object.Instances Hack.Middleware.MethodOverride Hack.Middleware.ClientSession Hack.Middleware.Jsonp From 77dc6ed78bbb6806e69205bbe5962925caa421bb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 01:38:20 +0200 Subject: [PATCH 065/624] Completely replaced Handler type --- Data/Object/Html.hs | 3 ++ Yesod/Application.hs | 21 ++++---- Yesod/Handler.hs | 101 ++++++++++++++++++++++---------------- Yesod/Helpers/AtomFeed.hs | 9 ++-- Yesod/Helpers/Auth.hs | 32 ++++++------ Yesod/Helpers/Sitemap.hs | 19 +++---- Yesod/Helpers/Static.hs | 33 +++++++------ Yesod/Rep.hs | 71 ++++++++++++++++++++------- Yesod/Resource.hs | 8 ++- Yesod/Response.hs | 89 +++------------------------------ Yesod/Yesod.hs | 16 +++--- 11 files changed, 195 insertions(+), 207 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index beb8e67e..8c289da7 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -112,6 +112,9 @@ instance ConvertSuccess HtmlObject JsonObject where instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) +instance ToObject Html String Html where + toObject = Scalar + instance ToSElem HtmlObject where toSElem (Scalar h) = STR $ TL.unpack $ cs h toSElem (Sequence hs) = LI $ map toSElem hs diff --git a/Yesod/Application.hs b/Yesod/Application.hs index 7a562893..aa97a4f7 100644 --- a/Yesod/Application.hs +++ b/Yesod/Application.hs @@ -25,6 +25,7 @@ module Yesod.Application import Web.Encodings import Data.Enumerable import Control.Monad (when) +import Data.Object.Html import qualified Hack import Hack.Middleware.CleanPath @@ -40,6 +41,7 @@ import Yesod.Handler import Yesod.Definitions import Yesod.Constants import Yesod.Resource +import Yesod.Rep import Data.Convertible.Text import Control.Arrow ((***)) @@ -60,7 +62,7 @@ class ResourceName a => RestfulApp a where ] -- | Output error response pages. - errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig? + errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig? -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool @@ -100,12 +102,12 @@ takeJusts (Just x:rest) = x : takeJusts rest toHackApplication :: RestfulApp resourceName => resourceName - -> (resourceName -> Verb -> Handler) + -> (resourceName -> Verb -> Handler [(ContentType, Content)]) -> Hack.Application toHackApplication sampleRN hm env = do -- The following is safe since we run cleanPath as middleware let (Right resource) = splitPath $ Hack.pathInfo env - let (handler :: Handler, urlParams') = + let (handler, urlParams') = case findResourceNames resource of [] -> (notFound, []) ((rn, urlParams''):_) -> @@ -113,7 +115,7 @@ toHackApplication sampleRN hm env = do in (hm rn verb, urlParams'') let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept + ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept r <- runHandler handler rr ctypes' >>= either (applyErrorHandler sampleRN rr ctypes') return @@ -126,20 +128,19 @@ applyErrorHandler :: (RestfulApp ra, Monad m) -> (ErrorResult, [Header]) -> m Response applyErrorHandler ra rr cts (er, headers) = do - let (ct, c) = chooseRep cts (errorHandler ra rr er) - c' <- c + let (ct, c) = chooseRep (errorHandler ra rr er) cts return $ Response (getStatus er) (getHeaders er ++ headers) ct - c' + c responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response -responseToHackResponse ls (Response sc hs ct c) = do +responseToHackResponse _FIXMEls (Response sc hs ct c) = do hs' <- mapM toPair hs - let hs'' = ("Content-Type", ct) : hs' - let asLBS = runContent ls c + let hs'' = ("Content-Type", show ct) : hs' + let asLBS = unContent c return $ Hack.Response sc hs'' asLBS envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2d9233cc..ee0d456d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -18,13 +18,10 @@ --------------------------------------------------------- module Yesod.Handler ( -- * Handler monad - HandlerT - , HandlerT' -- FIXME - , HandlerIO - , Handler + Handler , runHandler , liftIO - , ToHandler (..) + --, ToHandler (..) -- * Special handlers , redirect , notFound @@ -36,54 +33,76 @@ module Yesod.Handler import Yesod.Request import Yesod.Response +import Yesod.Rep import Control.Exception hiding (Handler) +import Control.Applicative -import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Attempt -import Data.Typeable +--import Data.Typeable ------ Handler monad -type HandlerT m = - ReaderT RawRequest ( - AttemptT ( - WriterT [Header] m - ) - ) -type HandlerIO = HandlerT IO -type Handler = HandlerIO [RepT HandlerIO] -type HandlerT' m a = - ReaderT RawRequest ( - AttemptT ( - WriterT [Header] m - ) - ) a +newtype Handler a = Handler { + unHandler :: RawRequest -> IO ([Header], HandlerContents a) +} +data HandlerContents a = + forall e. Exception e => HCError e + | HCSpecial ErrorResult + | HCContent a --- FIXME shouldn't call error here... -instance MonadRequestReader HandlerIO where - askRawRequest = ask +instance Functor Handler where + fmap = liftM +instance Applicative Handler where + pure = return + (<*>) = ap +instance Monad Handler where + fail = failureString -- 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 where + liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') +instance Exception e => Failure e Handler where + failure e = Handler $ \_ -> return ([], HCError e) +instance MonadRequestReader Handler where + askRawRequest = Handler $ \rr -> return ([], HCContent rr) invalidParam _pt _pn _pe = error "invalidParam" authRequired = error "authRequired" -instance Exception e => Failure e HandlerIO where - failure = error "HandlerIO failure" +-- FIXME this is a stupid signature +runHandler :: HasReps a + => Handler a + -> RawRequest + -> [ContentType] + -> IO (Either (ErrorResult, [Header]) Response) +runHandler (Handler handler) rr cts = do + (headers, contents) <- handler rr + case contents of + HCError e -> return $ Left (InternalError $ show e, headers) + HCSpecial e -> return $ Left (e, headers) + HCContent a -> + let (ct, c) = chooseRep a cts + in return $ Right $ Response 200 headers ct c +{- FIXME class ToHandler a where toHandler :: a -> Handler -{- FIXME instance (Request r, ToHandler h) => ToHandler (r -> h) where toHandler f = parseRequest >>= toHandler . f --} instance ToHandler Handler where toHandler = id -{- FIXME instance HasReps r HandlerIO => ToHandler (HandlerIO r) where toHandler = fmap reps --} runHandler :: Handler -> RawRequest @@ -124,6 +143,7 @@ joinHandler cts rs = do let (ct, c) = chooseRep cts rs' c' <- c return (ct, c') +-} {- runHandler :: (ErrorResult -> Reps) @@ -151,33 +171,32 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do -} ------ Special handlers -errorResult :: ErrorResult -> HandlerIO a -errorResult = lift . failure -- FIXME more instances in Attempt? +errorResult :: ErrorResult -> Handler a +errorResult er = Handler $ \_ -> return ([], HCSpecial er) -- | Redirect to the given URL. -redirect :: String -> HandlerIO a +redirect :: String -> Handler a redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. -notFound :: HandlerIO a +notFound :: Handler a notFound = errorResult NotFound ------- Headers -- | Set the cookie on the client. -addCookie :: Monad m - => Int -- ^ minutes to timeout +addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value - -> HandlerT m () + -> Handler () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: Monad m => String -> HandlerT m () +deleteCookie :: String -> Handler () deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. -header :: Monad m => String -> String -> HandlerT m () +header :: String -> String -> Handler () header a = addHeader . Header a -addHeader :: Monad m => Header -> HandlerT m () -addHeader = lift . lift . tell . return +addHeader :: Header -> Handler () +addHeader h = Handler $ \_ -> return ([h], HCContent ()) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 77a35bc4..9a4ffaba 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -19,7 +19,8 @@ module Yesod.Helpers.AtomFeed , AtomFeedEntry (..) ) where -import Yesod.Response +import Yesod.Rep +import Data.Convertible.Text (cs) import Data.Time.Clock import Web.Encodings @@ -31,9 +32,9 @@ data AtomFeed = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance Monad m => HasReps AtomFeed m where - reps e = - [ ("application/atom+xml", return $ toContent $ show e) +instance HasReps AtomFeed where + reps = + [ (TypeAtom, cs . show) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 47523fc5..e722e21b 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -26,6 +26,9 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Data.Enumerable +import Data.Object.Html +import Data.Convertible.Text (cs) + import Yesod import Yesod.Constants @@ -57,7 +60,7 @@ instance Enumerable AuthResource where newtype RpxnowApiKey = RpxnowApiKey String -authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler +authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler HtmlObject authHandler _ Check Get = authCheck authHandler _ Logout Get = authLogout authHandler _ Openid Get = authOpenidForm @@ -85,7 +88,7 @@ instance Show OIDFormReq where show (OIDFormReq (Just s) _) = "

                " ++ encodeHtml s ++ "

                " -authOpenidForm :: Handler +authOpenidForm :: Handler HtmlObject authOpenidForm = do m@(OIDFormReq _ dest) <- parseRequest let html = @@ -97,9 +100,9 @@ authOpenidForm = do case dest of Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () - return $ htmlResponse html + return $ toHtmlObject $ Html $ cs html -authOpenidForward :: Handler +authOpenidForward :: Handler HtmlObject authOpenidForward = do oid <- getParam "openid" env <- parseEnv @@ -112,7 +115,7 @@ authOpenidForward = do redirect res -authOpenidComplete :: Handler +authOpenidComplete :: Handler HtmlObject authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" @@ -138,7 +141,7 @@ chopHash ('#':rest) = rest chopHash x = x rpxnowLogin :: String -- ^ api key - -> Handler + -> Handler HtmlObject rpxnowLogin apiKey = do token <- anyParam "token" postDest <- postParam "dest" @@ -154,24 +157,17 @@ rpxnowLogin apiKey = do header authCookieName $ Rpxnow.identifier ident redirect dest -authCheck :: Handler -authCheck = error "authCheck" - -authLogout :: Handler -authLogout = error "authLogout" -{- FIXME -authCheck :: Handler +authCheck :: Handler HtmlObject authCheck = do ident <- maybeIdentifier case ident of - Nothing -> return $ objectResponse [("status", "notloggedin")] - Just i -> return $ objectResponse + Nothing -> return $ toHtmlObject [("status", "notloggedin")] + Just i -> return $ toHtmlObject [ ("status", "loggedin") , ("ident", i) ] -authLogout :: Handler +authLogout :: Handler HtmlObject authLogout = do deleteCookie authCookieName - return $ objectResponse [("status", "loggedout")] --} + return $ toHtmlObject [("status", "loggedout")] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 410cde5c..16a65721 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -24,11 +24,12 @@ module Yesod.Helpers.Sitemap import Yesod.Definitions import Yesod.Handler -import Yesod.Response +import Yesod.Rep import Web.Encodings import qualified Hack import Yesod.Request import Data.Time (UTCTime) +import Data.Convertible.Text (cs) data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always @@ -55,7 +56,7 @@ data SitemapUrl = SitemapUrl } data SitemapRequest = SitemapRequest String Int data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] -instance Show SitemapResponse where +instance Show SitemapResponse where -- FIXME very ugly, use Text instead show (SitemapResponse (SitemapRequest host port) urls) = "\n" ++ "" ++ @@ -80,19 +81,19 @@ instance Show SitemapResponse where showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s -instance Monad m => HasReps SitemapResponse m where - reps res = - [ ("text/xml", return $ toContent $ show res) +instance HasReps SitemapResponse where + reps = + [ (TypeXml, cs . show) ] -sitemap :: IO [SitemapUrl] -> Handler +sitemap :: IO [SitemapUrl] -> Handler SitemapResponse sitemap urls' = do env <- parseEnv -- FIXME let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env) urls <- liftIO urls' - return $ reps $ SitemapResponse req urls + return $ SitemapResponse req urls -robots :: Approot -> Handler +robots :: Approot -> Handler Plain robots (Approot ar) = do - return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml" + return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml" diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index dd3d3066..0d198353 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -22,11 +22,12 @@ module Yesod.Helpers.Static , fileLookupDir ) where -import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as B import System.Directory (doesFileExist) import Control.Applicative ((<$>)) import Yesod +import Yesod.Rep type FileLookup = FilePath -> IO (Maybe B.ByteString) @@ -39,30 +40,30 @@ fileLookupDir dir fp = do then Just <$> B.readFile fp' else return Nothing -serveStatic :: FileLookup -> Verb -> Handler +serveStatic :: FileLookup -> Verb -> Handler [(ContentType, Content)] serveStatic fl Get = getStatic fl serveStatic _ _ = notFound -getStatic :: FileLookup -> Handler +getStatic :: FileLookup -> Handler [(ContentType, Content)] getStatic fl = do fp <- urlParam "filepath" -- FIXME check for .. content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return [(mimeType $ ext fp, return $ toContent bs)] + Just bs -> return [(mimeType $ ext fp, Content bs)] -mimeType :: String -> String -mimeType "jpg" = "image/jpeg" -mimeType "jpeg" = "image/jpeg" -mimeType "js" = "text/javascript" -mimeType "css" = "text/css" -mimeType "html" = "text/html" -mimeType "png" = "image/png" -mimeType "gif" = "image/gif" -mimeType "txt" = "text/plain" -mimeType "flv" = "video/x-flv" -mimeType "ogv" = "video/ogg" -mimeType _ = "application/octet-stream" +mimeType :: String -> ContentType +mimeType "jpg" = TypeJpeg +mimeType "jpeg" = TypeJpeg +mimeType "js" = TypeJavascript +mimeType "css" = TypeCss +mimeType "html" = TypeHtml +mimeType "png" = TypePng +mimeType "gif" = TypeGif +mimeType "txt" = TypePlain +mimeType "flv" = TypeFlv +mimeType "ogv" = TypeOgv +mimeType _ = TypeOctet ext :: String -> String ext = reverse . fst . break (== '.') . reverse diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 926825e1..1ce9a195 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} -- | Representations of data. A representation is basically how you display -- information in a certain mime-type. For example, tree-style data can easily -- be displayed as both JSON and Yaml. @@ -26,12 +28,15 @@ module Yesod.Rep ( ContentType (..) - , Content + , Content (..) , Rep , Reps , HasReps (..) , chooseRep -- FIXME TemplateFile or some such... + -- * Specific types of representations + , Plain (..) + , plain #if TEST , testSuite #endif @@ -58,21 +63,46 @@ import Test.HUnit hiding (Test) data ContentType = TypeHtml + | TypePlain | TypeJson + | TypeXml + | TypeAtom + | TypeJpeg + | TypePng + | TypeGif + | TypeJavascript + | TypeCss + | TypeFlv + | TypeOgv + | TypeOctet | TypeOther String - deriving Eq instance Show ContentType where show TypeHtml = "text/html" + show TypePlain = "text/plain" show TypeJson = "application/json" + show TypeXml = "text/xml" + show TypeAtom = "application/atom+xml" + show TypeJpeg = "image/jpeg" + show TypePng = "image/png" + show TypeGif = "image/gif" + show TypeJavascript = "text/javascript" + show TypeCss = "text/css" + show TypeFlv = "video/x-flv" + show TypeOgv = "video/ogg" + show TypeOctet = "application/octet-stream" show (TypeOther s) = s +instance Eq ContentType where + x == y = show x == show y -newtype Content = Content ByteString +newtype Content = Content { unContent :: ByteString } deriving (Eq, Show) instance ConvertSuccess Text Content where convertSuccess = Content . cs instance ConvertSuccess ByteString Content where convertSuccess = Content +instance ConvertSuccess String Content where + convertSuccess = Content . cs type Rep a = (ContentType, a -> Content) type Reps a = [Rep a] @@ -81,25 +111,32 @@ type Reps a = [Rep a] -- one representation for each type. class HasReps a where reps :: Reps a +instance HasReps [(ContentType, Content)] where + reps = [(TypeOther "FIXME", const $ Content $ cs "FIXME")] -chooseRep :: (Applicative f, HasReps a) - => f a +-- FIXME done badly, needs cleanup +chooseRep :: HasReps a + => a -> [ContentType] - -> f (ContentType, Content) -chooseRep fa ts = + -> (ContentType, Content) +chooseRep a ts = let choices = rs' ++ rs - helper2 (ct, f) = - let fbs = f `fmap` fa - in pure (\bs -> (ct, bs)) <*> fbs + helper2 (ct, f) = (ct, f a) in if null rs then error "Invalid empty reps" - else helper2 (head choices) + else helper2 $ head choices where rs = reps rs' = filter (\r -> fst r `elem` ts) rs -- for type signature stuff _ignored = pure (undefined :: Content) `asTypeOf` - (snd (head rs) `fmap` fa) + (snd (head rs) ) + +newtype Plain = Plain Text + deriving (Eq, Show) + +plain :: ConvertSuccess x Text => x -> Plain +plain = Plain . cs -- Useful instances of HasReps instance HasReps HtmlObject where @@ -112,13 +149,13 @@ instance HasReps HtmlObject where caseChooseRep :: Assertion caseChooseRep = do let content = "IGNOREME" - a = Just $ toHtmlObject content + a = toHtmlObject content htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content jsonbs = Content . cs $ "\"" ++ content ++ "\"" - chooseRep a [TypeHtml] @?= Just (TypeHtml, htmlbs) - chooseRep a [TypeJson] @?= Just (TypeJson, jsonbs) - chooseRep a [TypeHtml, TypeJson] @?= Just (TypeHtml, htmlbs) - chooseRep a [TypeOther "foo", TypeJson] @?= Just (TypeJson, jsonbs) + chooseRep a [TypeHtml] @?= (TypeHtml, htmlbs) + chooseRep a [TypeJson] @?= (TypeJson, jsonbs) + chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs) + chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs) testSuite :: Test testSuite = testGroup "Yesod.Rep" diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 05a90be7..3e29f387 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -36,6 +36,12 @@ import Data.List (intercalate) import Data.Enumerable import Data.Char (isDigit) +#if TEST +import Yesod.Rep hiding (testSuite) +#else +import Yesod.Rep +#endif + #if TEST import Control.Monad (replicateM, when) import Test.Framework (testGroup, Test) @@ -86,7 +92,7 @@ class (Show a, Enumerable a) => ResourceName a where resourcePattern :: a -> String -- | Find the handler for each resource name/verb pattern. - getHandler :: a -> Verb -> Handler + getHandler :: a -> Verb -> Handler [(ContentType, Content)] -- FIXME type SMap = [(String, String)] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 069f6e26..f4232ead 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -19,15 +19,6 @@ --------------------------------------------------------- module Yesod.Response ( Response (..) - -- * Representations - , RepT - , chooseRep - , HasReps (..) - , ContentType - -- * Content - , Content - , ToContent (..) - , runContent -- * Abnormal responses , ErrorResult (..) , getHeaders @@ -35,21 +26,19 @@ module Yesod.Response -- * Header , Header (..) , toPair - -- * Generic responses - , genResponse - , htmlResponse #if TEST -- * Tests , testSuite #endif ) where -import Yesod.Definitions +#if TEST +import Yesod.Rep hiding (testSuite) +#else +import Yesod.Rep +#endif + import Data.Time.Clock -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as ST -import qualified Data.Text.Lazy as LT import Web.Encodings (formatW3) @@ -59,62 +48,9 @@ import Test.Framework (testGroup, Test) import Data.Generics import Control.Exception (Exception) -import Data.Maybe (fromJust) -import Data.Convertible.Text - -import Data.Text.Lazy (Text) data Response = Response Int [Header] ContentType Content -type ContentType = String - --- | FIXME: Lazy in theory is better, but kills actual programs -data Content = ByteString SBS.ByteString - | Text ST.Text - | TransText ([Language] -> ST.Text) - -runContent :: [Language] -> Content -> LBS.ByteString -runContent _ (ByteString sbs) = convertSuccess sbs -runContent _ (Text lt) = convertSuccess lt -runContent ls (TransText t) = convertSuccess $ t ls - -class ToContent a where - toContent :: a -> Content -instance ToContent SBS.ByteString where - toContent = ByteString -instance ToContent LBS.ByteString where - toContent = ByteString . convertSuccess -instance ToContent String where - toContent = Text . convertSuccess -instance ToContent Text where - toContent = Text . convertSuccess -instance ToContent ([Language] -> String) where - toContent f = TransText $ convertSuccess . f - -type RepT m = (ContentType, m Content) - -chooseRep :: Monad m - => [ContentType] - -> [RepT m] - -> RepT m -chooseRep cs' rs - | null rs = error "All reps must have at least one representation" -- FIXME - | otherwise = do - let availCs = map fst rs - case filter (`elem` availCs) cs' of - [] -> head rs - [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME - _ -> error "Overlapping representations" -- FIXME just take the first? - --- | Something which can be represented as multiple content types. --- Each content type is called a representation of the data. -class Monad m => HasReps a m where - -- | Provide an ordered list of possible representations, depending on - -- content type. If the user asked for a specific response type (like - -- text/html), then that will get priority. If not, then the first - -- element in this list will be used. - reps :: a -> [RepT m] - -- | Abnormal return codes. data ErrorResult = Redirect String @@ -155,19 +91,6 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) ------- Generic responses --- FIXME move these to Handler? --- | Return a response with an arbitrary content type. -genResponse :: (Monad m, ToContent t) - => ContentType - -> t - -> [RepT m] -genResponse ct t = [(ct, return $ toContent t)] - --- | Return a response with a text/html content type. -htmlResponse :: (Monad m, ToContent t) => t -> [RepT m] -htmlResponse = genResponse "text/html" - #if TEST ----- Testing testSuite :: Test diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9cecddeb..9580d2ce 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -7,7 +7,7 @@ module Yesod.Yesod import Yesod.Rep import Data.Object.Html (toHtmlObject) -import Yesod.Response hiding (reps, ContentType, Content, chooseRep) +import Yesod.Response import Yesod.Request import Yesod.Constants --import Yesod.Definitions @@ -43,7 +43,7 @@ class Yesod a where ] -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> MyIdentity (ContentType, Content) -- FIXME better type sig? + errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> (ContentType, Content) -- FIXME better type sig? errorHandler = defaultErrorHandler -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool @@ -60,20 +60,20 @@ defaultErrorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] - -> MyIdentity (ContentType, Content) -defaultErrorHandler _ rr NotFound = chooseRep $ pure . toHtmlObject $ + -> (ContentType, Content) +defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $ "Not found: " ++ show rr defaultErrorHandler _ _ (Redirect url) = - chooseRep $ pure . toHtmlObject $ "Redirect to: " ++ url + chooseRep $ toHtmlObject $ "Redirect to: " ++ url defaultErrorHandler _ _ (InternalError e) = - chooseRep $ pure . toHtmlObject $ "Internal server error: " ++ e + chooseRep $ toHtmlObject $ "Internal server error: " ++ e defaultErrorHandler _ _ (InvalidArgs ia) = - chooseRep $ pure $ toHtmlObject + chooseRep $ toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) ] defaultErrorHandler _ _ PermissionDenied = - chooseRep $ pure $ toHtmlObject "Permission denied" + chooseRep $ toHtmlObject "Permission denied" toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do From 4650cf4e92e7008288e12fde5022fda2074c2243 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 04:05:29 +0200 Subject: [PATCH 066/624] Moved chooseRep into HasReps --- Yesod/Rep.hs | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 1ce9a195..796fd783 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -32,7 +32,6 @@ module Yesod.Rep , Rep , Reps , HasReps (..) - , chooseRep -- FIXME TemplateFile or some such... -- * Specific types of representations , Plain (..) @@ -111,15 +110,24 @@ type Reps a = [Rep a] -- one representation for each type. class HasReps a where reps :: Reps a + chooseRep :: a -> [ContentType] -> (ContentType, Content) + chooseRep = chooseRep' + instance HasReps [(ContentType, Content)] where - reps = [(TypeOther "FIXME", const $ Content $ cs "FIXME")] + reps = error "reps of [(ContentType, Content)]" + chooseRep a cts = + case filter (\(ct, _) -> ct `elem` cts) a of + ((ct, c):_) -> (ct, c) + _ -> case a of + (x:_) -> x + _ -> error "chooseRep [(ContentType, Content)] of empty" -- FIXME done badly, needs cleanup -chooseRep :: HasReps a +chooseRep' :: HasReps a => a -> [ContentType] -> (ContentType, Content) -chooseRep a ts = +chooseRep' a ts = let choices = rs' ++ rs helper2 (ct, f) = (ct, f a) in if null rs @@ -146,8 +154,8 @@ instance HasReps HtmlObject where ] #if TEST -caseChooseRep :: Assertion -caseChooseRep = do +caseChooseRepHO :: Assertion +caseChooseRepHO = do let content = "IGNOREME" a = toHtmlObject content htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content @@ -157,8 +165,20 @@ caseChooseRep = do chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs) chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs) +caseChooseRepRaw :: Assertion +caseChooseRepRaw = do + let content = Content $ cs "FOO" + foo = TypeOther "foo" + bar = TypeOther "bar" + hasreps = [(TypeHtml, content), (foo, content)] + chooseRep hasreps [TypeHtml] @?= (TypeHtml, content) + chooseRep hasreps [foo, bar] @?= (foo, content) + chooseRep hasreps [bar, foo] @?= (foo, content) + chooseRep hasreps [bar] @?= (TypeHtml, content) + testSuite :: Test testSuite = testGroup "Yesod.Rep" - [ testCase "caseChooseRep" caseChooseRep + [ testCase "caseChooseRep HtmlObject" caseChooseRepHO + , testCase "caseChooseRep raw" caseChooseRepRaw ] #endif From ac54b644bc2848e042bfa329324bf557d6f7dbf5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 13 Dec 2009 09:50:43 +0200 Subject: [PATCH 067/624] Added Yesod parameter to Handler --- Yesod/Application.hs | 4 +-- Yesod/Handler.hs | 43 ++++++++++++++++-------------- Yesod/Helpers/Auth.hs | 14 +++++----- Yesod/Helpers/Sitemap.hs | 11 +++++--- Yesod/Helpers/Static.hs | 4 +-- Yesod/Resource.hs | 5 +++- Yesod/Yesod.hs | 57 ++++++++++++++++++++-------------------- 7 files changed, 74 insertions(+), 64 deletions(-) diff --git a/Yesod/Application.hs b/Yesod/Application.hs index aa97a4f7..e2907a94 100644 --- a/Yesod/Application.hs +++ b/Yesod/Application.hs @@ -102,7 +102,7 @@ takeJusts (Just x:rest) = x : takeJusts rest toHackApplication :: RestfulApp resourceName => resourceName - -> (resourceName -> Verb -> Handler [(ContentType, Content)]) + -> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)]) -> Hack.Application toHackApplication sampleRN hm env = do -- The following is safe since we run cleanPath as middleware @@ -117,7 +117,7 @@ toHackApplication sampleRN hm env = do let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept r <- - runHandler handler rr ctypes' >>= + runHandler handler rr sampleRN ctypes' >>= either (applyErrorHandler sampleRN rr ctypes') return responseToHackResponse (rawLanguages rr) r diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ee0d456d..0d5ffc93 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -19,6 +19,7 @@ module Yesod.Handler ( -- * Handler monad Handler + , getYesod , runHandler , liftIO --, ToHandler (..) @@ -44,20 +45,20 @@ import Control.Monad.Attempt --import Data.Typeable ------ Handler monad -newtype Handler a = Handler { - unHandler :: RawRequest -> IO ([Header], HandlerContents a) +newtype Handler yesod a = Handler { + unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a) } data HandlerContents a = forall e. Exception e => HCError e | HCSpecial ErrorResult | HCContent a -instance Functor Handler where +instance Functor (Handler yesod) where fmap = liftM -instance Applicative Handler where +instance Applicative (Handler yesod) where pure = return (<*>) = ap -instance Monad Handler where +instance Monad (Handler yesod) where fail = failureString -- We want to catch all exceptions anyway return x = Handler $ \_ -> return ([], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do @@ -68,23 +69,27 @@ instance Monad Handler where (HCSpecial e) -> return $ ([], HCSpecial e) (HCContent a) -> unHandler (f a) rr return (headers ++ headers', c') -instance MonadIO Handler where +instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') -instance Exception e => Failure e Handler where +instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) -instance MonadRequestReader Handler where - askRawRequest = Handler $ \rr -> return ([], HCContent rr) +instance MonadRequestReader (Handler yesod) where + askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr) invalidParam _pt _pn _pe = error "invalidParam" authRequired = error "authRequired" +getYesod :: Handler yesod yesod +getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) + -- FIXME this is a stupid signature runHandler :: HasReps a - => Handler a + => Handler yesod a -> RawRequest + -> yesod -> [ContentType] -> IO (Either (ErrorResult, [Header]) Response) -runHandler (Handler handler) rr cts = do - (headers, contents) <- handler rr +runHandler (Handler handler) rr yesod cts = do + (headers, contents) <- handler (rr, yesod) case contents of HCError e -> return $ Left (InternalError $ show e, headers) HCSpecial e -> return $ Left (e, headers) @@ -171,15 +176,15 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do -} ------ Special handlers -errorResult :: ErrorResult -> Handler a +errorResult :: ErrorResult -> Handler yesod a errorResult er = Handler $ \_ -> return ([], HCSpecial er) -- | Redirect to the given URL. -redirect :: String -> Handler a +redirect :: String -> Handler yesod a redirect = errorResult . Redirect -- | Return a 404 not found page. Also denotes no handler available. -notFound :: Handler a +notFound :: Handler yesod a notFound = errorResult NotFound ------- Headers @@ -187,16 +192,16 @@ notFound = errorResult NotFound addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value - -> Handler () + -> Handler yesod () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> Handler () +deleteCookie :: String -> Handler yesod () deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. -header :: String -> String -> Handler () +header :: String -> String -> Handler yesod () header a = addHeader . Header a -addHeader :: Header -> Handler () +addHeader :: Header -> Handler yesod () addHeader h = Handler $ \_ -> return ([h], HCContent ()) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e722e21b..96229ce6 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -60,7 +60,7 @@ instance Enumerable AuthResource where newtype RpxnowApiKey = RpxnowApiKey String -authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler HtmlObject +authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler y HtmlObject authHandler _ Check Get = authCheck authHandler _ Logout Get = authLogout authHandler _ Openid Get = authOpenidForm @@ -88,7 +88,7 @@ instance Show OIDFormReq where show (OIDFormReq (Just s) _) = "

                " ++ encodeHtml s ++ "

                " -authOpenidForm :: Handler HtmlObject +authOpenidForm :: Handler y HtmlObject authOpenidForm = do m@(OIDFormReq _ dest) <- parseRequest let html = @@ -102,7 +102,7 @@ authOpenidForm = do Nothing -> return () return $ toHtmlObject $ Html $ cs html -authOpenidForward :: Handler HtmlObject +authOpenidForward :: Handler y HtmlObject authOpenidForward = do oid <- getParam "openid" env <- parseEnv @@ -115,7 +115,7 @@ authOpenidForward = do redirect res -authOpenidComplete :: Handler HtmlObject +authOpenidComplete :: Handler y HtmlObject authOpenidComplete = do gets' <- rawGetParams <$> askRawRequest dest <- cookieParam "DEST" @@ -141,7 +141,7 @@ chopHash ('#':rest) = rest chopHash x = x rpxnowLogin :: String -- ^ api key - -> Handler HtmlObject + -> Handler y HtmlObject rpxnowLogin apiKey = do token <- anyParam "token" postDest <- postParam "dest" @@ -157,7 +157,7 @@ rpxnowLogin apiKey = do header authCookieName $ Rpxnow.identifier ident redirect dest -authCheck :: Handler HtmlObject +authCheck :: Handler y HtmlObject authCheck = do ident <- maybeIdentifier case ident of @@ -167,7 +167,7 @@ authCheck = do , ("ident", i) ] -authLogout :: Handler HtmlObject +authLogout :: Handler y HtmlObject authLogout = do deleteCookie authCookieName return $ toHtmlObject [("status", "loggedout")] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 16a65721..797bd9b6 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -30,6 +30,7 @@ import qualified Hack import Yesod.Request import Data.Time (UTCTime) import Data.Convertible.Text (cs) +import Yesod.Yesod data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always @@ -86,7 +87,7 @@ instance HasReps SitemapResponse where [ (TypeXml, cs . show) ] -sitemap :: IO [SitemapUrl] -> Handler SitemapResponse +sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse sitemap urls' = do env <- parseEnv -- FIXME @@ -94,6 +95,8 @@ sitemap urls' = do urls <- liftIO urls' return $ SitemapResponse req urls -robots :: Approot -> Handler Plain -robots (Approot ar) = do - return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml" +robots :: Yesod yesod => Handler yesod Plain +robots = do + yesod <- getYesod + return $ plain $ "Sitemap: " ++ unApproot (approot yesod) + ++ "sitemap.xml" diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 0d198353..c7c06bc8 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -40,11 +40,11 @@ fileLookupDir dir fp = do then Just <$> B.readFile fp' else return Nothing -serveStatic :: FileLookup -> Verb -> Handler [(ContentType, Content)] +serveStatic :: FileLookup -> Verb -> Handler y [(ContentType, Content)] serveStatic fl Get = getStatic fl serveStatic _ _ = notFound -getStatic :: FileLookup -> Handler [(ContentType, Content)] +getStatic :: FileLookup -> Handler y [(ContentType, Content)] getStatic fl = do fp <- urlParam "filepath" -- FIXME check for .. content <- liftIO $ fl fp diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 3e29f387..024f5a20 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -19,6 +19,7 @@ --------------------------------------------------------- module Yesod.Resource ( ResourceName (..) + , ResourcePatternString , fromString , checkPattern , validatePatterns @@ -92,7 +93,9 @@ class (Show a, Enumerable a) => ResourceName a where resourcePattern :: a -> String -- | Find the handler for each resource name/verb pattern. - getHandler :: a -> Verb -> Handler [(ContentType, Content)] -- FIXME + getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME + +type ResourcePatternString = String type SMap = [(String, String)] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9580d2ce..83a6d64a 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,7 +1,6 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) - , Handler , toHackApp ) where @@ -10,10 +9,10 @@ import Data.Object.Html (toHtmlObject) import Yesod.Response import Yesod.Request import Yesod.Constants ---import Yesod.Definitions ---import Yesod.Resource (checkResourceName) +import Yesod.Definitions +import Yesod.Resource +import Yesod.Handler -import Control.Applicative --import Control.Monad (when) import qualified Hack @@ -23,11 +22,12 @@ import Hack.Middleware.Gzip import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride -type Handler a v = a -> IO v -- FIXME -type HandlerMap a = [(String, [ContentType] -> Handler a Content)] +type ContentPair = (ContentType, Content) class Yesod a where - handlers :: HandlerMap a + handlers :: + [(ResourcePatternString, + [(Verb, [ContentType] -> Handler a ContentPair)])] -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -43,37 +43,36 @@ class Yesod a where ] -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> (ContentType, Content) -- FIXME better type sig? + errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair errorHandler = defaultErrorHandler + -- | Whether or not we should check for overlapping resource names. checkOverlaps :: a -> Bool checkOverlaps = const True -newtype MyIdentity a = MyIdentity { _unMyIdentity :: a } -instance Functor MyIdentity where - fmap f (MyIdentity a) = MyIdentity $ f a -instance Applicative MyIdentity where - pure = MyIdentity - (MyIdentity f) <*> (MyIdentity a) = MyIdentity $ f a + -- | An absolute URL to the root of the application. + approot :: a -> Approot -defaultErrorHandler :: a - -> RawRequest - -> ErrorResult +defaultErrorHandler :: Yesod y + => ErrorResult -> [ContentType] - -> (ContentType, Content) -defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $ - "Not found: " ++ show rr -defaultErrorHandler _ _ (Redirect url) = - chooseRep $ toHtmlObject $ "Redirect to: " ++ url -defaultErrorHandler _ _ (InternalError e) = - chooseRep $ toHtmlObject $ "Internal server error: " ++ e -defaultErrorHandler _ _ (InvalidArgs ia) = - chooseRep $ toHtmlObject + -> Handler y ContentPair +defaultErrorHandler NotFound cts = do + rr <- askRawRequest + return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts +defaultErrorHandler (Redirect url) cts = + return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts +defaultErrorHandler PermissionDenied cts = + return $ chooseRep (toHtmlObject "Permission denied") cts +defaultErrorHandler (InvalidArgs ia) cts = + return $ chooseRep (toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) - ] -defaultErrorHandler _ _ PermissionDenied = - chooseRep $ toHtmlObject "Permission denied" + ]) cts +defaultErrorHandler (InternalError e) cts = + return $ chooseRep (toHtmlObject + [ ("Internal server error", e) + ]) cts toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do From 52f5ab2374454bb3e40784629ceaee793fbcf3c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 08:58:49 +0200 Subject: [PATCH 068/624] Removed Yesod.Application; still have some undefineds --- Yesod.hs | 4 +- Yesod/Application.hs | 163 ------------------------------------------- Yesod/Definitions.hs | 15 ++-- Yesod/Request.hs | 22 +++++- Yesod/Resource.hs | 48 +++++-------- Yesod/Yesod.hs | 81 +++++++++++++++++---- yesod.cabal | 1 - 7 files changed, 116 insertions(+), 218 deletions(-) delete mode 100644 Yesod/Application.hs diff --git a/Yesod.hs b/Yesod.hs index 32272254..124c83d4 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,7 +15,7 @@ module Yesod ( module Yesod.Request , module Yesod.Response - , module Yesod.Application + , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource @@ -24,7 +24,7 @@ module Yesod import Yesod.Request import Yesod.Response -import Yesod.Application +import Yesod.Yesod import Yesod.Definitions import Yesod.Handler import Yesod.Resource diff --git a/Yesod/Application.hs b/Yesod/Application.hs deleted file mode 100644 index e2907a94..00000000 --- a/Yesod/Application.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} ---------------------------------------------------------- --- --- Module : Yesod.Application --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Defining the application. --- ---------------------------------------------------------- -module Yesod.Application - ( - toHackApp - , RestfulApp (..) - ) where - -import Web.Encodings -import Data.Enumerable -import Control.Monad (when) -import Data.Object.Html - -import qualified Hack -import Hack.Middleware.CleanPath -import Hack.Middleware.ClientSession -import Hack.Middleware.Gzip -import Hack.Middleware.Jsonp -import Hack.Middleware.MethodOverride - -import Yesod.Request -import Yesod.Response -import Yesod.Utils -import Yesod.Handler -import Yesod.Definitions -import Yesod.Constants -import Yesod.Resource -import Yesod.Rep - -import Data.Convertible.Text -import Control.Arrow ((***)) - --- | A data type that can be turned into a Hack application. -class ResourceName a => RestfulApp a where - -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Word256 - encryptKey _ = getKey defaultKeyFile - - -- | All of the middlewares to install. - hackMiddleware :: a -> [Hack.Middleware] - hackMiddleware _ = - [ gzip - , cleanPath - , jsonp - , methodOverride - ] - - -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig? - - -- | Whether or not we should check for overlapping resource names. - checkOverlaps :: a -> Bool - checkOverlaps = const True - --- | Given a sample resource name (purely for typing reasons), generating --- a Hack application. -toHackApp :: RestfulApp resourceName - => resourceName - -> IO Hack.Application -toHackApp a = do - when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? - key <- encryptKey a - let app' = toHackApplication a getHandler - clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... - app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] - return app - -findResourceNames :: ResourceName a - => Resource - -> [(a, [(String, String)])] -findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate - -checkPatternHelper :: ResourceName a - => Resource - -> a - -> Maybe (a, [(String, String)]) -checkPatternHelper r rn = - case checkPattern (fromString $ resourcePattern rn) r of - Nothing -> Nothing - Just pairs -> Just (rn, pairs) - -takeJusts :: [Maybe a] -> [a] -takeJusts [] = [] -takeJusts (Nothing:rest) = takeJusts rest -takeJusts (Just x:rest) = x : takeJusts rest - -toHackApplication :: RestfulApp resourceName - => resourceName - -> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)]) - -> Hack.Application -toHackApplication sampleRN hm env = do - -- The following is safe since we run cleanPath as middleware - let (Right resource) = splitPath $ Hack.pathInfo env - let (handler, urlParams') = - case findResourceNames resource of - [] -> (notFound, []) - ((rn, urlParams''):_) -> - let verb = toVerb $ Hack.requestMethod env - in (hm rn verb, urlParams'') - let rr = envToRawRequest urlParams' env - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept - r <- - runHandler handler rr sampleRN ctypes' >>= - either (applyErrorHandler sampleRN rr ctypes') return - responseToHackResponse (rawLanguages rr) r - -applyErrorHandler :: (RestfulApp ra, Monad m) - => ra - -> RawRequest - -> [ContentType] - -> (ErrorResult, [Header]) - -> m Response -applyErrorHandler ra rr cts (er, headers) = do - let (ct, c) = chooseRep (errorHandler ra rr er) cts - return $ Response - (getStatus er) - (getHeaders er ++ headers) - ct - c - -responseToHackResponse :: [String] -- ^ language list - -> Response -> IO Hack.Response -responseToHackResponse _FIXMEls (Response sc hs ct c) = do - hs' <- mapM toPair hs - let hs'' = ("Content-Type", show ct) : hs' - let asLBS = unContent c - return $ Hack.Response sc hs'' asLBS - -envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest -envToRawRequest urlParams' env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = tryLookup "0" "Content-Length" $ Hack.http env - ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = map (convertSuccess *** convertSuccess) *** - map (convertSuccess *** convertFileInfo) - $ parsePost ctype clength - $ Hack.hackInput env - rawCookie = tryLookup "" "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - langs = ["en"] -- FIXME - in RawRequest rawPieces urlParams' gets' posts cookies' files env langs - -convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c -convertFileInfo (FileInfo a b c) = - FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index e3cc3a12..43f38aec 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Yesod.Definitions @@ -15,22 +14,22 @@ --------------------------------------------------------- module Yesod.Definitions ( Verb (..) - , toVerb , Resource , Approot (..) , Language ) where import qualified Hack +import Data.Convertible.Text data Verb = Get | Put | Delete | Post deriving (Eq, Show) -toVerb :: Hack.RequestMethod -> Verb -toVerb Hack.PUT = Put -toVerb Hack.DELETE = Delete -toVerb Hack.POST = Post -toVerb _ = Get +instance ConvertSuccess Hack.RequestMethod Verb where + convertSuccess Hack.PUT = Put + convertSuccess Hack.DELETE = Delete + convertSuccess Hack.POST = Post + convertSuccess _ = Get type Resource = [String] diff --git a/Yesod/Request.hs b/Yesod/Request.hs index a25ed720..515f0388 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} -- Parameter String --------------------------------------------------------- -- -- Module : Yesod.Request @@ -56,6 +57,9 @@ import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) import qualified Data.ByteString.Lazy as BL +import Data.Convertible.Text +import Hack.Middleware.CleanPath (splitPath) +import Control.Arrow ((***)) -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -319,3 +323,19 @@ notBlank rp = case paramValue rp of "" -> invalidParam (paramType rp) (paramName rp) "Required field" s -> return s + +instance ConvertSuccess ([(ParamName, ParamValue)], Hack.Env) RawRequest where + convertSuccess (urlParams', env) = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = tryLookup "0" "Content-Length" $ Hack.http env + ctype = tryLookup "" "Content-Type" $ Hack.http env + convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c + (posts, files) = map (convertSuccess *** convertSuccess) *** + map (convertSuccess *** convertFileInfo) + $ parsePost ctype clength + $ Hack.hackInput env + rawCookie = tryLookup "" "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 024f5a20..03a89f9a 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -4,6 +4,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Yesod.Resource @@ -18,9 +20,8 @@ -- --------------------------------------------------------- module Yesod.Resource - ( ResourceName (..) - , ResourcePatternString - , fromString + ( ResourcePatternString -- FIXME rename + , fromString -- FIXME rename , checkPattern , validatePatterns , checkResourceName @@ -32,16 +33,12 @@ module Yesod.Resource import Data.List.Split (splitOn) import Yesod.Definitions -import Yesod.Handler import Data.List (intercalate) -import Data.Enumerable import Data.Char (isDigit) -#if TEST -import Yesod.Rep hiding (testSuite) -#else -import Yesod.Rep -#endif +import Data.Typeable (Typeable) +import Control.Exception (Exception) +import Data.Attempt -- for failure stuff #if TEST import Control.Monad (replicateM, when) @@ -83,18 +80,6 @@ fromString' ('*':rest) = Slurp rest fromString' ('#':rest) = DynInt rest fromString' x = Static x -class (Show a, Enumerable a) => ResourceName a where - -- | Get the URL pattern for each different resource name. - -- Something like /foo/$bar/baz/ will match the regular expression - -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. - -- - -- Also, /foo/\*bar/ will match /foo/, capturing the value - -- into the bar urlParam. - resourcePattern :: a -> String - - -- | Find the handler for each resource name/verb pattern. - getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME - type ResourcePatternString = String type SMap = [(String, String)] @@ -150,14 +135,19 @@ overlaps (Static s:x) (DynInt _:y) | otherwise = False overlaps (Static a:x) (Static b:y) = a == b && overlaps x y -checkResourceName :: (Monad m, ResourceName rn) => rn -> m () -checkResourceName rn = do - let avs@(y:_) = enumerate - _ignore = asTypeOf rn y - let patterns = map (fromString . resourcePattern) avs - case validatePatterns patterns of +data OverlappingPatterns = + OverlappingPatterns [(ResourcePattern, ResourcePattern)] + deriving (Show, Typeable) +instance Exception OverlappingPatterns + +checkResourceName :: MonadFailure OverlappingPatterns f + => [ResourcePatternString] + -> f () +checkResourceName patterns' = + let patterns = map fromString patterns' + in case validatePatterns patterns of [] -> return () - x -> fail $ "Overlapping patterns:\n" ++ unlines (map show x) + x -> failure $ OverlappingPatterns x validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] validatePatterns [] = [] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 83a6d64a..a8e5af05 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -13,7 +13,11 @@ import Yesod.Definitions import Yesod.Resource import Yesod.Handler ---import Control.Monad (when) +import Control.Monad (when) +import Data.Maybe (fromMaybe) +import Data.Convertible.Text +import Web.Encodings +import Control.Arrow ((***)) import qualified Hack import Hack.Middleware.CleanPath @@ -33,15 +37,6 @@ class Yesod a where encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile - -- | All of the middlewares to install. - hackMiddleware :: a -> [Hack.Middleware] - hackMiddleware _ = - [ gzip - , cleanPath - , jsonp - , methodOverride - ] - -- | Output error response pages. errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair errorHandler = defaultErrorHandler @@ -74,14 +69,72 @@ defaultErrorHandler (InternalError e) cts = [ ("Internal server error", e) ]) cts +-- | For type signature reasons. +handlers' :: Yesod y => y -> + [(ResourcePatternString, + [(Verb, [ContentType] -> Handler y ContentPair)])] +handlers' _ = handlers + toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do - -- FIXME when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? + let patterns = map fst $ handlers' a + when (checkOverlaps a) $ checkResourceName patterns -- FIXME maybe this should be done compile-time? key <- encryptKey a let app' = toHackApp' a - clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... - app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] + middleware = + [ gzip + , cleanPath + , jsonp + , methodOverride + , clientsession [authCookieName] key + ] + app = foldr ($) app' middleware app env toHackApp' :: Yesod y => y -> Hack.Application -toHackApp' = undefined -- FIXME +toHackApp' y env = do + let (Right resource) = splitPath $ Hack.pathInfo env + types = httpAccept env + (handler, urlParams') = fromMaybe (notFound, []) $ do + (verbPairs, urlParams'') <- lookupHandlers resource + let verb = cs $ Hack.requestMethod env + handler'' <- lookup verb verbPairs + return (handler'' types, urlParams'') + rr = envToRawRequest urlParams' env + runHandler' handler rr y + +httpAccept :: Hack.Env -> [ContentType] +httpAccept = undefined + +lookupHandlers :: Yesod y + => Resource + -> Maybe + ( [(Verb, [ContentType] -> Handler y ContentPair)] + , [(ParamName, ParamValue)] + ) +lookupHandlers = undefined + +runHandler' :: Yesod y + => Handler y ContentPair + -> RawRequest + -> y + -> IO Hack.Response +runHandler' = undefined + +envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest +envToRawRequest urlParams' env = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env + ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env + (posts, files) = map (cs *** cs) *** map (cs *** convertFileInfo) + $ parsePost ctype clength + $ Hack.hackInput env + rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs + +convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c +convertFileInfo (FileInfo a b c) = + FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/yesod.cabal b/yesod.cabal index e4982fa0..3bff64b1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -51,7 +51,6 @@ library Yesod.Utils Yesod.Definitions Yesod.Handler - Yesod.Application Yesod.Resource Yesod.Yesod Data.Object.Html From 32f3ed04eb9ebb7fb643c4512735817fabd73011 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 09:34:01 +0200 Subject: [PATCH 069/624] Fixed type of handlers; Resource renames --- Yesod/Rep.hs | 16 +++++--- Yesod/Resource.hs | 100 ++++++++++++++++++++++++---------------------- Yesod/Yesod.hs | 9 +---- 3 files changed, 64 insertions(+), 61 deletions(-) diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 796fd783..0b505e50 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -29,8 +29,8 @@ module Yesod.Rep ( ContentType (..) , Content (..) - , Rep - , Reps + , RepChooser + , ContentPair , HasReps (..) -- FIXME TemplateFile or some such... -- * Specific types of representations @@ -103,16 +103,20 @@ instance ConvertSuccess ByteString Content where instance ConvertSuccess String Content where convertSuccess = Content . cs -type Rep a = (ContentType, a -> Content) -type Reps a = [Rep a] +type ContentPair = (ContentType, Content) +type RepChooser = [ContentType] -> ContentPair -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: Reps a - chooseRep :: a -> [ContentType] -> (ContentType, Content) + reps :: [(ContentType, a -> Content)] + chooseRep :: a -> RepChooser chooseRep = chooseRep' +instance HasReps RepChooser where + reps = error "reps of RepChooser" + chooseRep = id + instance HasReps [(ContentType, Content)] where reps = error "reps of [(ContentType, Content)]" chooseRep a cts = diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 03a89f9a..455c6c09 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -20,8 +20,7 @@ -- --------------------------------------------------------- module Yesod.Resource - ( ResourcePatternString -- FIXME rename - , fromString -- FIXME rename + ( ResourcePattern , checkPattern , validatePatterns , checkResourceName @@ -39,6 +38,7 @@ import Data.Char (isDigit) import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff +import Data.Convertible.Text #if TEST import Control.Monad (replicateM, when) @@ -49,38 +49,39 @@ import Test.HUnit hiding (Test) import Test.QuickCheck #endif -data ResourcePatternPiece = +-- | Resource Pattern Piece +data RPP = Static String | Dynamic String | DynInt String | Slurp String -- ^ take up the rest of the pieces. must be last deriving Eq -instance Show ResourcePattern where + +-- | Resource Pattern +newtype RP = RP { unRP :: [RPP] } + deriving Eq + +instance Show RP where show = concatMap helper . unRP where helper (Static s) = '/' : s helper (Dynamic s) = '/' : '$' : s helper (Slurp s) = '/' : '*' : s helper (DynInt s) = '/' : '#' : s -isSlurp :: ResourcePatternPiece -> Bool +isSlurp :: RPP -> Bool isSlurp (Slurp _) = True isSlurp _ = False -newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } - deriving Eq +instance ConvertSuccess String RP where + convertSuccess = RP . map helper . filter (not . null) .splitOn "/" + where + helper :: String -> RPP + helper ('$':rest) = Dynamic rest + helper ('*':rest) = Slurp rest + helper ('#':rest) = DynInt rest + helper x = Static x --- | FIXME not a good name for the function. Use convertible -fromString :: String -> ResourcePattern -fromString = ResourcePattern - . map fromString' . filter (not . null) . splitOn "/" - -fromString' :: String -> ResourcePatternPiece -fromString' ('$':rest) = Dynamic rest -fromString' ('*':rest) = Slurp rest -fromString' ('#':rest) = DynInt rest -fromString' x = Static x - -type ResourcePatternString = String +type ResourcePattern = String type SMap = [(String, String)] @@ -89,10 +90,10 @@ data CheckPatternReturn = | DynamicMatch (String, String) | NoMatch -checkPattern :: ResourcePattern -> Resource -> Maybe SMap +checkPattern :: RP -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP -checkPatternPieces :: [ResourcePatternPiece] -> Resource -> Maybe SMap +checkPatternPieces :: [RPP] -> Resource -> Maybe SMap checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do let rp' = init rp @@ -104,7 +105,7 @@ checkPatternPieces rp r | length rp /= length r = Nothing | otherwise = combine [] $ zipWith checkPattern' rp r -checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn +checkPattern' :: RPP -> String -> CheckPatternReturn checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch checkPattern' (Dynamic x) y = DynamicMatch (x, y) checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" @@ -118,7 +119,7 @@ combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest combine s (DynamicMatch x:rest) = combine (x:s) rest -overlaps :: [ResourcePatternPiece] -> [ResourcePatternPiece] -> Bool +overlaps :: [RPP] -> [RPP] -> Bool overlaps [] [] = True overlaps [] _ = False overlaps _ [] = False @@ -141,22 +142,25 @@ data OverlappingPatterns = instance Exception OverlappingPatterns checkResourceName :: MonadFailure OverlappingPatterns f - => [ResourcePatternString] + => [ResourcePattern] -> f () -checkResourceName patterns' = - let patterns = map fromString patterns' - in case validatePatterns patterns of +checkResourceName patterns = + case validatePatterns patterns of [] -> return () x -> failure $ OverlappingPatterns x -validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] +validatePatterns :: [ResourcePattern] + -> [(ResourcePattern, ResourcePattern)] validatePatterns [] = [] validatePatterns (x:xs) = concatMap (validatePatterns' x) xs ++ validatePatterns xs where validatePatterns' :: ResourcePattern - -> ResourcePattern - -> [(ResourcePattern, ResourcePattern)] - validatePatterns' a b = [(a, b) | overlaps (unRP a) (unRP b)] + -> ResourcePattern + -> [(ResourcePattern, ResourcePattern)] + validatePatterns' a b = + let a' = unRP $ cs a + b' = unRP $ cs b + in [(a, b) | overlaps a' b'] #if TEST ---- Testing @@ -170,35 +174,35 @@ testSuite = testGroup "Yesod.Resource" , testCase "integers" caseIntegers ] -deriving instance Arbitrary ResourcePattern +deriving instance Arbitrary RP caseOverlap1 :: Assertion caseOverlap1 = assert $ not $ overlaps - (unRP $ fromString "/foo/$bar/") - (unRP $ fromString "/foo/baz/$bin") + (unRP $ cs "/foo/$bar/") + (unRP $ cs "/foo/baz/$bin") caseOverlap2 :: Assertion caseOverlap2 = assert $ overlaps - (unRP $ fromString "/foo/bar") - (unRP $ fromString "/foo/$baz") + (unRP $ cs "/foo/bar") + (unRP $ cs "/foo/$baz") caseOverlap3 :: Assertion caseOverlap3 = assert $ overlaps - (unRP $ fromString "/foo/bar/baz/$bin") - (unRP $ fromString "*slurp") + (unRP $ cs "/foo/bar/baz/$bin") + (unRP $ cs "*slurp") caseValidatePatterns :: Assertion caseValidatePatterns = - let p1 = fromString "/foo/bar/baz" - p2 = fromString "/foo/$bar/baz" - p3 = fromString "/bin" - p4 = fromString "/bin/boo" - p5 = fromString "/bin/*slurp" + let p1 = cs "/foo/bar/baz" + p2 = cs "/foo/$bar/baz" + p3 = cs "/bin" + p4 = cs "/bin/boo" + p5 = cs "/bin/*slurp" in validatePatterns [p1, p2, p3, p4, p5] @?= [ (p1, p2) , (p4, p5) ] -prop_showPattern :: ResourcePattern -> Bool -prop_showPattern p = fromString (show p) == p +prop_showPattern :: RP -> Bool +prop_showPattern p = cs (show p) == p caseIntegers :: Assertion caseIntegers = do @@ -210,8 +214,8 @@ caseIntegers = do p6 = "/foo/*slurp/" checkOverlap :: String -> String -> Bool -> IO () checkOverlap a b c = do - let res1 = overlaps (unRP $ fromString a) (unRP $ fromString b) - let res2 = overlaps (unRP $ fromString b) (unRP $ fromString a) + let res1 = overlaps (unRP $ cs a) (unRP $ cs b) + let res2 = overlaps (unRP $ cs b) (unRP $ cs a) when (res1 /= c || res2 /= c) $ assertString $ a ++ (if c then " does not overlap with " else " overlaps with ") ++ b @@ -221,7 +225,7 @@ caseIntegers = do checkOverlap p1 p5 False checkOverlap p1 p6 True -instance Arbitrary ResourcePatternPiece where +instance Arbitrary RPP where arbitrary = do constr <- elements [Static, Dynamic, Slurp, DynInt] size <- elements [1..10] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8e5af05..7321fcae 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -26,12 +26,8 @@ import Hack.Middleware.Gzip import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride -type ContentPair = (ContentType, Content) - class Yesod a where - handlers :: - [(ResourcePatternString, - [(Verb, [ContentType] -> Handler a ContentPair)])] + handlers :: [(ResourcePattern, [(Verb, Handler a RepChooser)])] -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -71,8 +67,7 @@ defaultErrorHandler (InternalError e) cts = -- | For type signature reasons. handlers' :: Yesod y => y -> - [(ResourcePatternString, - [(Verb, [ContentType] -> Handler y ContentPair)])] + [(ResourcePattern, [(Verb, Handler y RepChooser)])] handlers' _ = handlers toHackApp :: Yesod y => y -> Hack.Application From b78a16e9383f13fab80f1e2890da81cad63616ae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 19:50:16 +0200 Subject: [PATCH 070/624] Removed bad undefineds --- Yesod.hs | 1 + Yesod/Handler.hs | 31 +++++++++++++--------- Yesod/Resource.hs | 22 +++++++++++----- Yesod/Response.hs | 12 +++++++++ Yesod/Yesod.hs | 65 +++++++++++++++++++++++++---------------------- yesod.cabal | 3 ++- 6 files changed, 85 insertions(+), 49 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 124c83d4..6d492102 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- -- Module : Yesod diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d5ffc93..0d801a5b 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -81,21 +81,28 @@ instance MonadRequestReader (Handler yesod) where getYesod :: Handler yesod yesod getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) --- FIXME this is a stupid signature -runHandler :: HasReps a - => Handler yesod a +runHandler :: Handler yesod RepChooser + -> (ErrorResult -> Handler yesod RepChooser) -> RawRequest -> yesod -> [ContentType] - -> IO (Either (ErrorResult, [Header]) Response) -runHandler (Handler handler) rr yesod cts = do - (headers, contents) <- handler (rr, yesod) - case contents of - HCError e -> return $ Left (InternalError $ show e, headers) - HCSpecial e -> return $ Left (e, headers) - HCContent a -> - let (ct, c) = chooseRep a cts - in return $ Right $ Response 200 headers ct c + -> IO Response +runHandler (Handler handler) eh rr y cts = do + (headers, contents) <- Control.Exception.catch + (handler (rr, y)) + (\e -> return ([], HCError (e :: Control.Exception.SomeException))) + let contents' = + case contents of + HCError e -> Left $ InternalError $ show e + HCSpecial e -> Left e + HCContent a -> Right a + case contents' of + Left e -> do + Response _ hs ct c <- runHandler (eh e) eh rr y cts + return $ Response (getStatus e) hs ct c + Right a -> + let (ct, c) = a cts + in return $ Response 200 headers ct c {- FIXME class ToHandler a where toHandler :: a -> Handler diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 455c6c09..f339357b 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- -- Module : Yesod.Resource @@ -22,8 +23,9 @@ module Yesod.Resource ( ResourcePattern , checkPattern + , checkPatternsTH , validatePatterns - , checkResourceName + , checkPatterns #if TEST -- * Testing , testSuite @@ -35,13 +37,16 @@ import Yesod.Definitions import Data.List (intercalate) import Data.Char (isDigit) +import Control.Monad (when) +import Language.Haskell.TH + import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Convertible.Text #if TEST -import Control.Monad (replicateM, when) +import Control.Monad (replicateM) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck (testProperty) @@ -93,6 +98,11 @@ data CheckPatternReturn = checkPattern :: RP -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP +checkPatternsTH :: Bool -> [ResourcePattern] -> Q Exp +checkPatternsTH toCheck patterns = do + runIO $ when toCheck $ checkPatterns patterns + [|return ()|] + checkPatternPieces :: [RPP] -> Resource -> Maybe SMap checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do @@ -141,10 +151,10 @@ data OverlappingPatterns = deriving (Show, Typeable) instance Exception OverlappingPatterns -checkResourceName :: MonadFailure OverlappingPatterns f - => [ResourcePattern] - -> f () -checkResourceName patterns = +checkPatterns :: MonadFailure OverlappingPatterns f + => [ResourcePattern] + -> f () +checkPatterns patterns = case validatePatterns patterns of [] -> return () x -> failure $ OverlappingPatterns x diff --git a/Yesod/Response.hs b/Yesod/Response.hs index f4232ead..bf548de0 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -26,6 +26,8 @@ module Yesod.Response -- * Header , Header (..) , toPair + -- * Converting to Hack values + , responseToHackResponse #if TEST -- * Tests , testSuite @@ -41,6 +43,7 @@ import Yesod.Rep import Data.Time.Clock import Web.Encodings (formatW3) +import qualified Hack #if TEST import Test.Framework (testGroup, Test) @@ -91,6 +94,15 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) +-- FIXME add test +responseToHackResponse :: [String] -- ^ language list + -> Response -> IO Hack.Response +responseToHackResponse _FIXMEls (Response sc hs ct c) = do + hs' <- mapM toPair hs + let hs'' = ("Content-Type", show ct) : hs' + let asLBS = unContent c + return $ Hack.Response sc hs'' asLBS + #if TEST ----- Testing testSuite :: Test diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7321fcae..b794b74f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -12,12 +12,13 @@ import Yesod.Constants import Yesod.Definitions import Yesod.Resource import Yesod.Handler +import Yesod.Utils -import Control.Monad (when) import Data.Maybe (fromMaybe) import Data.Convertible.Text import Web.Encodings import Control.Arrow ((***)) +import Control.Monad (when) import qualified Hack import Hack.Middleware.CleanPath @@ -34,7 +35,7 @@ class Yesod a where encryptKey _ = getKey defaultKeyFile -- | Output error response pages. - errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair + errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler -- | Whether or not we should check for overlapping resource names. @@ -46,24 +47,23 @@ class Yesod a where defaultErrorHandler :: Yesod y => ErrorResult - -> [ContentType] - -> Handler y ContentPair -defaultErrorHandler NotFound cts = do + -> Handler y RepChooser +defaultErrorHandler NotFound = do rr <- askRawRequest - return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts -defaultErrorHandler (Redirect url) cts = - return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts -defaultErrorHandler PermissionDenied cts = - return $ chooseRep (toHtmlObject "Permission denied") cts -defaultErrorHandler (InvalidArgs ia) cts = - return $ chooseRep (toHtmlObject + return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr +defaultErrorHandler (Redirect url) = + return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url +defaultErrorHandler PermissionDenied = + return $ chooseRep $ toHtmlObject "Permission denied" +defaultErrorHandler (InvalidArgs ia) = + return $ chooseRep $ toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) - ]) cts -defaultErrorHandler (InternalError e) cts = - return $ chooseRep (toHtmlObject + ] +defaultErrorHandler (InternalError e) = + return $ chooseRep $ toHtmlObject [ ("Internal server error", e) - ]) cts + ] -- | For type signature reasons. handlers' :: Yesod y => y -> @@ -72,8 +72,12 @@ handlers' _ = handlers toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do - let patterns = map fst $ handlers' a - when (checkOverlaps a) $ checkResourceName patterns -- FIXME maybe this should be done compile-time? + -- FIXME figure out a way to do this check compile-time + when (checkOverlaps a) $ checkPatterns $ map fst $ handlers' a + toHackAppUnchecked a env + +toHackAppUnchecked :: Yesod y => y -> Hack.Application +toHackAppUnchecked a env = do key <- encryptKey a let app' = toHackApp' a middleware = @@ -94,27 +98,28 @@ toHackApp' y env = do (verbPairs, urlParams'') <- lookupHandlers resource let verb = cs $ Hack.requestMethod env handler'' <- lookup verb verbPairs - return (handler'' types, urlParams'') + return (handler'', urlParams'') rr = envToRawRequest urlParams' env - runHandler' handler rr y + res <- runHandler handler errorHandler rr y types + let langs = ["en"] -- FIXME + responseToHackResponse langs res httpAccept :: Hack.Env -> [ContentType] -httpAccept = undefined +httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" + . lookup "Accept" . Hack.http lookupHandlers :: Yesod y => Resource -> Maybe - ( [(Verb, [ContentType] -> Handler y ContentPair)] + ( [(Verb, Handler y RepChooser)] , [(ParamName, ParamValue)] ) -lookupHandlers = undefined - -runHandler' :: Yesod y - => Handler y ContentPair - -> RawRequest - -> y - -> IO Hack.Response -runHandler' = undefined +lookupHandlers r = helper handlers where + helper [] = Nothing + helper ((rps, v):rest) = + case checkPattern (cs rps) r of + Just up -> Just (v, up) + Nothing -> helper rest envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = diff --git a/yesod.cabal b/yesod.cabal index 3bff64b1..705a419e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -42,7 +42,8 @@ library containers >= 0.2.0.1 && < 0.3, HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, - attempt >= 0.2.1 && < 0.3 + attempt >= 0.2.1 && < 0.3, + template-haskell exposed-modules: Yesod Yesod.Constants Yesod.Rep From 998ee83a5b9842488bdb4333c41e179b36b954f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 20:02:00 +0200 Subject: [PATCH 071/624] Fixed default chooseRep --- Yesod/Rep.hs | 28 ++++++++-------------------- 1 file changed, 8 insertions(+), 20 deletions(-) diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 0b505e50..10550ec3 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -43,7 +43,6 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) -import Control.Applicative #if TEST import Data.Object.Html hiding (testSuite) @@ -111,7 +110,14 @@ type RepChooser = [ContentType] -> ContentPair class HasReps a where reps :: [(ContentType, a -> Content)] chooseRep :: a -> RepChooser - chooseRep = chooseRep' + chooseRep a ts = + let (ct, c) = + case filter (\(ct', _) -> ct' `elem` ts) reps of + (x:_) -> x + [] -> case reps of + [] -> error "Empty reps" + (x:_) -> x + in (ct, c a) instance HasReps RepChooser where reps = error "reps of RepChooser" @@ -126,24 +132,6 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" --- FIXME done badly, needs cleanup -chooseRep' :: HasReps a - => a - -> [ContentType] - -> (ContentType, Content) -chooseRep' a ts = - let choices = rs' ++ rs - helper2 (ct, f) = (ct, f a) - in if null rs - then error "Invalid empty reps" - else helper2 $ head choices - where - rs = reps - rs' = filter (\r -> fst r `elem` ts) rs - -- for type signature stuff - _ignored = pure (undefined :: Content) `asTypeOf` - (snd (head rs) ) - newtype Plain = Plain Text deriving (Eq, Show) From c23984b15433586bf17660845a944a5ea6075c9a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 20:21:45 +0200 Subject: [PATCH 072/624] Added Template reps --- Yesod/Rep.hs | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 10550ec3..ceb64c65 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -32,10 +32,10 @@ module Yesod.Rep , RepChooser , ContentPair , HasReps (..) - -- FIXME TemplateFile or some such... -- * Specific types of representations , Plain (..) , plain + , Template (..) #if TEST , testSuite #endif @@ -43,6 +43,7 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) +import Data.Maybe (catMaybes) #if TEST import Data.Object.Html hiding (testSuite) @@ -52,6 +53,7 @@ import Data.Object.Html import Data.Object.Json import Data.Convertible.Text +import Text.StringTemplate #if TEST import Test.Framework (testGroup, Test) @@ -112,12 +114,17 @@ class HasReps a where chooseRep :: a -> RepChooser chooseRep a ts = let (ct, c) = - case filter (\(ct', _) -> ct' `elem` ts) reps of + case catMaybes $ map helper ts of (x:_) -> x [] -> case reps of [] -> error "Empty reps" (x:_) -> x in (ct, c a) + where + --helper :: ContentType -> Maybe ContentPair + helper ct = do + c <- lookup ct reps + return (ct, c) instance HasReps RepChooser where reps = error "reps of RepChooser" @@ -138,6 +145,14 @@ newtype Plain = Plain Text plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs +data Template = Template (StringTemplate String) HtmlObject +instance HasReps Template where + reps = [ (TypeHtml, + \(Template t h) -> + cs $ toString $ setAttribute "o" h t) + , (TypeJson, \(Template _ ho) -> cs $ unJsonDoc $ cs ho) + ] + -- Useful instances of HasReps instance HasReps HtmlObject where reps = @@ -168,9 +183,25 @@ caseChooseRepRaw = do chooseRep hasreps [bar, foo] @?= (foo, content) chooseRep hasreps [bar] @?= (TypeHtml, content) +caseChooseRepTemplate :: Assertion +caseChooseRepTemplate = do + let temp = newSTMP "foo:$o.foo$, bar:$o.bar$" + ho = toHtmlObject [ ("foo", toHtmlObject "") + , ("bar", toHtmlObject ["bar1", "bar2"]) + ] + hasreps = Template temp ho + res1 = cs "foo:<fooval>, bar:bar1bar2" + res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ + "\"foo\":\"<fooval>\"}" + (1, chooseRep hasreps [TypeHtml]) @?= (1, (TypeHtml, res1)) + (2, chooseRep hasreps [TypeJson]) @?= (2, (TypeJson, res2)) + (3, chooseRep hasreps [TypeHtml, TypeJson]) @?= (3, (TypeHtml, res1)) + (4, chooseRep hasreps [TypeJson, TypeHtml]) @?= (4, (TypeJson, res2)) + testSuite :: Test testSuite = testGroup "Yesod.Rep" [ testCase "caseChooseRep HtmlObject" caseChooseRepHO , testCase "caseChooseRep raw" caseChooseRepRaw + , testCase "caseChooseRep Template" caseChooseRepTemplate ] #endif From 12437533b68b303601c67c20bdf3a8a60bb6ea3c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 23:41:20 +0200 Subject: [PATCH 073/624] TemplateFile rep --- Yesod/Handler.hs | 6 ++-- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Rep.hs | 73 ++++++++++++++++++++++++++++----------- test/rep.st | 1 + 5 files changed, 58 insertions(+), 26 deletions(-) create mode 100644 test/rep.st diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d801a5b..50d2ff16 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -100,9 +100,9 @@ runHandler (Handler handler) eh rr y cts = do Left e -> do Response _ hs ct c <- runHandler (eh e) eh rr y cts return $ Response (getStatus e) hs ct c - Right a -> - let (ct, c) = a cts - in return $ Response 200 headers ct c + Right a -> do + (ct, c) <- a cts + return $ Response 200 headers ct c {- FIXME class ToHandler a where toHandler :: a -> Handler diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 9a4ffaba..1305d4ec 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -34,7 +34,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps = - [ (TypeAtom, cs . show) + [ (TypeAtom, return . cs . show) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 797bd9b6..b6b6d337 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -84,7 +84,7 @@ instance Show SitemapResponse where -- FIXME very ugly, use Text instead instance HasReps SitemapResponse where reps = - [ (TypeXml, cs . show) + [ (TypeXml, return . cs . show) ] sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index ceb64c65..ae5e4998 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -36,6 +36,7 @@ module Yesod.Rep , Plain (..) , plain , Template (..) + , TemplateFile (..) #if TEST , testSuite #endif @@ -105,21 +106,22 @@ instance ConvertSuccess String Content where convertSuccess = Content . cs type ContentPair = (ContentType, Content) -type RepChooser = [ContentType] -> ContentPair +type RepChooser = [ContentType] -> IO ContentPair -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: [(ContentType, a -> Content)] + reps :: [(ContentType, a -> IO Content)] chooseRep :: a -> RepChooser - chooseRep a ts = + chooseRep a ts = do let (ct, c) = case catMaybes $ map helper ts of (x:_) -> x [] -> case reps of [] -> error "Empty reps" (x:_) -> x - in (ct, c a) + c' <- c a + return (ct, c') where --helper :: ContentType -> Maybe ContentPair helper ct = do @@ -132,7 +134,7 @@ instance HasReps RepChooser where instance HasReps [(ContentType, Content)] where reps = error "reps of [(ContentType, Content)]" - chooseRep a cts = + chooseRep a cts = return $ case filter (\(ct, _) -> ct `elem` cts) a of ((ct, c):_) -> (ct, c) _ -> case a of @@ -149,15 +151,28 @@ data Template = Template (StringTemplate String) HtmlObject instance HasReps Template where reps = [ (TypeHtml, \(Template t h) -> - cs $ toString $ setAttribute "o" h t) - , (TypeJson, \(Template _ ho) -> cs $ unJsonDoc $ cs ho) + return $ cs $ toString $ setAttribute "o" h t) + , (TypeJson, \(Template _ ho) -> + return $ cs $ unJsonDoc $ cs ho) + ] + +data TemplateFile = TemplateFile FilePath HtmlObject +instance HasReps TemplateFile where + reps = [ (TypeHtml, + \(TemplateFile fp h) -> do + contents <- readFile fp + let t = newSTMP contents + return $ cs $ toString $ setAttribute "o" h t + ) + , (TypeJson, \(TemplateFile _ ho) -> + return $ cs $ unJsonDoc $ cs ho) ] -- Useful instances of HasReps instance HasReps HtmlObject where reps = - [ (TypeHtml, cs . unHtmlDoc . cs) - , (TypeJson, cs . unJsonDoc . cs) + [ (TypeHtml, return . cs . unHtmlDoc . cs) + , (TypeJson, return . cs . unJsonDoc . cs) ] #if TEST @@ -167,10 +182,10 @@ caseChooseRepHO = do a = toHtmlObject content htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content jsonbs = Content . cs $ "\"" ++ content ++ "\"" - chooseRep a [TypeHtml] @?= (TypeHtml, htmlbs) - chooseRep a [TypeJson] @?= (TypeJson, jsonbs) - chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs) - chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs) + chooseRep a [TypeHtml] >>= (@?= (TypeHtml, htmlbs)) + chooseRep a [TypeJson] >>= (@?= (TypeJson, jsonbs)) + chooseRep a [TypeHtml, TypeJson] >>= (@?= (TypeHtml, htmlbs)) + chooseRep a [TypeOther "foo", TypeJson] >>= (@?= (TypeJson, jsonbs)) caseChooseRepRaw :: Assertion caseChooseRepRaw = do @@ -178,10 +193,10 @@ caseChooseRepRaw = do foo = TypeOther "foo" bar = TypeOther "bar" hasreps = [(TypeHtml, content), (foo, content)] - chooseRep hasreps [TypeHtml] @?= (TypeHtml, content) - chooseRep hasreps [foo, bar] @?= (foo, content) - chooseRep hasreps [bar, foo] @?= (foo, content) - chooseRep hasreps [bar] @?= (TypeHtml, content) + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, content)) + chooseRep hasreps [foo, bar] >>= (@?= (foo, content)) + chooseRep hasreps [bar, foo] >>= (@?= (foo, content)) + chooseRep hasreps [bar] >>= (@?= (TypeHtml, content)) caseChooseRepTemplate :: Assertion caseChooseRepTemplate = do @@ -193,15 +208,31 @@ caseChooseRepTemplate = do res1 = cs "foo:<fooval>, bar:bar1bar2" res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ "\"foo\":\"<fooval>\"}" - (1, chooseRep hasreps [TypeHtml]) @?= (1, (TypeHtml, res1)) - (2, chooseRep hasreps [TypeJson]) @?= (2, (TypeJson, res2)) - (3, chooseRep hasreps [TypeHtml, TypeJson]) @?= (3, (TypeHtml, res1)) - (4, chooseRep hasreps [TypeJson, TypeHtml]) @?= (4, (TypeJson, res2)) + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) + chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) + +caseChooseRepTemplateFile :: Assertion +caseChooseRepTemplateFile = do + let temp = "test/rep.st" + ho = toHtmlObject [ ("foo", toHtmlObject "") + , ("bar", toHtmlObject ["bar1", "bar2"]) + ] + hasreps = TemplateFile temp ho + res1 = cs "foo:<fooval>, bar:bar1bar2" + res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ + "\"foo\":\"<fooval>\"}" + chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) + chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) + chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) testSuite :: Test testSuite = testGroup "Yesod.Rep" [ testCase "caseChooseRep HtmlObject" caseChooseRepHO , testCase "caseChooseRep raw" caseChooseRepRaw , testCase "caseChooseRep Template" caseChooseRepTemplate + , testCase "caseChooseRep TemplateFile" caseChooseRepTemplateFile ] #endif diff --git a/test/rep.st b/test/rep.st new file mode 100644 index 00000000..127b7fd7 --- /dev/null +++ b/test/rep.st @@ -0,0 +1 @@ +foo:$o.foo$, bar:$o.bar$ From 603ebb3672c7d477a71e326b3389a39c30407571 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 23:48:39 +0200 Subject: [PATCH 074/624] hlint cleanup --- Hack/Middleware/CleanPath.hs | 2 +- Hack/Middleware/ClientSession.hs | 2 +- Yesod.hs | 1 - Yesod/Handler.hs | 4 ++-- Yesod/Helpers/Auth.hs | 1 - Yesod/Rep.hs | 7 ++++--- Yesod/Request.hs | 3 ++- 7 files changed, 10 insertions(+), 10 deletions(-) diff --git a/Hack/Middleware/CleanPath.hs b/Hack/Middleware/CleanPath.hs index 71c6973e..0fc1d82c 100644 --- a/Hack/Middleware/CleanPath.hs +++ b/Hack/Middleware/CleanPath.hs @@ -33,7 +33,7 @@ splitPath :: String -> Either String [String] splitPath s = let corrected = ats $ rds s in if corrected == s - then Right $ map decodeUrl $ filter (\l -> length l /= 0) + then Right $ map decodeUrl $ filter (not . null) $ splitOneOf "/" s else Left corrected diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs index 76a9f8cb..963fffe2 100644 --- a/Hack/Middleware/ClientSession.hs +++ b/Hack/Middleware/ClientSession.hs @@ -76,7 +76,7 @@ clientsession cnames key app env = do twentyMinutes = 20 * 60 let exp = fromIntegral twentyMinutes `addUTCTime` now let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp - let oldCookies = filter (\(k, _) -> not $ k `elem` map fst interceptHeaders) convertedCookies + let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies let newCookies = map (setCookie key exp formattedExp remoteHost') $ oldCookies ++ interceptHeaders let res' = res { headers = newCookies ++ headers' } diff --git a/Yesod.hs b/Yesod.hs index 6d492102..124c83d4 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- -- Module : Yesod diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 50d2ff16..4b997079 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -65,8 +65,8 @@ instance Monad (Handler yesod) where (headers, c) <- handler rr (headers', c') <- case c of - (HCError e) -> return $ ([], HCError e) - (HCSpecial e) -> return $ ([], HCSpecial e) + (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 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 96229ce6..e443ab18 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -37,7 +37,6 @@ import Control.Monad.Reader import Control.Monad.Attempt import Data.Maybe (fromMaybe) -import Control.Monad.Attempt data AuthResource = Check diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index ae5e4998..02952ca6 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -44,7 +44,8 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) +import Data.Function (on) #if TEST import Data.Object.Html hiding (testSuite) @@ -93,7 +94,7 @@ instance Show ContentType where show TypeOctet = "application/octet-stream" show (TypeOther s) = s instance Eq ContentType where - x == y = show x == show y + (==) = (==) `on` show newtype Content = Content { unContent :: ByteString } deriving (Eq, Show) @@ -115,7 +116,7 @@ class HasReps a where chooseRep :: a -> RepChooser chooseRep a ts = do let (ct, c) = - case catMaybes $ map helper ts of + case mapMaybe helper ts of (x:_) -> x [] -> case reps of [] -> error "Empty reps" diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 515f0388..e8263a74 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} -- Parameter String +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -274,7 +275,7 @@ instance Parameter a => Parameter [a] where Left l -> Left l Right rest' -> Right $ r : rest' -instance Parameter [Char] where +instance Parameter String where readParam = Right . paramValue instance Parameter Int where From 1f57f38aac023aa7e5c7cf1b40633780df7204a2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Dec 2009 01:26:57 +0200 Subject: [PATCH 075/624] Removed many of the special Show instances. Show should be for debug usage only. In general, using ConvertSuccess as a replacement. Also now replacing some String outputs with Text outputs. --- Data/Object/Html.hs | 7 ++++ Yesod/Definitions.hs | 13 ++++++ Yesod/Helpers/AtomFeed.hs | 88 ++++++++++++++++++++------------------- Yesod/Helpers/Auth.hs | 22 +++++----- Yesod/Helpers/Sitemap.hs | 61 +++++++++++++-------------- Yesod/Rep.hs | 33 ++++++++------- 6 files changed, 124 insertions(+), 100 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 8c289da7..5ec42cc3 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -50,6 +50,7 @@ data Html = | Text 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. @@ -63,6 +64,11 @@ toHtmlObject = toObject fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x fromHtmlObject = fromObject +instance ConvertSuccess String Html where + convertSuccess = Text . cs +instance ConvertSuccess Text Html where + convertSuccess = Text + instance ConvertSuccess Html Text where convertSuccess (Html t) = t convertSuccess (Text t) = encodeHtml t @@ -82,6 +88,7 @@ instance ConvertSuccess Html Text where , showAttribs as , cs ">" ] + convertSuccess (HtmlList l) = TL.concat $ map cs l instance ConvertSuccess Html HtmlDoc where convertSuccess h = HtmlDoc $ TL.concat diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 43f38aec..547ebadc 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -1,4 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Yesod.Definitions @@ -21,9 +23,20 @@ module Yesod.Definitions import qualified Hack import Data.Convertible.Text +import Control.Exception (Exception) +import Data.Typeable (Typeable) data Verb = Get | Put | Delete | Post deriving (Eq, Show) +instance ConvertAttempt String Verb where + convertAttempt "Get" = return Get + convertAttempt "Put" = return Put + convertAttempt "Delete" = return Delete + convertAttempt "Post" = return Post + convertAttempt s = failure $ InvalidVerb s +newtype InvalidVerb = InvalidVerb String + deriving (Show, Typeable) +instance Exception InvalidVerb instance ConvertSuccess Hack.RequestMethod Verb where convertSuccess Hack.PUT = Put diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 1305d4ec..c194faaf 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -20,7 +20,9 @@ module Yesod.Helpers.AtomFeed ) where import Yesod.Rep -import Data.Convertible.Text (cs) +import Data.Convertible.Text +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL import Data.Time.Clock import Web.Encodings @@ -34,7 +36,7 @@ data AtomFeed = AtomFeed } instance HasReps AtomFeed where reps = - [ (TypeAtom, return . cs . show) + [ (TypeAtom, return . cs) ] data AtomFeedEntry = AtomFeedEntry @@ -44,46 +46,48 @@ data AtomFeedEntry = AtomFeedEntry , atomEntryContent :: String } -instance Show AtomFeed where - show f = concat - [ "\n" - , "" - , "" - , encodeHtml $ atomTitle f - , "" - , "" - , "" - , "" - , formatW3 $ atomUpdated f - , "" - , "" - , encodeHtml $ atomLinkHome f - , "" - , concatMap show $ atomEntries f - , "" +instance ConvertSuccess AtomFeed Content where + convertSuccess = cs . (cs :: AtomFeed -> Text) +instance ConvertSuccess AtomFeed Text where + convertSuccess f = TL.concat + [ cs "\n" + , cs "" + , cs "" + , encodeHtml $ cs $ atomTitle f + , cs "" + , cs "" + , cs "" + , cs "" + , cs $ formatW3 $ atomUpdated f + , cs "" + , cs "" + , encodeHtml $ cs $ atomLinkHome f + , cs "" + , TL.concat $ map cs $ atomEntries f + , cs "" ] -instance Show AtomFeedEntry where - show e = concat - [ "" - , "" - , encodeHtml $ atomEntryLink e - , "" - , "" - , "" - , formatW3 $ atomEntryUpdated e - , "" - , "" - , encodeHtml $ atomEntryTitle e - , "" - , "" - , "" +instance ConvertSuccess AtomFeedEntry Text where + convertSuccess e = TL.concat + [ cs "" + , cs "" + , encodeHtml $ cs $ atomEntryLink e + , cs "" + , cs "" + , cs "" + , cs $ formatW3 $ atomEntryUpdated e + , cs "" + , cs "" + , encodeHtml $ cs $ atomEntryTitle e + , cs "" + , cs "" + , cs "" ] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e443ab18..087e65b0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -27,7 +27,7 @@ import qualified Web.Authenticate.OpenId as OpenId import Data.Enumerable import Data.Object.Html -import Data.Convertible.Text (cs) +import Data.Convertible.Text import Yesod import Yesod.Constants @@ -82,20 +82,22 @@ authResourcePattern LoginRpxnow = "/auth/login/rpxnow/" data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) instance Request OIDFormReq where parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" -instance Show OIDFormReq where - show (OIDFormReq Nothing _) = "" - show (OIDFormReq (Just s) _) = "

                " ++ encodeHtml s ++ - "

                " +instance ConvertSuccess OIDFormReq Html where + convertSuccess (OIDFormReq Nothing _) = cs "" + convertSuccess (OIDFormReq (Just s) _) = + Tag "p" [("class", "message")] [cs s] authOpenidForm :: Handler y HtmlObject authOpenidForm = do m@(OIDFormReq _ dest) <- parseRequest let html = - show m ++ - "" ++ - "OpenID: " ++ - "" ++ - "" + HtmlList + [ cs m + , Tag "form" [("method", "get"), ("action", "forward/")] + [ Tag "label" [("for", "openid")] [cs "OpenID: "] + , EmptyTag "input" [("type", "submit"), ("value", "Login")] + ] + ] case dest of Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index b6b6d337..e5cc9ab8 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap @@ -26,10 +27,10 @@ import Yesod.Definitions import Yesod.Handler import Yesod.Rep import Web.Encodings -import qualified Hack -import Yesod.Request import Data.Time (UTCTime) -import Data.Convertible.Text (cs) +import Data.Convertible.Text +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL import Yesod.Yesod data SitemapLoc = AbsLoc String | RelLoc String @@ -40,14 +41,14 @@ data SitemapChangeFreq = Always | Monthly | Yearly | Never -instance Show SitemapChangeFreq where - show Always = "always" - show Hourly = "hourly" - show Daily = "daily" - show Weekly = "weekly" - show Monthly = "monthly" - show Yearly = "yearly" - show Never = "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" data SitemapUrl = SitemapUrl { sitemapLoc :: SitemapLoc @@ -55,45 +56,41 @@ data SitemapUrl = SitemapUrl , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double } -data SitemapRequest = SitemapRequest String Int -data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] -instance Show SitemapResponse where -- FIXME very ugly, use Text instead - show (SitemapResponse (SitemapRequest host port) urls) = - "\n" ++ - "" ++ - concatMap helper urls ++ - "" +data SitemapResponse = SitemapResponse [SitemapUrl] Approot +instance ConvertSuccess SitemapResponse Content where + convertSuccess = cs . (cs :: SitemapResponse -> Text) +instance ConvertSuccess SitemapResponse Text where + convertSuccess (SitemapResponse urls (Approot ar)) = TL.concat + [ cs "\n" + , cs "" + , TL.concat $ map helper urls + , cs "" + ] where - prefix = "http://" ++ host ++ - case port of - 80 -> "" - _ -> ':' : show port - helper (SitemapUrl loc modTime freq pri) = concat + helper (SitemapUrl loc modTime freq pri) = cs $ concat [ "" , encodeHtml $ showLoc loc , "" , formatW3 modTime , "" - , show freq + , cs freq , "" , show pri , "" ] showLoc (AbsLoc s) = s - showLoc (RelLoc s) = prefix ++ s + showLoc (RelLoc s) = ar ++ s instance HasReps SitemapResponse where reps = - [ (TypeXml, return . cs . show) + [ (TypeXml, return . cs) ] -sitemap :: IO [SitemapUrl] -> Handler yesod SitemapResponse +sitemap :: Yesod yesod => IO [SitemapUrl] -> Handler yesod SitemapResponse sitemap urls' = do - env <- parseEnv - -- FIXME - let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env) + yesod <- getYesod urls <- liftIO urls' - return $ SitemapResponse req urls + return $ SitemapResponse urls $ approot yesod robots :: Yesod yesod => Handler yesod Plain robots = do diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 02952ca6..c0f96443 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -78,23 +78,24 @@ data ContentType = | TypeOgv | TypeOctet | TypeOther String -instance Show ContentType where - show TypeHtml = "text/html" - show TypePlain = "text/plain" - show TypeJson = "application/json" - show TypeXml = "text/xml" - show TypeAtom = "application/atom+xml" - show TypeJpeg = "image/jpeg" - show TypePng = "image/png" - show TypeGif = "image/gif" - show TypeJavascript = "text/javascript" - show TypeCss = "text/css" - show TypeFlv = "video/x-flv" - show TypeOgv = "video/ogg" - show TypeOctet = "application/octet-stream" - show (TypeOther s) = s + deriving (Show) +instance ConvertSuccess ContentType String where + convertSuccess TypeHtml = "text/html" + convertSuccess TypePlain = "text/plain" + convertSuccess TypeJson = "application/json" + 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" + convertSuccess TypeCss = "text/css" + convertSuccess TypeFlv = "video/x-flv" + convertSuccess TypeOgv = "video/ogg" + convertSuccess TypeOctet = "application/octet-stream" + convertSuccess (TypeOther s) = s instance Eq ContentType where - (==) = (==) `on` show + (==) = (==) `on` (cs :: ContentType -> String) newtype Content = Content { unContent :: ByteString } deriving (Eq, Show) From 9bf29bc335e18206997131048adbf0b40a86429b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Dec 2009 01:27:34 +0200 Subject: [PATCH 076/624] Add nolib compile flag. --- yesod.cabal | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/yesod.cabal b/yesod.cabal index 705a419e..dcec0e08 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,7 +16,15 @@ flag buildtests description: Build the executable to run unit tests 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, From 498ed1cee5d07b7e0ffc68f66069400722caef46 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Dec 2009 01:50:18 +0200 Subject: [PATCH 077/624] Beginning yaml -> resource map code --- Yesod/Resource.hs | 67 +++++++++++++++++++++++++++++++------ test/resource-patterns.yaml | 10 ++++++ 2 files changed, 67 insertions(+), 10 deletions(-) create mode 100644 test/resource-patterns.yaml diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index f339357b..337acffd 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- @@ -44,6 +45,9 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Convertible.Text +import Data.Object.Text +import Control.Monad ((<=<)) +import Text.Yaml #if TEST import Control.Monad (replicateM) @@ -60,18 +64,11 @@ data RPP = | Dynamic String | DynInt String | Slurp String -- ^ take up the rest of the pieces. must be last - deriving Eq + deriving (Eq, Show) -- | Resource Pattern newtype RP = RP { unRP :: [RPP] } - deriving Eq - -instance Show RP where - show = concatMap helper . unRP where - helper (Static s) = '/' : s - helper (Dynamic s) = '/' : '$' : s - helper (Slurp s) = '/' : '*' : s - helper (DynInt s) = '/' : '#' : s + deriving (Eq, Show) isSlurp :: RPP -> Bool isSlurp (Slurp _) = True @@ -85,6 +82,12 @@ instance ConvertSuccess String RP where helper ('*':rest) = Slurp rest helper ('#':rest) = DynInt rest helper x = Static x +instance ConvertSuccess RP String where + convertSuccess = concatMap helper . unRP where + helper (Static s) = '/' : s + helper (Dynamic s) = '/' : '$' : s + helper (Slurp s) = '/' : '*' : s + helper (DynInt s) = '/' : '#' : s type ResourcePattern = String @@ -172,6 +175,34 @@ validatePatterns (x:xs) = b' = unRP $ cs b in [(a, b) | overlaps a' b'] +data RPNode = RPNode RP VerbMap + deriving (Show, Eq) +data VerbMap = AllVerbs String | Verbs [(Verb, String)] + deriving (Show, Eq) +instance ConvertAttempt YamlDoc [RPNode] where + convertAttempt = fromTextObject <=< ca +instance FromObject RPNode Text Text where + fromObject = error "fromObject RPNode Text Text" + listFromObject = mapM helper <=< fromMapping where + helper :: (Text, TextObject) -> Attempt RPNode + helper (rp, rest) = do + verbMap <- fromTextObject rest + let rp' = cs (cs rp :: String) + return $ RPNode rp' verbMap +instance FromObject VerbMap Text Text where + fromObject (Scalar s) = return $ AllVerbs $ cs s + fromObject (Mapping m) = Verbs `fmap` mapM helper m where + helper :: (Text, TextObject) -> Attempt (Verb, String) + helper (v, Scalar f) = do + v' <- ca (cs v :: String) + return (v', cs f) + helper (_, x) = failure $ VerbMapNonScalar x + fromObject o = failure $ VerbMapSequence o +data RPNodeException = VerbMapNonScalar TextObject + | VerbMapSequence TextObject + deriving (Show, Typeable) +instance Exception RPNodeException + #if TEST ---- Testing testSuite :: Test @@ -182,6 +213,7 @@ testSuite = testGroup "Yesod.Resource" , testCase "validatePatterns" caseValidatePatterns , testProperty "show pattern" prop_showPattern , testCase "integers" caseIntegers + , testCase "read patterns from YAML" caseFromYaml ] deriving instance Arbitrary RP @@ -212,7 +244,7 @@ caseValidatePatterns = ] prop_showPattern :: RP -> Bool -prop_showPattern p = cs (show p) == p +prop_showPattern p = cs (cs p :: String) == p caseIntegers :: Assertion caseIntegers = do @@ -242,4 +274,19 @@ instance Arbitrary RPP where s <- replicateM size $ elements ['a'..'z'] return $ constr s coarbitrary = undefined + +caseFromYaml :: Assertion +caseFromYaml = do + contents <- readYamlDoc "test/resource-patterns.yaml" + let expected = + [ RPNode (cs "static/*filepath") $ AllVerbs "getStatic" + , RPNode (cs "page") $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] + , RPNode (cs "page/$page") $ Verbs [ (Get, "pageDetail") + , (Delete, "pageDelete") + , (Post, "pageUpdate") + ] + , RPNode (cs "user/#id") $ Verbs [(Get, "userInfo")] + ] + contents' <- fa $ ca contents + expected @=? contents' #endif diff --git a/test/resource-patterns.yaml b/test/resource-patterns.yaml new file mode 100644 index 00000000..3865b7a0 --- /dev/null +++ b/test/resource-patterns.yaml @@ -0,0 +1,10 @@ +/static/*filepath/: getStatic +/page/: + Get: pageIndex + Put: pageAdd +/page/$page/: + Get: pageDetail + Delete: pageDelete + Post: pageUpdate +/user/#id/: + Get: userInfo From f162ac54b33fe007e4a376f0dc079ed7fabe4c86 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 16 Dec 2009 20:27:38 +0200 Subject: [PATCH 078/624] Underlying libraries: remove To/FromObject --- Data/Object/Html.hs | 59 +++++++++++++++++++++++++++------------------ Yesod/Resource.hs | 16 ++++++------ yesod.cabal | 4 +-- 3 files changed, 45 insertions(+), 34 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 5ec42cc3..235ff927 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -3,8 +3,10 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} --- | An 'Html' data type and associated 'HtmlObject'. This has useful --- conversions in web development: +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +-- | 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 @@ -58,16 +60,31 @@ newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text } type HtmlObject = Object String Html -toHtmlObject :: ToObject x String Html => x -> HtmlObject -toHtmlObject = toObject +toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject +toHtmlObject = cs -fromHtmlObject :: FromObject x String Html => HtmlObject -> Attempt x -fromHtmlObject = fromObject +fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x +fromHtmlObject = ca instance ConvertSuccess String Html where convertSuccess = Text . cs instance ConvertSuccess Text Html where convertSuccess = Text +$(deriveAttempts + [ (''String, ''Html) + , (''Text, ''Html) + ]) + +showAttribs :: [(String, String)] -> Text +showAttribs = TL.concat . map helper where + helper :: (String, String) -> Text + helper (k, v) = TL.concat + [ cs " " + , encodeHtml $ cs k + , cs "=\"" + , encodeHtml $ cs v + , cs "\"" + ] instance ConvertSuccess Html Text where convertSuccess (Html t) = t @@ -90,6 +107,9 @@ instance ConvertSuccess Html Text where ] convertSuccess (HtmlList l) = TL.concat $ map cs l +instance ConvertSuccess Html String where + convertSuccess = cs . (cs :: Html -> Text) + instance ConvertSuccess Html HtmlDoc where convertSuccess h = HtmlDoc $ TL.concat [ cs "HtmlDoc (autogenerated)" @@ -119,25 +139,22 @@ instance ConvertSuccess HtmlObject JsonObject where instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) -instance ToObject Html String Html where - toObject = Scalar +$(deriveAttempts + [ (''Html, ''String) + , (''Html, ''Text) + , (''Html, ''HtmlDoc) + , (''Html, ''JsonScalar) + ]) + +$(deriveSuccessConvs ''String ''Html + [''String, ''Text] + [''Html, ''String, ''Text]) instance ToSElem HtmlObject where toSElem (Scalar h) = STR $ TL.unpack $ cs h toSElem (Sequence hs) = LI $ map toSElem hs toSElem (Mapping pairs) = SM $ Map.fromList $ map (second toSElem) pairs -showAttribs :: [(String, String)] -> Text -showAttribs = TL.concat . map helper where - helper :: (String, String) -> Text - helper (k, v) = TL.concat - [ cs " " - , encodeHtml $ cs k - , cs "=\"" - , encodeHtml $ cs v - , cs "\"" - ] - #if TEST caseHtmlToText :: Assertion caseHtmlToText = do @@ -183,7 +200,3 @@ testSuite = testGroup "Data.Object.Html" ] #endif - -instance ToObject Char String Html where - toObject c = Scalar $ Text $ cs [c] - listToObject = Scalar . Text . cs diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 337acffd..a608b2b8 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -44,10 +44,9 @@ import Language.Haskell.TH import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff -import Data.Convertible.Text import Data.Object.Text import Control.Monad ((<=<)) -import Text.Yaml +import Data.Object.Yaml #if TEST import Control.Monad (replicateM) @@ -181,23 +180,22 @@ data VerbMap = AllVerbs String | Verbs [(Verb, String)] deriving (Show, Eq) instance ConvertAttempt YamlDoc [RPNode] where convertAttempt = fromTextObject <=< ca -instance FromObject RPNode Text Text where - fromObject = error "fromObject RPNode Text Text" - listFromObject = mapM helper <=< fromMapping where +instance ConvertAttempt TextObject [RPNode] where + convertAttempt = mapM helper <=< fromMapping where helper :: (Text, TextObject) -> Attempt RPNode helper (rp, rest) = do verbMap <- fromTextObject rest let rp' = cs (cs rp :: String) return $ RPNode rp' verbMap -instance FromObject VerbMap Text Text where - fromObject (Scalar s) = return $ AllVerbs $ cs s - fromObject (Mapping m) = Verbs `fmap` mapM helper m where +instance ConvertAttempt TextObject VerbMap where + convertAttempt (Scalar s) = return $ AllVerbs $ cs s + convertAttempt (Mapping m) = Verbs `fmap` mapM helper m where helper :: (Text, TextObject) -> Attempt (Verb, String) helper (v, Scalar f) = do v' <- ca (cs v :: String) return (v', cs f) helper (_, x) = failure $ VerbMapNonScalar x - fromObject o = failure $ VerbMapSequence o + convertAttempt o = failure $ VerbMapSequence o data RPNodeException = VerbMapNonScalar TextObject | VerbMapSequence TextObject deriving (Show, Typeable) diff --git a/yesod.cabal b/yesod.cabal index dcec0e08..137fa631 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -36,7 +36,7 @@ library bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.0 && < 0.3, data-object >= 0.2.0 && < 0.3, - yaml >= 0.2.0 && < 0.3, + data-object-yaml >= 0.0.0 && < 0.1, enumerable >= 0.0.3 && < 0.1, directory >= 1 && < 1.1, transformers >= 0.1.4.0 && < 0.2, @@ -44,7 +44,7 @@ library control-monad-attempt >= 0.0.0 && < 0.1, syb, text >= 0.5 && < 0.6, - convertible-text >= 0.0.1 && < 0.1, + convertible-text >= 0.2.0 && < 0.3, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6, containers >= 0.2.0.1 && < 0.3, From aedb43fe6902e0f8a90f5406e5814a5005fbc19d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 10:13:46 +0200 Subject: [PATCH 079/624] Initial quasi-quoting of resources complete, still ugly code --- Yesod/Definitions.hs | 5 ++- Yesod/Resource.hs | 91 +++++++++++++++++++++++++++++++++++++++++- test/quasi-resource.hs | 38 ++++++++++++++++++ 3 files changed, 131 insertions(+), 3 deletions(-) create mode 100644 test/quasi-resource.hs diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 547ebadc..f77d8fcc 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -25,9 +25,12 @@ import qualified Hack import Data.Convertible.Text import Control.Exception (Exception) import Data.Typeable (Typeable) +import Language.Haskell.TH.Syntax data Verb = Get | Put | Delete | Post - deriving (Eq, Show) + deriving (Eq, Show, Enum, Bounded) +instance Lift Verb where + lift = return . ConE . mkName . show instance ConvertAttempt String Verb where convertAttempt "Get" = return Get convertAttempt "Put" = return Put diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index a608b2b8..0e41b4c4 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Resource @@ -27,6 +28,14 @@ module Yesod.Resource , checkPatternsTH , validatePatterns , checkPatterns + , checkRPNodes + , rpnodesTH + , rpnodesTHCheck + , rpnodesQuasi + , RPNode (..) + , VerbMap (..) + , RP (..) + , RPP (..) #if TEST -- * Testing , testSuite @@ -35,11 +44,12 @@ module Yesod.Resource import Data.List.Split (splitOn) import Yesod.Definitions -import Data.List (intercalate) +import Data.List (intercalate, nub) import Data.Char (isDigit) import Control.Monad (when) -import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -201,6 +211,70 @@ data RPNodeException = VerbMapNonScalar TextObject deriving (Show, Typeable) instance Exception RPNodeException +checkRPNodes :: (MonadFailure OverlappingPatterns m, + MonadFailure RepeatedVerb m + ) + => [RPNode] + -> m [RPNode] +checkRPNodes nodes = do + checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly + mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes + return nodes + where + checkVerbMap (AllVerbs _) = return () + checkVerbMap (Verbs vs) = + let vs' = map fst vs + res = nub vs' == vs' + in if res then return () else failure $ RepeatedVerb vs + +newtype RepeatedVerb = RepeatedVerb [(Verb, String)] + deriving (Show, Typeable) +instance Exception RepeatedVerb + +rpnodesTHCheck :: [RPNode] -> Q Exp +rpnodesTHCheck nodes = do + nodes' <- runIO $ checkRPNodes nodes + rpnodesTH nodes' + +rpnodesTH :: [RPNode] -> Q Exp +rpnodesTH = fmap ListE . mapM lift +instance Lift RPNode where + lift (RPNode rp vm) = do + rp' <- lift rp + vm' <- lift vm + return $ TupE [rp', vm'] +instance Lift RP where + lift (RP rpps) = do + rpps' <- lift rpps + return $ ConE (mkName "RP") `AppE` rpps' +instance Lift RPP where + lift (Static s) = + return $ ConE (mkName "Static") `AppE` (LitE $ StringL s) + lift (Dynamic s) = + return $ ConE (mkName "Dynamic") `AppE` (LitE $ StringL s) + lift (DynInt s) = + return $ ConE (mkName "DynInt") `AppE` (LitE $ StringL s) + lift (Slurp s) = + return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) +instance Lift VerbMap where + lift (AllVerbs s) = return $ ListE $ map helper [minBound..maxBound] + where + helper :: Verb -> Exp + helper v = TupE [(helper2 v), LitE $ StringL s] + helper2 :: Verb -> Exp + helper2 = ConE . mkName . show + lift (Verbs v) = lift v + +strToExp :: String -> Q Exp +strToExp s = do + let yd :: YamlDoc + yd = YamlDoc $ cs s + rpnodes <- runIO $ convertAttemptWrap yd + rpnodesTHCheck rpnodes + +rpnodesQuasi :: QuasiQuoter +rpnodesQuasi = QuasiQuoter strToExp undefined + #if TEST ---- Testing testSuite :: Test @@ -212,6 +286,7 @@ testSuite = testGroup "Yesod.Resource" , testProperty "show pattern" prop_showPattern , testCase "integers" caseIntegers , testCase "read patterns from YAML" caseFromYaml + , testCase "checkRPNodes" caseCheckRPNodes ] deriving instance Arbitrary RP @@ -287,4 +362,16 @@ caseFromYaml = do ] contents' <- fa $ ca contents expected @=? contents' + +caseCheckRPNodes :: Assertion +caseCheckRPNodes = do + good' <- readYamlDoc "test/resource-patterns.yaml" + good <- fa $ ca good' + Just good @=? checkRPNodes good + let bad1 = [ RPNode (cs "foo/bar") $ AllVerbs "foo" + , RPNode (cs "$foo/bar") $ AllVerbs "bar" + ] + Nothing @=? checkRPNodes bad1 + let bad2 = [RPNode (cs "") $ Verbs [(Get, "foo"), (Get, "bar")]] + Nothing @=? checkRPNodes bad2 #endif diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs new file mode 100644 index 00000000..9013ce86 --- /dev/null +++ b/test/quasi-resource.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod.Resource +import Yesod.Definitions +import Data.Convertible.Text + +handler :: [(RP, [(Verb, [Char])])] +handler = + $(rpnodesTHCheck + [ RPNode (cs "static/*filepath") $ AllVerbs "getStatic" + , RPNode (cs "page") $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] + , RPNode (cs "page/$page") $ Verbs [ (Get, "pageDetail") + , (Delete, "pageDelete") + , (Post, "pageUpdate") + ] + , RPNode (cs "user/#id") $ Verbs [(Get, "userInfo")] + ]) + +handler2 :: [(RP, [(Verb, [Char])])] +handler2 = [$rpnodesQuasi| +/static/*filepath/: getStatic +/page/: + Get: pageIndex + Put: pageAdd +/page/$page/: + Get: pageDetail + Delete: pageDelete + Post: pageUpdate +/user/#id/: + Get: userInfo +|] + +main :: IO () +main = do + print handler + print handler2 + print $ handler == handler2 From cb6f497c03b0d21a2ce35f2cbdf637eb18fb4012 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 10:36:10 +0200 Subject: [PATCH 080/624] VerbMap now becomes a function in quasi-quoting --- Yesod/Resource.hs | 19 +++++++++++++------ test/quasi-resource.hs | 43 ++++++++++++++++++++++++------------------ 2 files changed, 38 insertions(+), 24 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 0e41b4c4..28806d7e 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -257,13 +257,20 @@ instance Lift RPP where lift (Slurp s) = return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) instance Lift VerbMap where - lift (AllVerbs s) = return $ ListE $ map helper [minBound..maxBound] + lift (AllVerbs s) = + return $ LamE [VarP $ mkName "_FIXMEverb"] $ VarE $ mkName s + lift (Verbs vs) = + return $ LamE [VarP $ mkName "verb"] + $ CaseE (VarE $ mkName "verb") + $ map helper vs ++ [whenNotFound] where - helper :: Verb -> Exp - helper v = TupE [(helper2 v), LitE $ StringL s] - helper2 :: Verb -> Exp - helper2 = ConE . mkName . show - lift (Verbs v) = lift v + helper :: (Verb, String) -> Match + helper (v, f) = + Match (ConP (mkName $ show v) []) + (NormalB $ VarE $ mkName f) + [] + whenNotFound :: Match + whenNotFound = Match WildP (NormalB $ VarE $ mkName "notFound") [] strToExp :: String -> Q Exp strToExp s = do diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 9013ce86..44cee4d7 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -1,24 +1,33 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} -import Yesod.Resource -import Yesod.Definitions -import Data.Convertible.Text +import Yesod +import Yesod.Rep -handler :: [(RP, [(Verb, [Char])])] -handler = - $(rpnodesTHCheck - [ RPNode (cs "static/*filepath") $ AllVerbs "getStatic" - , RPNode (cs "page") $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] - , RPNode (cs "page/$page") $ Verbs [ (Get, "pageDetail") - , (Delete, "pageDelete") - , (Post, "pageUpdate") - ] - , RPNode (cs "user/#id") $ Verbs [(Get, "userInfo")] - ]) +data MyYesod = MyYesod -handler2 :: [(RP, [(Verb, [Char])])] -handler2 = [$rpnodesQuasi| +instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" + +getStatic :: Handler MyYesod RepChooser +getStatic = undefined +pageIndex :: Handler MyYesod RepChooser +pageIndex = undefined +pageAdd :: Handler MyYesod RepChooser +pageAdd = undefined +pageDetail :: Handler MyYesod RepChooser +pageDetail = undefined +pageDelete :: Handler MyYesod RepChooser +pageDelete = undefined +pageUpdate :: Handler MyYesod RepChooser +pageUpdate = undefined +userInfo :: Handler MyYesod RepChooser +userInfo = undefined + +instance Show (Verb -> Handler MyYesod RepChooser) where + show _ = "verb -> handler" +handler :: [(RP, Verb -> Handler MyYesod RepChooser)] +handler = [$rpnodesQuasi| /static/*filepath/: getStatic /page/: Get: pageIndex @@ -34,5 +43,3 @@ handler2 = [$rpnodesQuasi| main :: IO () main = do print handler - print handler2 - print $ handler == handler2 From f6221dacc9460c1b480ff76ada875410c662c504 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 11:20:35 +0200 Subject: [PATCH 081/624] Quasi-quoting generates a single function --- Yesod/Handler.hs | 10 +++++++++- Yesod/Resource.hs | 33 ++++++++++++++++++++++++++++++--- Yesod/Response.hs | 2 ++ test/quasi-resource.hs | 37 +++++++++++++++++++++++++++---------- 4 files changed, 68 insertions(+), 14 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 4b997079..e10c81ad 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -42,6 +42,9 @@ import Control.Applicative import Control.Monad.Writer import Control.Monad.Attempt +import System.IO +import Data.Object.Html + --import Data.Typeable ------ Handler monad @@ -98,11 +101,16 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - Response _ hs ct c <- runHandler (eh e) eh rr y cts + Response _ hs ct c <- runHandler (eh e) specialEh rr y cts return $ Response (getStatus e) hs ct c Right a -> do (ct, c) <- a cts return $ Response 200 headers ct c + +specialEh :: ErrorResult -> Handler yesod RepChooser +specialEh er = do + liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er + return $ chooseRep $ toHtmlObject "Internal server error" {- FIXME class ToHandler a where toHandler :: a -> Handler diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 28806d7e..2ba20f68 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -57,6 +57,7 @@ import Data.Attempt -- for failure stuff import Data.Object.Text import Control.Monad ((<=<)) import Data.Object.Yaml +import Yesod.Handler #if TEST import Control.Monad (replicateM) @@ -107,6 +108,11 @@ data CheckPatternReturn = | DynamicMatch (String, String) | NoMatch +checkPatternBool :: RP -> Resource -> Bool +checkPatternBool rp r = case checkPattern rp r of + Nothing -> False + _ -> True + checkPattern :: RP -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP @@ -234,10 +240,30 @@ instance Exception RepeatedVerb rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do nodes' <- runIO $ checkRPNodes nodes - rpnodesTH nodes' + res <- rpnodesTH nodes' + -- For debugging purposes runIO $ putStrLn $ pprint res + return res + +notFoundVerb :: Verb -> Handler yesod a +notFoundVerb _verb = notFound rpnodesTH :: [RPNode] -> Q Exp -rpnodesTH = fmap ListE . mapM lift +rpnodesTH ns = do + b <- helper ns + nfv <- [|notFoundVerb|] + let b' = b ++ [(NormalG $ VarE $ mkName "otherwise", nfv)] + return $ LamE [VarP $ mkName "resource"] + $ CaseE (TupE []) [Match WildP (GuardedB b') []] + where + helper :: [RPNode] -> Q [(Guard, Exp)] + helper nodes = mapM helper2 nodes + helper2 :: RPNode -> Q (Guard, Exp) + helper2 (RPNode rp vm) = do + rp' <- lift rp + cpb <- [|checkPatternBool|] + let g = cpb `AppE` rp' `AppE` VarE (mkName "resource") + vm' <- lift vm + return (NormalG g, vm') instance Lift RPNode where lift (RPNode rp vm) = do rp' <- lift rp @@ -258,7 +284,8 @@ instance Lift RPP where return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) instance Lift VerbMap where lift (AllVerbs s) = - return $ LamE [VarP $ mkName "_FIXMEverb"] $ VarE $ mkName s + return $ LamE [VarP $ mkName "verb"] + $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb") lift (Verbs vs) = return $ LamE [VarP $ mkName "verb"] $ CaseE (VarE $ mkName "verb") diff --git a/Yesod/Response.hs b/Yesod/Response.hs index bf548de0..d5904229 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -53,6 +53,7 @@ import Data.Generics import Control.Exception (Exception) data Response = Response Int [Header] ContentType Content + deriving Show -- | Abnormal return codes. data ErrorResult = @@ -81,6 +82,7 @@ data Header = AddCookie Int String String | DeleteCookie String | Header String String + deriving (Eq, Show) -- | Convert Header to a key/value pair. toPair :: Header -> IO (String, String) diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 44cee4d7..d30f97f7 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -4,29 +4,32 @@ import Yesod import Yesod.Rep +import Data.Object.Html data MyYesod = MyYesod instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" -getStatic :: Handler MyYesod RepChooser -getStatic = undefined +getStatic :: Verb -> Handler MyYesod RepChooser +getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v] pageIndex :: Handler MyYesod RepChooser -pageIndex = undefined +pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser -pageAdd = undefined +pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] pageDetail :: Handler MyYesod RepChooser -pageDetail = undefined +pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"] pageDelete :: Handler MyYesod RepChooser -pageDelete = undefined +pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"] pageUpdate :: Handler MyYesod RepChooser -pageUpdate = undefined +pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"] userInfo :: Handler MyYesod RepChooser -userInfo = undefined +userInfo = return $ chooseRep $ toHtmlObject ["userInfo"] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" -handler :: [(RP, Verb -> Handler MyYesod RepChooser)] +instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where + show _ = "resource -> verb -> handler" +handler :: Resource -> Verb -> Handler MyYesod RepChooser handler = [$rpnodesQuasi| /static/*filepath/: getStatic /page/: @@ -40,6 +43,20 @@ handler = [$rpnodesQuasi| Get: userInfo |] +ph :: Handler MyYesod RepChooser -> IO () +ph h = do + let eh e = return $ chooseRep $ toHtmlObject $ show e + rr = error "No raw request" + y = MyYesod + cts = [TypeHtml] + res <- runHandler h eh rr y cts + print res + main :: IO () main = do - print handler + ph $ handler ["static", "foo", "bar", "baz"] Get + ph $ handler ["foo", "bar", "baz"] Get + ph $ handler ["page"] Get + ph $ handler ["user"] Get + ph $ handler ["user", "five"] Get + ph $ handler ["user", "5"] Get From e5276cae4606eabb44d4e15b17ff67886bc8c843 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 14:35:39 +0200 Subject: [PATCH 082/624] URL params passed as args, chooseRep called --- Yesod/Resource.hs | 109 ++++++++++++++++++++++++++++++++--------- Yesod/Yesod.hs | 4 +- test/quasi-resource.hs | 20 ++++---- 3 files changed, 98 insertions(+), 35 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 2ba20f68..7b67028e 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -36,6 +36,7 @@ module Yesod.Resource , VerbMap (..) , RP (..) , RPP (..) + , UrlParam (..) #if TEST -- * Testing , testSuite @@ -44,7 +45,7 @@ module Yesod.Resource import Data.List.Split (splitOn) import Yesod.Definitions -import Data.List (intercalate, nub) +import Data.List (nub) import Data.Char (isDigit) import Control.Monad (when) @@ -58,6 +59,8 @@ import Data.Object.Text import Control.Monad ((<=<)) import Data.Object.Yaml import Yesod.Handler +import Data.Maybe (fromJust) +import Yesod.Rep #if TEST import Control.Monad (replicateM) @@ -101,11 +104,10 @@ instance ConvertSuccess RP String where type ResourcePattern = String -type SMap = [(String, String)] - data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) + | DynIntMatch (String, Int) | NoMatch checkPatternBool :: RP -> Resource -> Bool @@ -113,7 +115,10 @@ checkPatternBool rp r = case checkPattern rp r of Nothing -> False _ -> True -checkPattern :: RP -> Resource -> Maybe SMap +checkPatternUP :: RP -> Resource -> [UrlParam] +checkPatternUP rp r = map snd $ fromJust (checkPattern rp r) + +checkPattern :: RP -> Resource -> Maybe [(String, UrlParam)] checkPattern = checkPatternPieces . unRP checkPatternsTH :: Bool -> [ResourcePattern] -> Q Exp @@ -121,15 +126,14 @@ checkPatternsTH toCheck patterns = do runIO $ when toCheck $ checkPatterns patterns [|return ()|] -checkPatternPieces :: [RPP] -> Resource -> Maybe SMap +checkPatternPieces :: [RPP] -> Resource -> Maybe [(String, UrlParam)] checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do let rp' = init rp (r1, r2) = splitAt (length rp') r smap <- checkPatternPieces rp' r1 - let slurpValue = intercalate "/" r2 - Slurp slurpKey = last rp - return $ (slurpKey, slurpValue) : smap + let Slurp slurpKey = last rp + return $ (slurpKey, SlurpParam r2) : smap | length rp /= length r = Nothing | otherwise = combine [] $ zipWith checkPattern' rp r @@ -138,14 +142,17 @@ checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch checkPattern' (Dynamic x) y = DynamicMatch (x, y) checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" checkPattern' (DynInt x) y - | all isDigit y = DynamicMatch (x, y) + | all isDigit y = DynIntMatch (x, read y) | otherwise = NoMatch -combine :: SMap -> [CheckPatternReturn] -> Maybe SMap +combine :: [(String, UrlParam)] + -> [CheckPatternReturn] + -> Maybe [(String, UrlParam)] combine s [] = Just $ reverse s combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest -combine s (DynamicMatch x:rest) = combine (x:s) rest +combine s (DynamicMatch (x, y):rest) = combine ((x, StringParam y):s) rest +combine s (DynIntMatch (x, y):rest) = combine ((x, IntParam y):s) rest overlaps :: [RPP] -> [RPP] -> Bool overlaps [] [] = True @@ -261,13 +268,67 @@ rpnodesTH ns = do helper2 (RPNode rp vm) = do rp' <- lift rp cpb <- [|checkPatternBool|] - let g = cpb `AppE` rp' `AppE` VarE (mkName "resource") - vm' <- lift vm - return (NormalG g, vm') + let r' = VarE $ mkName "resource" + let g = cpb `AppE` rp' `AppE` r' + vm' <- liftVerbMap vm $ countParams rp + vm'' <- applyUrlParams rp r' vm' + let vm''' = LamE [VarP $ mkName "verb"] vm'' + return (NormalG g, vm''') + +data UrlParam = SlurpParam { slurpParam :: [String] } + | StringParam { stringParam :: String } + | IntParam { intParam :: Int } + deriving Show -- FIXME remove + +getUrlParam :: RP -> Resource -> Int -> UrlParam +getUrlParam rp r i = checkPatternUP rp r !! i + +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 -> Int +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 (Dynamic _: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' + +countParams :: RP -> Int +countParams (RP rpps) = helper 0 rpps where + helper i [] = i + helper i (Static _:rest) = helper i rest + helper i (_:rest) = helper (i + 1) rest + instance Lift RPNode where lift (RPNode rp vm) = do rp' <- lift rp - vm' <- lift vm + vm' <- liftVerbMap vm $ countParams rp return $ TupE [rp', vm'] instance Lift RP where lift (RP rpps) = do @@ -282,13 +343,12 @@ instance Lift RPP where return $ ConE (mkName "DynInt") `AppE` (LitE $ StringL s) lift (Slurp s) = return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) -instance Lift VerbMap where - lift (AllVerbs s) = - return $ LamE [VarP $ mkName "verb"] - $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb") - lift (Verbs vs) = - return $ LamE [VarP $ mkName "verb"] - $ CaseE (VarE $ mkName "verb") +liftVerbMap :: VerbMap -> Int -> Q Exp +liftVerbMap (AllVerbs s) _ = do + cr <- [|(.) (fmap chooseRep)|] + return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) +liftVerbMap (Verbs vs) params = + return $ CaseE (VarE $ mkName "verb") $ map helper vs ++ [whenNotFound] where helper :: (Verb, String) -> Match @@ -297,7 +357,10 @@ instance Lift VerbMap where (NormalB $ VarE $ mkName f) [] whenNotFound :: Match - whenNotFound = Match WildP (NormalB $ VarE $ mkName "notFound") [] + whenNotFound = + Match WildP + (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound") + [] strToExp :: String -> Q Exp strToExp s = do diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b794b74f..1afe1ff6 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,7 +17,7 @@ import Yesod.Utils import Data.Maybe (fromMaybe) import Data.Convertible.Text import Web.Encodings -import Control.Arrow ((***)) +import Control.Arrow ((***), second) import Control.Monad (when) import qualified Hack @@ -118,7 +118,7 @@ lookupHandlers r = helper handlers where helper [] = Nothing helper ((rps, v):rest) = case checkPattern (cs rps) r of - Just up -> Just (v, up) + Just up -> Just (v, map (second show) up) Nothing -> helper rest envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index d30f97f7..3e8ace12 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -10,20 +10,20 @@ data MyYesod = MyYesod instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" -getStatic :: Verb -> Handler MyYesod RepChooser -getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v] +getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject +getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] pageIndex :: Handler MyYesod RepChooser pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] -pageDetail :: Handler MyYesod RepChooser -pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"] -pageDelete :: Handler MyYesod RepChooser -pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"] -pageUpdate :: Handler MyYesod RepChooser -pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"] -userInfo :: Handler MyYesod RepChooser -userInfo = return $ chooseRep $ toHtmlObject ["userInfo"] +pageDetail :: String -> Handler MyYesod RepChooser +pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] +pageDelete :: String -> Handler MyYesod RepChooser +pageDelete s = return $ chooseRep $ toHtmlObject ["pageDelete", s] +pageUpdate :: String -> Handler MyYesod RepChooser +pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] +userInfo :: Int -> Handler MyYesod RepChooser +userInfo i = return $ chooseRep $ toHtmlObject ["userInfo", show i] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" From ec2d63ce07512722b191e67280c45cf8619bd65b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 14:47:37 +0200 Subject: [PATCH 083/624] Compiling again --- Yesod/Helpers/Static.hs | 14 ++++++---- Yesod/Request.hs | 26 ++++------------- Yesod/Resource.hs | 4 +++ Yesod/Yesod.hs | 62 ++++------------------------------------- 4 files changed, 22 insertions(+), 84 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index c7c06bc8..f0d98293 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -28,6 +28,7 @@ import Control.Applicative ((<$>)) import Yesod import Yesod.Rep +import Data.List (intercalate) type FileLookup = FilePath -> IO (Maybe B.ByteString) @@ -40,13 +41,14 @@ fileLookupDir dir fp = do then Just <$> B.readFile fp' else return Nothing -serveStatic :: FileLookup -> Verb -> Handler y [(ContentType, Content)] -serveStatic fl Get = getStatic fl -serveStatic _ _ = notFound +serveStatic :: FileLookup -> Verb -> [String] + -> Handler y [(ContentType, Content)] +serveStatic fl Get fp = getStatic fl fp +serveStatic _ _ _ = notFound -getStatic :: FileLookup -> Handler y [(ContentType, Content)] -getStatic fl = do - fp <- urlParam "filepath" -- FIXME check for .. +getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] +getStatic fl fp' = do + let fp = intercalate "/" fp' -- FIXME check for . or .. content <- liftIO $ fl fp case content of Nothing -> notFound diff --git a/Yesod/Request.hs b/Yesod/Request.hs index e8263a74..01cdf535 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -33,7 +33,6 @@ module Yesod.Request , MonadRequestReader (..) , getParam , postParam - , urlParam , anyParam , cookieParam , identifier @@ -76,7 +75,6 @@ import Control.Arrow ((***)) data ParamType = GetParam | PostParam - | UrlParam | CookieParam deriving (Eq, Show) @@ -158,11 +156,6 @@ getParam = genParam getParams GetParam postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a postParam = genParam postParams PostParam --- | Parse a value passed in the URL and extracted using rewrite. --- (FIXME: link to rewrite section.) -urlParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a -urlParam = genParam urlParams UrlParam - -- | Parse a value passed as a GET, POST or URL parameter. anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a anyParam = genParam anyParams PostParam -- FIXME @@ -217,7 +210,6 @@ type PathInfo = [String] -- | The raw information passed through Hack, cleaned up a bit. data RawRequest = RawRequest { rawPathInfo :: PathInfo - , rawUrlParams :: [(ParamName, ParamValue)] , rawGetParams :: [(ParamName, ParamValue)] , rawPostParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] @@ -241,17 +233,9 @@ postParams rr name = map snd . rawPostParams $ rr --- | All URL paramater values (see rewriting) with the given name. -urlParams :: RawRequest -> ParamName -> [ParamValue] -urlParams rr name = map snd - . filter (\x -> name == fst x) - . rawUrlParams - $ rr - --- | All GET, POST and URL paramater values (see rewriting) with the given name. +-- | All GET and POST paramater values (see rewriting) with the given name. anyParams :: RawRequest -> ParamName -> [ParamValue] -anyParams req name = urlParams req name ++ - getParams req name ++ +anyParams req name = getParams req name ++ postParams req name -- | All cookies with the given name. @@ -325,8 +309,8 @@ notBlank rp = "" -> invalidParam (paramType rp) (paramName rp) "Required field" s -> return s -instance ConvertSuccess ([(ParamName, ParamValue)], Hack.Env) RawRequest where - convertSuccess (urlParams', env) = +instance ConvertSuccess Hack.Env RawRequest where + convertSuccess env = let (Right rawPieces) = splitPath $ Hack.pathInfo env gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] clength = tryLookup "0" "Content-Length" $ Hack.http env @@ -339,4 +323,4 @@ instance ConvertSuccess ([(ParamName, ParamValue)], Hack.Env) RawRequest where rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] langs = ["en"] -- FIXME - in RawRequest rawPieces urlParams' gets' posts cookies' files env langs + in RawRequest rawPieces gets' posts cookies' files env langs diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 7b67028e..3f0f8645 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -60,7 +60,11 @@ import Control.Monad ((<=<)) import Data.Object.Yaml import Yesod.Handler import Data.Maybe (fromJust) +#if TEST +import Yesod.Rep hiding (testSuite) +#else import Yesod.Rep +#endif #if TEST import Control.Monad (replicateM) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 1afe1ff6..048cdad8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -10,15 +10,11 @@ import Yesod.Response import Yesod.Request import Yesod.Constants import Yesod.Definitions -import Yesod.Resource import Yesod.Handler import Yesod.Utils import Data.Maybe (fromMaybe) import Data.Convertible.Text -import Web.Encodings -import Control.Arrow ((***), second) -import Control.Monad (when) import qualified Hack import Hack.Middleware.CleanPath @@ -28,7 +24,8 @@ import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride class Yesod a where - handlers :: [(ResourcePattern, [(Verb, Handler a RepChooser)])] + -- | Please use the Quasi-Quoter, you\'ll be happier. FIXME more info. + handlers :: Resource -> Verb -> Handler a RepChooser -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -38,10 +35,6 @@ class Yesod a where errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler - -- | Whether or not we should check for overlapping resource names. - checkOverlaps :: a -> Bool - checkOverlaps = const True - -- | An absolute URL to the root of the application. approot :: a -> Approot @@ -65,19 +58,8 @@ defaultErrorHandler (InternalError e) = [ ("Internal server error", e) ] --- | For type signature reasons. -handlers' :: Yesod y => y -> - [(ResourcePattern, [(Verb, Handler y RepChooser)])] -handlers' _ = handlers - toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do - -- FIXME figure out a way to do this check compile-time - when (checkOverlaps a) $ checkPatterns $ map fst $ handlers' a - toHackAppUnchecked a env - -toHackAppUnchecked :: Yesod y => y -> Hack.Application -toHackAppUnchecked a env = do key <- encryptKey a let app' = toHackApp' a middleware = @@ -94,12 +76,9 @@ toHackApp' :: Yesod y => y -> Hack.Application toHackApp' y env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env - (handler, urlParams') = fromMaybe (notFound, []) $ do - (verbPairs, urlParams'') <- lookupHandlers resource - let verb = cs $ Hack.requestMethod env - handler'' <- lookup verb verbPairs - return (handler'', urlParams'') - rr = envToRawRequest urlParams' env + verb = cs $ Hack.requestMethod env + handler = handlers resource verb + rr = cs env res <- runHandler handler errorHandler rr y types let langs = ["en"] -- FIXME responseToHackResponse langs res @@ -107,34 +86,3 @@ toHackApp' y env = do httpAccept :: Hack.Env -> [ContentType] httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" . lookup "Accept" . Hack.http - -lookupHandlers :: Yesod y - => Resource - -> Maybe - ( [(Verb, Handler y RepChooser)] - , [(ParamName, ParamValue)] - ) -lookupHandlers r = helper handlers where - helper [] = Nothing - helper ((rps, v):rest) = - case checkPattern (cs rps) r of - Just up -> Just (v, map (second show) up) - Nothing -> helper rest - -envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest -envToRawRequest urlParams' env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env - ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env - (posts, files) = map (cs *** cs) *** map (cs *** convertFileInfo) - $ parsePost ctype clength - $ Hack.hackInput env - rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - langs = ["en"] -- FIXME - in RawRequest rawPieces urlParams' gets' posts cookies' files env langs - -convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c -convertFileInfo (FileInfo a b c) = - FileInfo (convertSuccess a) (convertSuccess b) c From f5cb44bff1a1eee6c6edfcd1ea4c2dfd2b670f95 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 14:58:07 +0200 Subject: [PATCH 084/624] Slimmed down Resource exports --- Yesod/Resource.hs | 66 ++++++++++++++++++------------------------ test/quasi-resource.hs | 2 +- 2 files changed, 29 insertions(+), 39 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 3f0f8645..25cef18f 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -23,20 +23,8 @@ -- --------------------------------------------------------- module Yesod.Resource - ( ResourcePattern - , checkPattern - , checkPatternsTH - , validatePatterns - , checkPatterns - , checkRPNodes - , rpnodesTH - , rpnodesTHCheck - , rpnodesQuasi - , RPNode (..) - , VerbMap (..) - , RP (..) - , RPP (..) - , UrlParam (..) + ( resources + , resourcesNoCheck #if TEST -- * Testing , testSuite @@ -48,7 +36,6 @@ import Yesod.Definitions import Data.List (nub) import Data.Char (isDigit) -import Control.Monad (when) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote @@ -73,6 +60,7 @@ import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck +import Control.Monad (when) #endif -- | Resource Pattern Piece @@ -125,11 +113,6 @@ checkPatternUP rp r = map snd $ fromJust (checkPattern rp r) checkPattern :: RP -> Resource -> Maybe [(String, UrlParam)] checkPattern = checkPatternPieces . unRP -checkPatternsTH :: Bool -> [ResourcePattern] -> Q Exp -checkPatternsTH toCheck patterns = do - runIO $ when toCheck $ checkPatterns patterns - [|return ()|] - checkPatternPieces :: [RPP] -> Resource -> Maybe [(String, UrlParam)] checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do @@ -262,7 +245,8 @@ rpnodesTH :: [RPNode] -> Q Exp rpnodesTH ns = do b <- helper ns nfv <- [|notFoundVerb|] - let b' = b ++ [(NormalG $ VarE $ mkName "otherwise", nfv)] + ow <- [|otherwise|] + let b' = b ++ [(NormalG ow, nfv)] return $ LamE [VarP $ mkName "resource"] $ CaseE (TupE []) [Match WildP (GuardedB b') []] where @@ -337,16 +321,21 @@ instance Lift RPNode where instance Lift RP where lift (RP rpps) = do rpps' <- lift rpps - return $ ConE (mkName "RP") `AppE` rpps' + rp <- [|RP|] + return $ rp `AppE` rpps' instance Lift RPP where - lift (Static s) = - return $ ConE (mkName "Static") `AppE` (LitE $ StringL s) - lift (Dynamic s) = - return $ ConE (mkName "Dynamic") `AppE` (LitE $ StringL s) - lift (DynInt s) = - return $ ConE (mkName "DynInt") `AppE` (LitE $ StringL s) - lift (Slurp s) = - return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) + lift (Static s) = do + st <- [|Static|] + return $ st `AppE` (LitE $ StringL s) + lift (Dynamic s) = do + d <- [|Dynamic|] + 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) liftVerbMap :: VerbMap -> Int -> Q Exp liftVerbMap (AllVerbs s) _ = do cr <- [|(.) (fmap chooseRep)|] @@ -366,15 +355,16 @@ liftVerbMap (Verbs vs) params = (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound") [] -strToExp :: String -> Q Exp -strToExp s = do - let yd :: YamlDoc - yd = YamlDoc $ cs s - rpnodes <- runIO $ convertAttemptWrap yd - rpnodesTHCheck rpnodes +strToExp :: Bool -> String -> Q Exp +strToExp toCheck s = do + rpnodes <- runIO $ convertAttemptWrap $ YamlDoc $ cs s + (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes -rpnodesQuasi :: QuasiQuoter -rpnodesQuasi = QuasiQuoter strToExp undefined +resources :: QuasiQuoter +resources = QuasiQuoter (strToExp True) undefined + +resourcesNoCheck :: QuasiQuoter +resourcesNoCheck = QuasiQuoter (strToExp False) undefined #if TEST ---- Testing diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 3e8ace12..c2d10594 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -30,7 +30,7 @@ instance Show (Verb -> Handler MyYesod RepChooser) where instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where show _ = "resource -> verb -> handler" handler :: Resource -> Verb -> Handler MyYesod RepChooser -handler = [$rpnodesQuasi| +handler = [$resources| /static/*filepath/: getStatic /page/: Get: pageIndex From ac450c9513ad6b0ad7334d3ac5e8655a9c2bf6b5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 18:33:00 +0200 Subject: [PATCH 085/624] Cleaned up a good bit of Yesod.Resource --- Yesod/Resource.hs | 276 ++++++++++++++++++++++++----------------- test/quasi-resource.hs | 3 +- 2 files changed, 163 insertions(+), 116 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 25cef18f..5b129ada 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -43,7 +43,7 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Object.Text -import Control.Monad ((<=<)) +import Control.Monad ((<=<), unless) import Data.Object.Yaml import Yesod.Handler import Data.Maybe (fromJust) @@ -52,6 +52,7 @@ import Yesod.Rep hiding (testSuite) #else import Yesod.Rep #endif +import Control.Arrow #if TEST import Control.Monad (replicateM) @@ -63,10 +64,16 @@ import Test.QuickCheck import Control.Monad (when) #endif +resources :: QuasiQuoter +resources = QuasiQuoter (strToExp True) undefined + +resourcesNoCheck :: QuasiQuoter +resourcesNoCheck = QuasiQuoter (strToExp False) undefined + -- | Resource Pattern Piece data RPP = Static String - | Dynamic String + | DynStr String | DynInt String | Slurp String -- ^ take up the rest of the pieces. must be last deriving (Eq, Show) @@ -79,76 +86,96 @@ isSlurp :: RPP -> Bool isSlurp (Slurp _) = True isSlurp _ = False -instance ConvertSuccess String RP where - convertSuccess = RP . map helper . filter (not . null) .splitOn "/" - where - helper :: String -> RPP - helper ('$':rest) = Dynamic rest - helper ('*':rest) = Slurp rest - helper ('#':rest) = DynInt rest - helper x = Static x +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 (Dynamic s) = '/' : '$' : s + helper (DynStr s) = '/' : '$' : s helper (Slurp s) = '/' : '*' : s helper (DynInt s) = '/' : '#' : s type ResourcePattern = String -data CheckPatternReturn = - StaticMatch - | DynamicMatch (String, String) - | DynIntMatch (String, Int) - | NoMatch - -checkPatternBool :: RP -> Resource -> Bool -checkPatternBool rp r = case checkPattern rp r of +-- | 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 -checkPatternUP :: RP -> Resource -> [UrlParam] -checkPatternUP rp r = map snd $ fromJust (checkPattern rp r) +-- | 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) -checkPattern :: RP -> Resource -> Maybe [(String, UrlParam)] -checkPattern = checkPatternPieces . unRP - -checkPatternPieces :: [RPP] -> Resource -> Maybe [(String, UrlParam)] -checkPatternPieces rp r +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 <- checkPatternPieces rp' r1 + smap <- doPatternPiecesMatch rp' r1 let Slurp slurpKey = last rp return $ (slurpKey, SlurpParam r2) : smap - | length rp /= length r = Nothing - | otherwise = combine [] $ zipWith checkPattern' rp r + | length rp /= length r = failure NoMatch + | otherwise = concat `fmap` sequence (zipWith doesPatternPieceMatch rp r) -checkPattern' :: RPP -> String -> CheckPatternReturn -checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch -checkPattern' (Dynamic x) y = DynamicMatch (x, y) -checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" -checkPattern' (DynInt x) y - | all isDigit y = DynIntMatch (x, read y) - | otherwise = NoMatch - -combine :: [(String, UrlParam)] - -> [CheckPatternReturn] - -> Maybe [(String, UrlParam)] -combine s [] = Just $ reverse s -combine _ (NoMatch:_) = Nothing -combine s (StaticMatch:rest) = combine s rest -combine s (DynamicMatch (x, y):rest) = combine ((x, StringParam y):s) rest -combine s (DynIntMatch (x, y):rest) = combine ((x, IntParam y):s) rest +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 (Dynamic _:x) (_:y) = overlaps x y -overlaps (_:x) (Dynamic _:y) = overlaps x y +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 @@ -163,26 +190,27 @@ data OverlappingPatterns = deriving (Show, Typeable) instance Exception OverlappingPatterns -checkPatterns :: MonadFailure OverlappingPatterns f - => [ResourcePattern] - -> f () -checkPatterns patterns = - case validatePatterns patterns of - [] -> return () - x -> failure $ OverlappingPatterns x +getAllPairs :: [x] -> [(x, x)] +getAllPairs [] = [] +getAllPairs [_] = [] +getAllPairs (x:xs) = map ((,) x) xs ++ getAllPairs xs -validatePatterns :: [ResourcePattern] - -> [(ResourcePattern, ResourcePattern)] -validatePatterns [] = [] -validatePatterns (x:xs) = - concatMap (validatePatterns' x) xs ++ validatePatterns xs where - validatePatterns' :: ResourcePattern - -> ResourcePattern - -> [(ResourcePattern, ResourcePattern)] - validatePatterns' a b = - let a' = unRP $ cs a - b' = unRP $ cs b - in [(a, b) | overlaps a' b'] +-- | Ensures that we have a consistent set of resource patterns. +checkPatterns :: (MonadFailure OverlappingPatterns m, + MonadFailure InvalidResourcePattern m) + => [ResourcePattern] + -> m [RP] -- FIXME +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 VerbMap deriving (Show, Eq) @@ -195,7 +223,7 @@ instance ConvertAttempt TextObject [RPNode] where helper :: (Text, TextObject) -> Attempt RPNode helper (rp, rest) = do verbMap <- fromTextObject rest - let rp' = cs (cs rp :: String) + rp' <- readRP $ cs rp return $ RPNode rp' verbMap instance ConvertAttempt TextObject VerbMap where convertAttempt (Scalar s) = return $ AllVerbs $ cs s @@ -212,7 +240,8 @@ data RPNodeException = VerbMapNonScalar TextObject instance Exception RPNodeException checkRPNodes :: (MonadFailure OverlappingPatterns m, - MonadFailure RepeatedVerb m + MonadFailure RepeatedVerb m, + MonadFailure InvalidResourcePattern m ) => [RPNode] -> m [RPNode] @@ -225,7 +254,7 @@ checkRPNodes nodes = do checkVerbMap (Verbs vs) = let vs' = map fst vs res = nub vs' == vs' - in if res then return () else failure $ RepeatedVerb vs + in unless res $ failure $ RepeatedVerb vs newtype RepeatedVerb = RepeatedVerb [(Verb, String)] deriving (Show, Typeable) @@ -234,28 +263,25 @@ instance Exception RepeatedVerb rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do nodes' <- runIO $ checkRPNodes nodes - res <- rpnodesTH nodes' -- For debugging purposes runIO $ putStrLn $ pprint res - return res + rpnodesTH nodes' notFoundVerb :: Verb -> Handler yesod a notFoundVerb _verb = notFound rpnodesTH :: [RPNode] -> Q Exp rpnodesTH ns = do - b <- helper ns + b <- mapM helper ns nfv <- [|notFoundVerb|] 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 nodes = mapM helper2 nodes - helper2 :: RPNode -> Q (Guard, Exp) - helper2 (RPNode rp vm) = do + helper :: RPNode -> Q (Guard, Exp) + helper (RPNode rp vm) = do rp' <- lift rp - cpb <- [|checkPatternBool|] + cpb <- [|doesPatternMatch|] let r' = VarE $ mkName "resource" let g = cpb `AppE` rp' `AppE` r' vm' <- liftVerbMap vm $ countParams rp @@ -266,10 +292,9 @@ rpnodesTH ns = do data UrlParam = SlurpParam { slurpParam :: [String] } | StringParam { stringParam :: String } | IntParam { intParam :: Int } - deriving Show -- FIXME remove getUrlParam :: RP -> Resource -> Int -> UrlParam -getUrlParam rp r i = checkPatternUP rp r !! i +getUrlParam rp = (!!) . paramsFromMatchingPattern rp getUrlParamSlurp :: RP -> Resource -> Int -> [String] getUrlParamSlurp rp r = slurpParam . getUrlParam rp r @@ -288,7 +313,7 @@ applyUrlParams rp@(RP rpps) r f = do helper :: Int -> [RPP] -> Q [Exp] helper _ [] = return [] helper i (Static _:rest) = helper i rest - helper i (Dynamic _:rest) = do + helper i (DynStr _:rest) = do rp' <- lift rp str <- [|getUrlParamString|] i' <- lift i @@ -327,8 +352,8 @@ instance Lift RPP where lift (Static s) = do st <- [|Static|] return $ st `AppE` (LitE $ StringL s) - lift (Dynamic s) = do - d <- [|Dynamic|] + lift (DynStr s) = do + d <- [|DynStr|] return $ d `AppE` (LitE $ StringL s) lift (DynInt s) = do d <- [|DynInt|] @@ -360,12 +385,6 @@ strToExp toCheck s = do rpnodes <- runIO $ convertAttemptWrap $ YamlDoc $ cs s (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes -resources :: QuasiQuoter -resources = QuasiQuoter (strToExp True) undefined - -resourcesNoCheck :: QuasiQuoter -resourcesNoCheck = QuasiQuoter (strToExp False) undefined - #if TEST ---- Testing testSuite :: Test @@ -373,28 +392,37 @@ testSuite = testGroup "Yesod.Resource" [ testCase "non-overlap" caseOverlap1 , testCase "overlap" caseOverlap2 , testCase "overlap-slurp" caseOverlap3 - , testCase "validatePatterns" caseValidatePatterns + -- FIXME, testCase "validatePatterns" caseValidatePatterns , testProperty "show pattern" prop_showPattern , testCase "integers" caseIntegers , testCase "read patterns from YAML" caseFromYaml , testCase "checkRPNodes" caseCheckRPNodes + , testCase "readRP" caseReadRP ] -deriving instance Arbitrary RP +instance Arbitrary RP where + coarbitrary = undefined + 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 = assert $ not $ overlaps - (unRP $ cs "/foo/$bar/") - (unRP $ cs "/foo/baz/$bin") +caseOverlap1 = caseOverlap' "/foo/$bar/" "/foo/baz/$bin" False caseOverlap2 :: Assertion -caseOverlap2 = assert $ overlaps - (unRP $ cs "/foo/bar") - (unRP $ cs "/foo/$baz") +caseOverlap2 = caseOverlap' "/foo/bar" "/foo/$baz" True caseOverlap3 :: Assertion -caseOverlap3 = assert $ overlaps - (unRP $ cs "/foo/bar/baz/$bin") - (unRP $ cs "*slurp") +caseOverlap3 = caseOverlap' "/foo/bar/baz/$bin" "*slurp" True +{- FIXME rewrite this test caseValidatePatterns :: Assertion caseValidatePatterns = let p1 = cs "/foo/bar/baz" @@ -402,13 +430,14 @@ caseValidatePatterns = p3 = cs "/bin" p4 = cs "/bin/boo" p5 = cs "/bin/*slurp" - in validatePatterns [p1, p2, p3, p4, p5] @?= + in validatePatterns [p1, p2, p3, p4, p5] @?= Just [ (p1, p2) , (p4, p5) ] +-} prop_showPattern :: RP -> Bool -prop_showPattern p = cs (cs p :: String) == p +prop_showPattern p = readRP (cs p) == Just p caseIntegers :: Assertion caseIntegers = do @@ -420,8 +449,10 @@ caseIntegers = do p6 = "/foo/*slurp/" checkOverlap :: String -> String -> Bool -> IO () checkOverlap a b c = do - let res1 = overlaps (unRP $ cs a) (unRP $ cs b) - let res2 = overlaps (unRP $ cs b) (unRP $ cs a) + 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 @@ -433,7 +464,7 @@ caseIntegers = do instance Arbitrary RPP where arbitrary = do - constr <- elements [Static, Dynamic, Slurp, DynInt] + constr <- elements [Static, DynStr, Slurp, DynInt] size <- elements [1..10] s <- replicateM size $ elements ['a'..'z'] return $ constr s @@ -442,14 +473,18 @@ instance Arbitrary RPP where caseFromYaml :: Assertion caseFromYaml = do contents <- readYamlDoc "test/resource-patterns.yaml" + rp1 <- readRP "static/*filepath" + rp2 <- readRP "page" + rp3 <- readRP "page/$page" + rp4 <- readRP "user/#id" let expected = - [ RPNode (cs "static/*filepath") $ AllVerbs "getStatic" - , RPNode (cs "page") $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] - , RPNode (cs "page/$page") $ Verbs [ (Get, "pageDetail") - , (Delete, "pageDelete") - , (Post, "pageUpdate") - ] - , RPNode (cs "user/#id") $ Verbs [(Get, "userInfo")] + [ RPNode rp1 $ AllVerbs "getStatic" + , RPNode rp2 $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] + , RPNode rp3 $ Verbs [ (Get, "pageDetail") + , (Delete, "pageDelete") + , (Post, "pageUpdate") + ] + , RPNode rp4 $ Verbs [(Get, "userInfo")] ] contents' <- fa $ ca contents expected @=? contents' @@ -459,10 +494,23 @@ caseCheckRPNodes = do good' <- readYamlDoc "test/resource-patterns.yaml" good <- fa $ ca good' Just good @=? checkRPNodes good - let bad1 = [ RPNode (cs "foo/bar") $ AllVerbs "foo" - , RPNode (cs "$foo/bar") $ AllVerbs "bar" + rp1 <- readRP "foo/bar" + rp2 <- readRP "$foo/bar" + let bad1 = [ RPNode rp1 $ AllVerbs "foo" + , RPNode rp2 $ AllVerbs "bar" ] Nothing @=? checkRPNodes bad1 - let bad2 = [RPNode (cs "") $ Verbs [(Get, "foo"), (Get, "bar")]] + rp' <- readRP "" + let bad2 = [RPNode rp' $ Verbs [(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 diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index c2d10594..4ee87fce 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} @@ -45,7 +44,7 @@ handler = [$resources| ph :: Handler MyYesod RepChooser -> IO () ph h = do - let eh e = return $ chooseRep $ toHtmlObject $ show e + let eh = return . chooseRep . toHtmlObject . show rr = error "No raw request" y = MyYesod cts = [TypeHtml] From a7cfa5f6675410a771c20eb24df7bed5f63ffa6c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 17 Dec 2009 19:27:03 +0200 Subject: [PATCH 086/624] Added two basic examples --- Yesod.hs | 6 ++++++ Yesod/Helpers/Auth.hs | 3 --- Yesod/Helpers/Sitemap.hs | 6 ++++-- Yesod/Resource.hs | 29 +++++++++++++++++------------ Yesod/Yesod.hs | 2 ++ examples/hellotemplate.lhs | 22 ++++++++++++++++++++++ examples/helloworld.lhs | 19 +++++++++++++++++++ examples/template.html | 26 ++++++++++++++++++++++++++ test/quasi-resource.hs | 14 ++++++-------- yesod.cabal | 29 +++++++++++++++++++++++++++++ 10 files changed, 131 insertions(+), 25 deletions(-) create mode 100644 examples/hellotemplate.lhs create mode 100644 examples/helloworld.lhs create mode 100644 examples/template.html diff --git a/Yesod.hs b/Yesod.hs index 124c83d4..6aa47888 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,6 +19,9 @@ module Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource + , module Data.Object.Html + , module Yesod.Rep + , module Data.Convertible.Text , Application ) where @@ -29,3 +32,6 @@ import Yesod.Definitions import Yesod.Handler import Yesod.Resource import Hack (Application) +import Yesod.Rep +import Data.Object.Html +import Data.Convertible.Text diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 087e65b0..60e3f319 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -26,9 +26,6 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Data.Enumerable -import Data.Object.Html -import Data.Convertible.Text - import Yesod import Yesod.Constants diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index e5cc9ab8..bc0694f2 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -86,13 +86,15 @@ instance HasReps SitemapResponse where [ (TypeXml, return . cs) ] -sitemap :: Yesod yesod => IO [SitemapUrl] -> Handler yesod SitemapResponse +sitemap :: YesodApproot yesod + => IO [SitemapUrl] + -> Handler yesod SitemapResponse sitemap urls' = do yesod <- getYesod urls <- liftIO urls' return $ SitemapResponse urls $ approot yesod -robots :: Yesod yesod => Handler yesod Plain +robots :: YesodApproot yesod => Handler yesod Plain robots = do yesod <- getYesod return $ plain $ "Sitemap: " ++ unApproot (approot yesod) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 5b129ada..b92df293 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -38,6 +38,10 @@ import Data.Char (isDigit) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote +{- Debugging +import Language.Haskell.TH.Ppr +import System.IO +-} import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -263,7 +267,10 @@ instance Exception RepeatedVerb rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do nodes' <- runIO $ checkRPNodes nodes - -- For debugging purposes runIO $ putStrLn $ pprint res + {- For debugging purposes + rpnodesTH nodes' >>= runIO . putStrLn . pprint + runIO $ hFlush stdout + -} rpnodesTH nodes' notFoundVerb :: Verb -> Handler yesod a @@ -338,11 +345,6 @@ countParams (RP rpps) = helper 0 rpps where helper i (Static _:rest) = helper i rest helper i (_:rest) = helper (i + 1) rest -instance Lift RPNode where - lift (RPNode rp vm) = do - rp' <- lift rp - vm' <- liftVerbMap vm $ countParams rp - return $ TupE [rp', vm'] instance Lift RP where lift (RP rpps) = do rpps' <- lift rpps @@ -365,14 +367,17 @@ liftVerbMap :: VerbMap -> Int -> Q Exp liftVerbMap (AllVerbs s) _ = do cr <- [|(.) (fmap chooseRep)|] return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) -liftVerbMap (Verbs vs) params = - return $ CaseE (VarE $ mkName "verb") - $ map helper vs ++ [whenNotFound] +liftVerbMap (Verbs vs) params = do + cr0 <- [|fmap chooseRep|] + cr1 <- [|(.) (fmap chooseRep)|] + let cr = if params == 0 then cr0 else cr1 + return $ CaseE (VarE $ mkName "verb") + $ map (helper cr) vs ++ [whenNotFound] where - helper :: (Verb, String) -> Match - helper (v, f) = + helper :: Exp -> (Verb, String) -> Match + helper cr (v, f) = Match (ConP (mkName $ show v) []) - (NormalB $ VarE $ mkName f) + (NormalB $ cr `AppE` VarE (mkName f)) [] whenNotFound :: Match whenNotFound = diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 048cdad8..6e48385f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,6 +1,7 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) + , YesodApproot (..) , toHackApp ) where @@ -35,6 +36,7 @@ class Yesod a where errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler +class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs new file mode 100644 index 00000000..869f06c6 --- /dev/null +++ b/examples/hellotemplate.lhs @@ -0,0 +1,22 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod +import Hack.Handler.SimpleServer + +data HelloWorld = HelloWorld +instance Yesod HelloWorld where + handlers = [$resources| +/: + Get: helloWorld +|] + +helloWorld :: Handler HelloWorld TemplateFile +helloWorld = return $ TemplateFile "examples/template.html" $ cs + [ ("title", "Hello world!") + , ("content", "Hey look!! I'm <auto escaped>!") + ] + +main :: IO () +main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +\end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs new file mode 100644 index 00000000..de8a90de --- /dev/null +++ b/examples/helloworld.lhs @@ -0,0 +1,19 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod +import Hack.Handler.SimpleServer + +data HelloWorld = HelloWorld +instance Yesod HelloWorld where + handlers = [$resources| +/: + Get: helloWorld +|] + +helloWorld :: Handler HelloWorld HtmlObject +helloWorld = return $ cs "Hello world!" + +main :: IO () +main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +\end{code} diff --git a/examples/template.html b/examples/template.html new file mode 100644 index 00000000..8d1b393d --- /dev/null +++ b/examples/template.html @@ -0,0 +1,26 @@ +<!DOCTYPE html> +<html> + <head> + <meta charset="utf-8"> + <title>$o.title$ + + + +
                + $o.content$ +
                + + diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 4ee87fce..46faac53 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -2,8 +2,6 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Yesod.Rep -import Data.Object.Html data MyYesod = MyYesod @@ -11,18 +9,18 @@ instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] -pageIndex :: Handler MyYesod RepChooser -pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] +pageIndex :: Handler MyYesod HtmlObject +pageIndex = return $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] pageDetail :: String -> Handler MyYesod RepChooser pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] -pageDelete :: String -> Handler MyYesod RepChooser -pageDelete s = return $ chooseRep $ toHtmlObject ["pageDelete", s] +pageDelete :: String -> Handler MyYesod HtmlObject +pageDelete s = return $ toHtmlObject ["pageDelete", s] pageUpdate :: String -> Handler MyYesod RepChooser pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] -userInfo :: Int -> Handler MyYesod RepChooser -userInfo i = return $ chooseRep $ toHtmlObject ["userInfo", show i] +userInfo :: Int -> Handler MyYesod HtmlObject +userInfo i = return $ toHtmlObject ["userInfo", show i] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" diff --git a/yesod.cabal b/yesod.cabal index 137fa631..be2ebd03 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,6 +16,10 @@ flag buildtests description: Build the executable to run unit tests default: False +flag buildsamples + description: Build the executable to run unit tests + default: False + flag nolib description: Skip building of the library. default: False @@ -87,3 +91,28 @@ executable runtests Buildable: False ghc-options: -Wall main-is: runtests.hs + +executable quasi-test + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: test/quasi-resource.hs + +executable helloworld + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + build-depends: hack-handler-simpleserver >= 0.2.0 && < 0.3 + main-is: examples/helloworld.lhs + +executable hellotemplate + if flag(buildsamples) + Buildable: True + else + Buildable: False + ghc-options: -Wall + main-is: examples/hellotemplate.lhs From 3661d96f0b8171514caade7b2e647dc6003797a7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 17 Dec 2009 19:55:29 +0200 Subject: [PATCH 087/624] Removed some dependencies --- Yesod/Handler.hs | 3 ++- Yesod/Helpers/Auth.hs | 14 +------------- yesod.cabal | 3 --- 3 files changed, 3 insertions(+), 17 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e10c81ad..78cd5d43 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -39,8 +39,9 @@ import Yesod.Rep import Control.Exception hiding (Handler) import Control.Applicative -import Control.Monad.Writer +import Control.Monad.Trans import Control.Monad.Attempt +import Control.Monad (liftM, ap) import System.IO import Data.Object.Html diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 60e3f319..971ded13 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -24,13 +24,11 @@ import qualified Hack import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId -import Data.Enumerable import Yesod import Yesod.Constants import Control.Applicative ((<$>), Applicative (..)) -import Control.Monad.Reader import Control.Monad.Attempt import Data.Maybe (fromMaybe) @@ -42,17 +40,7 @@ data AuthResource = | OpenidForward | OpenidComplete | LoginRpxnow - deriving Show - -instance Enumerable AuthResource where - enumerate = - [ Check - , Logout - , Openid - , OpenidForward - , OpenidComplete - , LoginRpxnow - ] + deriving (Show, Eq, Enum, Bounded) newtype RpxnowApiKey = RpxnowApiKey String diff --git a/yesod.cabal b/yesod.cabal index be2ebd03..2abb4387 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -35,16 +35,13 @@ library hack == 2009.10.30, split >= 0.1.1 && < 0.2, authenticate >= 0.4.0 && < 0.5, - data-default >= 0.2 && < 0.3, predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.0 && < 0.3, data-object >= 0.2.0 && < 0.3, data-object-yaml >= 0.0.0 && < 0.1, - enumerable >= 0.0.3 && < 0.1, directory >= 1 && < 1.1, transformers >= 0.1.4.0 && < 0.2, - monads-fd >= 0.0.0.1 && < 0.1, control-monad-attempt >= 0.0.0 && < 0.1, syb, text >= 0.5 && < 0.6, From f27f6cd7e3a876958d337803e08d6915e5383593 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 20 Dec 2009 22:04:50 +0200 Subject: [PATCH 088/624] Fixed liftVerbMap wrt applyUrlParams --- Yesod/Resource.hs | 55 +++++++++++++++++++++--------------------- test/quasi-resource.hs | 9 +++++++ 2 files changed, 37 insertions(+), 27 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index b92df293..88bf8333 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -203,7 +203,7 @@ getAllPairs (x:xs) = map ((,) x) xs ++ getAllPairs xs checkPatterns :: (MonadFailure OverlappingPatterns m, MonadFailure InvalidResourcePattern m) => [ResourcePattern] - -> m [RP] -- FIXME + -> m [RP] checkPatterns rpss = do rps <- mapM (runKleisli $ Kleisli return &&& Kleisli readRP) rpss let overlaps' = concatMap helper $ getAllPairs rps @@ -291,10 +291,9 @@ rpnodesTH ns = do cpb <- [|doesPatternMatch|] let r' = VarE $ mkName "resource" let g = cpb `AppE` rp' `AppE` r' - vm' <- liftVerbMap vm $ countParams rp - vm'' <- applyUrlParams rp r' vm' - let vm''' = LamE [VarP $ mkName "verb"] vm'' - return (NormalG g, vm''') + vm' <- liftVerbMap vm r' rp + let vm'' = LamE [VarP $ mkName "verb"] vm' + return (NormalG g, vm'') data UrlParam = SlurpParam { slurpParam :: [String] } | StringParam { stringParam :: String } @@ -339,12 +338,6 @@ applyUrlParams rp@(RP rpps) r f = do rest' <- helper (i + 1) rest return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest' -countParams :: RP -> Int -countParams (RP rpps) = helper 0 rpps where - helper i [] = i - helper i (Static _:rest) = helper i rest - helper i (_:rest) = helper (i + 1) rest - instance Lift RP where lift (RP rpps) = do rpps' <- lift rpps @@ -363,26 +356,34 @@ instance Lift RPP where lift (Slurp s) = do sl <- [|Slurp|] return $ sl `AppE` (LitE $ StringL s) -liftVerbMap :: VerbMap -> Int -> Q Exp -liftVerbMap (AllVerbs s) _ = do - cr <- [|(.) (fmap chooseRep)|] - return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) -liftVerbMap (Verbs vs) params = do - cr0 <- [|fmap chooseRep|] - cr1 <- [|(.) (fmap chooseRep)|] - let cr = if params == 0 then cr0 else cr1 - return $ CaseE (VarE $ mkName "verb") - $ map (helper cr) vs ++ [whenNotFound] +liftVerbMap :: VerbMap -> Exp -> RP -> Q Exp +liftVerbMap (AllVerbs 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''' +liftVerbMap (Verbs vs) r rp = do + cr <- [|fmap chooseRep|] + vs' <- mapM (helper cr) vs + return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound] where - helper :: Exp -> (Verb, String) -> Match - helper cr (v, f) = - Match (ConP (mkName $ show v) []) - (NormalB $ cr `AppE` VarE (mkName f)) - [] + helper :: Exp -> (Verb, String) -> Q Match + helper cr (v, fName) = do + let f = VarE $ mkName fName + f' <- applyUrlParams rp r f + let f'' = cr `AppE` f' + let con = ConP (mkName $ show v) [] + return $ Match con (NormalB f'') [] whenNotFound :: Match whenNotFound = Match WildP - (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound") + (NormalB $ VarE $ mkName "notFound") [] strToExp :: Bool -> String -> Q Exp diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 46faac53..c0f03e3a 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -21,6 +21,10 @@ pageUpdate :: String -> Handler MyYesod RepChooser pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] userInfo :: Int -> Handler MyYesod HtmlObject userInfo i = return $ toHtmlObject ["userInfo", show i] +userVariable :: Int -> String -> Handler MyYesod HtmlObject +userVariable i s = return $ toHtmlObject ["userVariable", show i, s] +userPage :: Int -> [String] -> Handler MyYesod HtmlObject +userPage i p = return $ toHtmlObject ["userPage", show i, show p] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" @@ -38,6 +42,10 @@ handler = [$resources| Post: pageUpdate /user/#id/: Get: userInfo +/user/#id/profile/$variable/: + Get: userVariable +/user/#id/page/*page/: + Get: userPage |] ph :: Handler MyYesod RepChooser -> IO () @@ -57,3 +65,4 @@ main = do ph $ handler ["user"] Get ph $ handler ["user", "five"] Get ph $ handler ["user", "5"] Get + ph $ handler ["user", "5", "profile", "email"] Get From 7ab3b406db2d13e78dfddd0c878c166aa8b10596 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Dec 2009 16:05:48 +0200 Subject: [PATCH 089/624] Added fact example and fixed a few bugs. Added the Static and StaticFile reps. Special responses set headers properly (redirect works). --- Yesod/Handler.hs | 6 ++++-- Yesod/Rep.hs | 18 ++++++++++++++++++ Yesod/Resource.hs | 6 +----- examples/fact.html | 12 ++++++++++++ examples/fact.lhs | 27 +++++++++++++++++++++++++++ yesod.cabal | 8 ++++++++ 6 files changed, 70 insertions(+), 7 deletions(-) create mode 100644 examples/fact.html create mode 100644 examples/fact.lhs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 78cd5d43..214f4832 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -39,7 +40,7 @@ import Yesod.Rep import Control.Exception hiding (Handler) import Control.Applicative -import Control.Monad.Trans +import "transformers" Control.Monad.Trans import Control.Monad.Attempt import Control.Monad (liftM, ap) @@ -103,7 +104,8 @@ runHandler (Handler handler) eh rr y cts = do case contents' of Left e -> do Response _ hs ct c <- runHandler (eh e) specialEh rr y cts - return $ Response (getStatus e) hs ct c + let hs' = hs ++ getHeaders e + return $ Response (getStatus e) hs' ct c Right a -> do (ct, c) <- a cts return $ Response 200 headers ct c diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index c0f96443..68ad4e42 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -37,12 +37,15 @@ module Yesod.Rep , plain , Template (..) , TemplateFile (..) + , Static (..) + , StaticFile (..) #if TEST , testSuite #endif ) where import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) import Data.Maybe (mapMaybe) import Data.Function (on) @@ -134,6 +137,9 @@ instance HasReps RepChooser where reps = error "reps of RepChooser" chooseRep = id +instance HasReps () where + reps = [(TypePlain, const $ return $ cs "")] + instance HasReps [(ContentType, Content)] where reps = error "reps of [(ContentType, Content)]" chooseRep a cts = return $ @@ -170,6 +176,18 @@ instance HasReps TemplateFile where return $ cs $ unJsonDoc $ cs ho) ] +data Static = Static ContentType ByteString +instance HasReps Static where + reps = error "reps of Static" + chooseRep (Static ct bs) _ = return (ct, Content bs) + +data StaticFile = StaticFile ContentType FilePath +instance HasReps StaticFile where + reps = error "reps of StaticFile" + chooseRep (StaticFile ct fp) _ = do + bs <- BL.readFile fp + return (ct, Content bs) + -- Useful instances of HasReps instance HasReps HtmlObject where reps = diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 88bf8333..56d1caa6 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -51,11 +51,7 @@ import Control.Monad ((<=<), unless) import Data.Object.Yaml import Yesod.Handler import Data.Maybe (fromJust) -#if TEST -import Yesod.Rep hiding (testSuite) -#else -import Yesod.Rep -#endif +import Yesod.Rep (chooseRep) import Control.Arrow #if TEST diff --git a/examples/fact.html b/examples/fact.html new file mode 100644 index 00000000..db3e135f --- /dev/null +++ b/examples/fact.html @@ -0,0 +1,12 @@ + + + + Factorials + + +
                +

                +

                +
                + + diff --git a/examples/fact.lhs b/examples/fact.lhs new file mode 100644 index 00000000..e41c6ae3 --- /dev/null +++ b/examples/fact.lhs @@ -0,0 +1,27 @@ +\begin{code} +{-# LANGUAGE QuasiQuotes #-} + +import Yesod +import Hack.Handler.SimpleServer + +data Fact = Fact +instance Yesod Fact where + handlers = [$resources| +/: + Get: index +/#num: + Get: fact +/fact: + Get: factRedirect +|] + +index = return $ StaticFile TypeHtml "examples/fact.html" +fact i = return $ toHtmlObject $ show $ product [1..fromIntegral i] +factRedirect = do + i <- getParam "num" + redirect $ "../" ++ i ++ "/" + return () + +main :: IO () +main = putStrLn "Running..." >> run 3000 (toHackApp Fact) +\end{code} diff --git a/yesod.cabal b/yesod.cabal index 2abb4387..22725226 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -113,3 +113,11 @@ executable hellotemplate 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 From 921dbf9b6c63433884a998a4559200903080bd0c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Dec 2009 16:15:35 +0200 Subject: [PATCH 090/624] Ajaxified fact example --- examples/fact.html | 20 +++++++++++++++++++- examples/fact.lhs | 5 ++++- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/examples/fact.html b/examples/fact.html index db3e135f..4f849dd4 100644 --- a/examples/fact.html +++ b/examples/fact.html @@ -2,11 +2,29 @@ Factorials + + +

                -

                +

                diff --git a/examples/fact.lhs b/examples/fact.lhs index e41c6ae3..4ede5469 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -16,7 +16,10 @@ instance Yesod Fact where |] index = return $ StaticFile TypeHtml "examples/fact.html" -fact i = return $ toHtmlObject $ show $ product [1..fromIntegral i] +fact i = return $ toHtmlObject + [ ("input", show i) + , ("result", show $ product [1..fromIntegral i]) + ] factRedirect = do i <- getParam "num" redirect $ "../" ++ i ++ "/" From b1042c2b0ff9df36f9d875fa2bc4aede5de41356 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Dec 2009 19:37:05 +0200 Subject: [PATCH 091/624] Compiles without warnings --- examples/fact.lhs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/examples/fact.lhs b/examples/fact.lhs index 4ede5469..0c1ec939 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -1,4 +1,9 @@ +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. + \begin{code} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE QuasiQuotes #-} import Yesod @@ -18,11 +23,15 @@ instance Yesod Fact where index = return $ StaticFile TypeHtml "examples/fact.html" fact i = return $ toHtmlObject [ ("input", show i) - , ("result", show $ product [1..fromIntegral i]) + , ("result", show $ product [1..fromIntegral i :: Integer]) ] factRedirect = do i <- getParam "num" redirect $ "../" ++ i ++ "/" +\end{code} +In particular, the following line would be unnecesary if we had a type +signature here. +\begin{code} return () main :: IO () From a614095aa456373027d36de367d582b366555bf5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 21 Dec 2009 20:09:56 +0200 Subject: [PATCH 092/624] Better documentation for fact.lhs --- examples/fact.lhs | 115 ++++++++++++++++++++++++++++++++++++---------- 1 file changed, 90 insertions(+), 25 deletions(-) diff --git a/examples/fact.lhs b/examples/fact.lhs index 0c1ec939..70e74c4f 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -1,17 +1,60 @@ +> {-# 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 Hack.Handler.SimpleServer allows us to test our +application easily. A Yesod app can in general run on any Hack handler, so this +application is easily convertible to CGI, FastCGI, or even run on the Happstack +server. + +> import Yesod +> import Hack.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} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# LANGUAGE QuasiQuotes #-} - -import Yesod -import Hack.Handler.SimpleServer - -data Fact = Fact -instance Yesod Fact where - handlers = [$resources| + handlers = [$resources| /: Get: index /#num: @@ -19,21 +62,43 @@ instance Yesod Fact where /fact: Get: factRedirect |] - -index = return $ StaticFile TypeHtml "examples/fact.html" -fact i = return $ toHtmlObject - [ ("input", show i) - , ("result", show $ product [1..fromIntegral i :: Integer]) - ] -factRedirect = do - i <- getParam "num" - redirect $ "../" ++ i ++ "/" \end{code} -In particular, the following line would be unnecesary if we had a type -signature here. -\begin{code} - return () -main :: IO () -main = putStrLn "Running..." >> run 3000 (toHackApp Fact) -\end{code} +This does what it looks like: serves a static HTML file. + +> index = return $ StaticFile TypeHtml "examples/fact.html" + +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 = return $ toHtmlObject +> [ ("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 = do +> i <- getParam "num" +> redirect $ "../" ++ i ++ "/" + +The following line would be unnecesary if we had a type signature on +factRedirect. + +> return () + +You could replace this main to use any Hack 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..." >> run 3000 (toHackApp Fact) From 336f900849e92d38048ee6c26fe6ecab24e4ed37 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 22 Dec 2009 16:57:46 +0200 Subject: [PATCH 093/624] Fixed invalid response content types. Was using "show" instead of "convertSuccess". --- Yesod/Response.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Response.hs b/Yesod/Response.hs index d5904229..6dc61c1c 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -51,6 +51,7 @@ import Test.Framework (testGroup, Test) import Data.Generics import Control.Exception (Exception) +import Data.Convertible.Text (cs) data Response = Response Int [Header] ContentType Content deriving Show @@ -101,7 +102,7 @@ responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response responseToHackResponse _FIXMEls (Response sc hs ct c) = do hs' <- mapM toPair hs - let hs'' = ("Content-Type", show ct) : hs' + let hs'' = ("Content-Type", cs ct) : hs' let asLBS = unContent c return $ Hack.Response sc hs'' asLBS From 29afbd1b3804269b5b978f95830b83b6a440c6b1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Dec 2009 08:45:59 +0200 Subject: [PATCH 094/624] Fixes to compile with 6.12.1 --- Data/Object/Html.hs | 1 - Hack/Middleware/CleanPath.hs | 1 - Yesod/Helpers/Static.hs | 1 - Yesod/Resource.hs | 2 +- 4 files changed, 1 insertion(+), 4 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 235ff927..c1129d8a 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -31,7 +31,6 @@ module Data.Object.Html import Data.Generics import Data.Object.Text import Data.Object.Json -import Data.Convertible.Text import qualified Data.Text.Lazy as TL import Web.Encodings import Text.StringTemplate.Classes diff --git a/Hack/Middleware/CleanPath.hs b/Hack/Middleware/CleanPath.hs index 0fc1d82c..5afd2558 100644 --- a/Hack/Middleware/CleanPath.hs +++ b/Hack/Middleware/CleanPath.hs @@ -2,7 +2,6 @@ module Hack.Middleware.CleanPath (cleanPath, splitPath) where import Hack import qualified Data.ByteString.Lazy as BS -import Data.List import Web.Encodings import Data.List.Split diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index f0d98293..2b8ba726 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,7 +27,6 @@ import System.Directory (doesFileExist) import Control.Applicative ((<$>)) import Yesod -import Yesod.Rep import Data.List (intercalate) type FileLookup = FilePath -> IO (Maybe B.ByteString) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 56d1caa6..f0ab2561 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -246,7 +246,7 @@ checkRPNodes :: (MonadFailure OverlappingPatterns m, => [RPNode] -> m [RPNode] checkRPNodes nodes = do - checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly + _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes return nodes where From c8078f0be3f6a2d72c65b5fe317e21823a8139fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Dec 2009 23:11:09 +0200 Subject: [PATCH 095/624] Removed containers dependency --- Data/Object/Html.hs | 5 +++-- yesod.cabal | 3 +-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index c1129d8a..0e1dc616 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -34,7 +34,6 @@ import Data.Object.Json import qualified Data.Text.Lazy as TL import Web.Encodings import Text.StringTemplate.Classes -import qualified Data.Map as Map import Control.Arrow (second) import Data.Attempt @@ -152,7 +151,9 @@ $(deriveSuccessConvs ''String ''Html instance ToSElem HtmlObject where toSElem (Scalar h) = STR $ TL.unpack $ cs h toSElem (Sequence hs) = LI $ map toSElem hs - toSElem (Mapping pairs) = SM $ Map.fromList $ map (second toSElem) pairs + toSElem (Mapping pairs) = helper $ map (second toSElem) pairs where + helper :: [(String, SElem b)] -> SElem b + helper = SM . cs #if TEST caseHtmlToText :: Assertion diff --git a/yesod.cabal b/yesod.cabal index 22725226..67c30672 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -48,7 +48,6 @@ library convertible-text >= 0.2.0 && < 0.3, clientsession >= 0.0.1 && < 0.1, zlib >= 0.5.2.0 && < 0.6, - containers >= 0.2.0.1 && < 0.3, HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, @@ -83,7 +82,7 @@ executable runtests test-framework-quickcheck, test-framework-hunit, HUnit, - QuickCheck == 1.* + QuickCheck >= 1 && < 2 else Buildable: False ghc-options: -Wall From abe8b16cfdda0c051be0aa0b3b55927d10509824 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 22 Dec 2009 00:17:54 +0200 Subject: [PATCH 096/624] HasReps Plain; exposing SitemapResponse --- Yesod/Helpers/Sitemap.hs | 1 + Yesod/Rep.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index bc0694f2..581b363b 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -21,6 +21,7 @@ module Yesod.Helpers.Sitemap , SitemapUrl (..) , SitemapLoc (..) , SitemapChangeFreq (..) + , SitemapResponse (..) ) where import Yesod.Definitions diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 68ad4e42..b59686ea 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -149,8 +149,10 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" -newtype Plain = Plain Text +newtype Plain = Plain { unPlain :: Text } deriving (Eq, Show) +instance HasReps Plain where + reps = [(TypePlain, return . cs . unPlain)] plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs From 0c6493f5f521cae7dd8d5720c01a3dc9bbc64930 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 25 Dec 2009 02:22:24 +0200 Subject: [PATCH 097/624] Can do authentication again --- Hack/Middleware/ClientSession.hs | 10 ++---- Yesod/Handler.hs | 3 +- Yesod/Helpers/Auth.hs | 53 ++++++++++++++++---------------- Yesod/Yesod.hs | 11 ++----- 4 files changed, 32 insertions(+), 45 deletions(-) diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs index 963fffe2..c9bff08d 100644 --- a/Hack/Middleware/ClientSession.hs +++ b/Hack/Middleware/ClientSession.hs @@ -12,7 +12,7 @@ import Hack import Web.Encodings import Data.List (partition, intercalate) import Data.Function.Predicate (is, isn't, equals) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Web.ClientSession import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime) import Data.Time.LocalTime () -- Show instance of UTCTime @@ -62,8 +62,7 @@ clientsession cnames key app env = do remoteHost' = remoteHost env now <- getCurrentTime let convertedCookies = - takeJusts $ - map (decodeCookie key now remoteHost') interceptCookies + mapMaybe (decodeCookie key now remoteHost') interceptCookies let env' = env { http = ("Cookie", cookiesRaw) : filter (fst `equals` "Cookie") (http env) ++ nonCookies @@ -82,11 +81,6 @@ clientsession cnames key app env = do let res' = res { headers = newCookies ++ headers' } return res' -takeJusts :: [Maybe a] -> [a] -takeJusts [] = [] -takeJusts (Just x:rest) = x : takeJusts rest -takeJusts (Nothing:rest) = takeJusts rest - setCookie :: Word256 -> UTCTime -- ^ expiration time -> String -- ^ formatted expiration time diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 214f4832..7c96f692 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -103,8 +103,9 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do + -- FIXME doesn't look right Response _ hs ct c <- runHandler (eh e) specialEh rr y cts - let hs' = hs ++ getHeaders e + let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c Right a -> do (ct, c) <- a cts diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 971ded13..115264a9 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -14,10 +14,8 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth - ( AuthResource - , authHandler - , authResourcePattern - , RpxnowApiKey (..) + ( authHandler + , YesodAuth (..) ) where import qualified Hack @@ -33,6 +31,10 @@ import Control.Monad.Attempt import Data.Maybe (fromMaybe) +class Yesod a => YesodAuth a where + rpxnowApiKey :: a -> Maybe String + rpxnowApiKey _ = Nothing + data AuthResource = Check | Logout @@ -42,27 +44,19 @@ data AuthResource = | LoginRpxnow deriving (Show, Eq, Enum, Bounded) -newtype RpxnowApiKey = RpxnowApiKey String - -authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler y HtmlObject -authHandler _ Check Get = authCheck -authHandler _ Logout Get = authLogout -authHandler _ Openid Get = authOpenidForm -authHandler _ OpenidForward Get = authOpenidForward -authHandler _ OpenidComplete Get = authOpenidComplete --- two different versions of RPX protocol apparently... -authHandler (Just (RpxnowApiKey key)) LoginRpxnow Get = rpxnowLogin key -authHandler (Just (RpxnowApiKey key)) LoginRpxnow Post = rpxnowLogin key -authHandler _ _ _ = notFound - -authResourcePattern :: AuthResource -> String -- FIXME supply prefix as well -authResourcePattern Check = "/auth/check/" -authResourcePattern Logout = "/auth/logout/" -authResourcePattern Openid = "/auth/openid/" -authResourcePattern OpenidForward = "/auth/openid/forward/" -authResourcePattern OpenidComplete = "/auth/openid/complete/" -authResourcePattern LoginRpxnow = "/auth/login/rpxnow/" +rc :: HasReps x => Handler y x -> Handler y RepChooser +rc = fmap chooseRep +authHandler :: YesodAuth y => Verb -> [String] -> Handler y RepChooser +authHandler Get ["check"] = rc authCheck +authHandler Get ["logout"] = rc authLogout +authHandler Get ["openid"] = rc authOpenidForm +authHandler Get ["openid", "forward"] = rc authOpenidForward +authHandler 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 Request OIDFormReq where @@ -80,6 +74,8 @@ authOpenidForm = do [ cs m , Tag "form" [("method", "get"), ("action", "forward/")] [ Tag "label" [("for", "openid")] [cs "OpenID: "] + , EmptyTag "input" [("type", "text"), ("id", "openid"), + ("name", "openid")] , EmptyTag "input" [("type", "submit"), ("value", "Login")] ] ] @@ -126,9 +122,12 @@ chopHash :: String -> String chopHash ('#':rest) = rest chopHash x = x -rpxnowLogin :: String -- ^ api key - -> Handler y HtmlObject -rpxnowLogin apiKey = do +rpxnowLogin :: YesodAuth y => Handler y HtmlObject +rpxnowLogin = do + ay <- getYesod + apiKey <- case rpxnowApiKey ay of + Just x -> return x + Nothing -> notFound token <- anyParam "token" postDest <- postParam "dest" dest' <- case postDest of diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6e48385f..5298ef87 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -64,15 +64,8 @@ toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do key <- encryptKey a let app' = toHackApp' a - middleware = - [ gzip - , cleanPath - , jsonp - , methodOverride - , clientsession [authCookieName] key - ] - app = foldr ($) app' middleware - app env + (gzip $ cleanPath $ jsonp $ methodOverride + $ clientsession [authCookieName] key $ app') env toHackApp' :: Yesod y => y -> Hack.Application toHackApp' y env = do From fb772f9d9e31844f22b9df95b8232b476ad659f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 25 Dec 2009 03:10:50 +0200 Subject: [PATCH 098/624] Added permissionDenied function --- Yesod/Handler.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7c96f692..1dcfa55d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -27,6 +27,7 @@ module Yesod.Handler -- * Special handlers , redirect , notFound + , permissionDenied -- * Setting headers , addCookie , deleteCookie @@ -206,6 +207,9 @@ redirect = errorResult . Redirect notFound :: Handler yesod a notFound = errorResult NotFound +permissionDenied :: Handler yesod a +permissionDenied = errorResult PermissionDenied + ------- Headers -- | Set the cookie on the client. addCookie :: Int -- ^ minutes to timeout From 0a72e93a616108759beb241140da426e81f1705c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 26 Dec 2009 23:57:03 +0200 Subject: [PATCH 099/624] Client session duration is configurable. Defaults to 2 hours. --- Hack/Middleware/ClientSession.hs | 9 +++++---- Yesod/Yesod.hs | 8 +++++++- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs index c9bff08d..7f069c93 100644 --- a/Hack/Middleware/ClientSession.hs +++ b/Hack/Middleware/ClientSession.hs @@ -44,8 +44,9 @@ import Control.Monad (guard) -- the data to make sure that the user can neither see not tamper with it. clientsession :: [String] -- ^ list of cookies to intercept -> Word256 -- ^ encryption key + -> Int -- ^ minutes to live -> Middleware -clientsession cnames key app env = do +clientsession cnames key minutesToLive app env = do let initCookiesRaw :: String initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env nonCookies :: [(String, String)] @@ -71,9 +72,9 @@ clientsession cnames key app env = do res <- app env' let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames)) $ headers res - let twentyMinutes :: Int - twentyMinutes = 20 * 60 - let exp = fromIntegral twentyMinutes `addUTCTime` now + let timeToLive :: Int + timeToLive = minutesToLive * 60 + let exp = fromIntegral timeToLive `addUTCTime` now let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies let newCookies = map (setCookie key exp formattedExp remoteHost') $ diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5298ef87..83ae306f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -32,6 +32,11 @@ class Yesod a where 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 :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler @@ -64,8 +69,9 @@ toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do key <- encryptKey a let app' = toHackApp' a + let mins = clientSessionDuration a (gzip $ cleanPath $ jsonp $ methodOverride - $ clientsession [authCookieName] key $ app') env + $ clientsession [authCookieName] key mins $ app') env toHackApp' :: Yesod y => y -> Hack.Application toHackApp' y env = do From ab233514e1776f8d8b220cac17c1c40b26db6e08 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 27 Dec 2009 10:06:47 +0200 Subject: [PATCH 100/624] Fixed some error reporting --- Yesod/Handler.hs | 8 ++++++-- test/errors.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 2 deletions(-) create mode 100644 test/errors.hs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1dcfa55d..b28c374c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -28,6 +28,7 @@ module Yesod.Handler , redirect , notFound , permissionDenied + , invalidArgs -- * Setting headers , addCookie , deleteCookie @@ -81,8 +82,8 @@ instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance MonadRequestReader (Handler yesod) where askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr) - invalidParam _pt _pn _pe = error "invalidParam" - authRequired = error "authRequired" + invalidParam _pt pn pe = invalidArgs [(pn, pe)] + authRequired = permissionDenied getYesod :: Handler yesod yesod getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) @@ -210,6 +211,9 @@ notFound = errorResult NotFound permissionDenied :: Handler yesod a permissionDenied = errorResult PermissionDenied +invalidArgs :: [(ParamName, ParamValue)] -> Handler yesod a +invalidArgs = errorResult . InvalidArgs + ------- Headers -- | Set the cookie on the client. addCookie :: Int -- ^ minutes to timeout diff --git a/test/errors.hs b/test/errors.hs new file mode 100644 index 00000000..b841f1ba --- /dev/null +++ b/test/errors.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE QuasiQuotes #-} +import Yesod +import Hack +import Data.Default +import Data.List + +data Errors = Errors +instance Yesod Errors where + handlers = [$resources| +/denied: + Get: denied +/needs-ident: + Get: needsIdent +/has-args: + Get: hasArgs +|] + +denied :: Handler Errors () +denied = permissionDenied + +needsIdent :: Handler Errors HtmlObject +needsIdent = do + i <- identifier + return $ toHtmlObject i + +hasArgs :: Handler Errors HtmlObject +hasArgs = do + -- FIXME this test needs more work + a <- getParam "firstParam" + b <- getParam "secondParam" + return $ toHtmlObject [a :: String, b] + +main = do + let app = toHackApp Errors + res <- app $ def { pathInfo = "/denied/" } + print res + print $ "Permission denied" `isInfixOf` show res + res' <- app $ def { pathInfo = "/needs-ident/" } + print res' + print $ "Permission denied" `isInfixOf` show res' + res3 <- app $ def { pathInfo = "/has-args/" } + print res3 + print $ "secondParam" `isInfixOf` show res3 From 4e30f5374657a9964c236d0926fd7c2f6bb69286 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 27 Dec 2009 10:17:26 +0200 Subject: [PATCH 101/624] Fixed some FIXMEs --- Yesod/Handler.hs | 81 +---------------------------------------------- Yesod/Resource.hs | 36 ++++++++++++--------- 2 files changed, 22 insertions(+), 95 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b28c374c..2ba325a6 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} --------------------------------------------------------- @@ -105,7 +105,6 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - -- FIXME doesn't look right Response _ hs ct c <- runHandler (eh e) specialEh rr y cts let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c @@ -117,84 +116,6 @@ specialEh :: ErrorResult -> Handler yesod RepChooser specialEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" -{- FIXME -class ToHandler a where - toHandler :: a -> Handler - -instance (Request r, ToHandler h) => ToHandler (r -> h) where - toHandler f = parseRequest >>= toHandler . f - -instance ToHandler Handler where - toHandler = id - -instance HasReps r HandlerIO => ToHandler (HandlerIO r) where - toHandler = fmap reps - -runHandler :: Handler - -> RawRequest - -> [ContentType] - -> IO (Either (ErrorResult, [Header]) Response) -runHandler h rr cts = do - --let (ares, _FIXMEheaders) = - let x :: IO (Attempt (ContentType, Content), [Header]) - x = - runWriterT $ runAttemptT $ runReaderT (joinHandler cts h) rr - y :: IO (Attempt (Attempt (ContentType, Content), [Header])) - y = takeAllExceptions x - z <- y - let z' :: Attempt (Attempt (ContentType, Content), [Header]) - z' = z - a :: (Attempt (ContentType, Content), [Header]) - a = attempt (\e -> (failure e, [])) id z' - (b, headers) = a - return $ attempt (\e -> (Left (toErrorResult e, headers))) (Right . toResponse headers) b - where - takeAllExceptions :: MonadFailure SomeException m => IO x -> IO (m x) - takeAllExceptions ioa = - Control.Exception.catch (return `fmap` ioa) (\e -> return $ failure (e :: SomeException)) - toErrorResult :: Exception e => e -> ErrorResult - toErrorResult e = - case cast e of - Just x -> x - Nothing -> InternalError $ show e - toResponse :: [Header] -> (ContentType, Content) -> Response - toResponse hs (ct, c) = Response 200 hs ct c - -joinHandler :: Monad m - => [ContentType] - -> m [RepT m] - -> m (ContentType, Content) -joinHandler cts rs = do - rs' <- rs - let (ct, c) = chooseRep cts rs' - c' <- c - return (ct, c') --} - -{- -runHandler :: (ErrorResult -> Reps) - -> (ContentType -> B.ByteString -> IO B.ByteString) - -> [ContentType] - -> Handler - -> RawRequest - -> IO Hack.Response -runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - let extraHeaders = - case x of - Left r -> getHeaders r - Right _ -> [] - headers <- mapM toPair (headers' ++ extraHeaders) - let outReps = either (reps . eh) reps x - let statusCode = - case x of - Left r -> getStatus r - Right _ -> 200 - (ctype, selectedRep) <- chooseRep outReps ctypesAll - let languages = [] -- FIXME - finalRep <- wrapper ctype $ selectedRep languages - let headers'' = ("Content-Type", ctype) : headers - return $! Hack.Response statusCode headers'' finalRep --} ------ Special handlers errorResult :: ErrorResult -> Handler yesod a diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index f0ab2561..8e6e5f7c 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -62,6 +62,7 @@ import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck import Control.Monad (when) +import Data.Typeable #endif resources :: QuasiQuoter @@ -187,7 +188,7 @@ overlaps (Static a:x) (Static b:y) = a == b && overlaps x y data OverlappingPatterns = OverlappingPatterns [(ResourcePattern, ResourcePattern)] - deriving (Show, Typeable) + deriving (Show, Typeable, Eq) instance Exception OverlappingPatterns getAllPairs :: [x] -> [(x, x)] @@ -394,7 +395,7 @@ testSuite = testGroup "Yesod.Resource" [ testCase "non-overlap" caseOverlap1 , testCase "overlap" caseOverlap2 , testCase "overlap-slurp" caseOverlap3 - -- FIXME, testCase "validatePatterns" caseValidatePatterns + , testCase "checkPatterns" caseCheckPatterns , testProperty "show pattern" prop_showPattern , testCase "integers" caseIntegers , testCase "read patterns from YAML" caseFromYaml @@ -424,19 +425,24 @@ caseOverlap2 = caseOverlap' "/foo/bar" "/foo/$baz" True caseOverlap3 :: Assertion caseOverlap3 = caseOverlap' "/foo/bar/baz/$bin" "*slurp" True -{- FIXME rewrite this test -caseValidatePatterns :: Assertion -caseValidatePatterns = - let p1 = cs "/foo/bar/baz" - p2 = cs "/foo/$bar/baz" - p3 = cs "/bin" - p4 = cs "/bin/boo" - p5 = cs "/bin/*slurp" - in validatePatterns [p1, p2, p3, p4, p5] @?= Just - [ (p1, p2) - , (p4, p5) - ] --} +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 From 29e6567c653db8f4332d9a29fe90d477c5a01392 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Dec 2009 22:44:51 +0200 Subject: [PATCH 102/624] Changes to HTML type; AtomFeed and Auth --- Data/Object/Html.hs | 18 +++++++++++------- TODO | 14 +++----------- Yesod/Helpers/AtomFeed.hs | 5 ++--- Yesod/Helpers/Auth.hs | 9 +++++---- Yesod/Rep.hs | 2 ++ 5 files changed, 23 insertions(+), 25 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 0e1dc616..0b03716f 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -32,6 +32,7 @@ import Data.Generics import Data.Object.Text import Data.Object.Json import qualified Data.Text.Lazy as TL +import Data.ByteString.Lazy (ByteString) import Web.Encodings import Text.StringTemplate.Classes import Control.Arrow (second) @@ -48,7 +49,7 @@ import Text.StringTemplate data Html = Html Text -- ^ Already encoded HTML. | Text Text -- ^ Text which should be HTML escaped. - | Tag String [(String, String)] [Html] -- ^ Tag which needs a closing tag. + | 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) @@ -92,7 +93,7 @@ instance ConvertSuccess Html Text where , cs n , showAttribs as , cs ">" - , TL.concat $ map convertSuccess content + , cs content , cs "" @@ -107,6 +108,8 @@ instance ConvertSuccess Html Text where instance ConvertSuccess Html String where convertSuccess = cs . (cs :: Html -> Text) +instance ConvertSuccess Html ByteString where + convertSuccess = cs . (cs :: Html -> Text) instance ConvertSuccess Html HtmlDoc where convertSuccess h = HtmlDoc $ TL.concat @@ -118,13 +121,14 @@ instance ConvertSuccess Html HtmlDoc where instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h - convertSuccess (Sequence hs) = Tag "ul" [] $ map addLi hs where - addLi h = Tag "li" [] [cs h] + convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs + where + addLi h = Tag "li" [] $ cs h convertSuccess (Mapping pairs) = - Tag "dl" [] $ concatMap addDtDd pairs where + Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where addDtDd (k, v) = - [ Tag "dt" [] [Text $ cs k] - , Tag "dd" [] [cs v] + [ Tag "dt" [] $ Text $ cs k + , Tag "dd" [] $ cs v ] instance ConvertSuccess HtmlObject HtmlDoc where diff --git a/TODO b/TODO index bb7148d8..394ef3dc 100644 --- a/TODO +++ b/TODO @@ -1,17 +1,9 @@ HTML sitemap generation Cleanup Data.Object.Translate -Remove Data.Object.Instances (Web.Types?) -Possibly unify ResourceName and RestfulApp? -Expand Yesod.Definitions? Cleanup Parameter stuff. Own module? Interface with formlets? -Merge MonadRequestReader class with other Handler stuff -SitemapLoc: what's the point again? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). -Simple model information (settings files, etc) in RestfulApp Is there a mimetype package on hackage for Yesod.Helpers.Static? -The RepT stuff is hideous. -More than one type of objectResponse? -Native support for HStringTemplate. -Automatic HTML escaping, something smart for templates vs JSON. -Handler should be a better type, do something about ToHandler. +Native support for HStringTemplate groups. +AtomFeed uses RelLoc and AbsLoc like Sitemap +Fix type of sitemap diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index c194faaf..ed93952d 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -19,8 +19,7 @@ module Yesod.Helpers.AtomFeed , AtomFeedEntry (..) ) where -import Yesod.Rep -import Data.Convertible.Text +import Yesod import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL @@ -43,7 +42,7 @@ data AtomFeedEntry = AtomFeedEntry { atomEntryLink :: String , atomEntryUpdated :: UTCTime , atomEntryTitle :: String - , atomEntryContent :: String + , atomEntryContent :: Html } instance ConvertSuccess AtomFeed Content where diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 115264a9..5d964c43 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -64,7 +64,7 @@ instance Request OIDFormReq where instance ConvertSuccess OIDFormReq Html where convertSuccess (OIDFormReq Nothing _) = cs "" convertSuccess (OIDFormReq (Just s) _) = - Tag "p" [("class", "message")] [cs s] + Tag "p" [("class", "message")] $ cs s authOpenidForm :: Handler y HtmlObject authOpenidForm = do @@ -72,8 +72,9 @@ authOpenidForm = do let html = HtmlList [ cs m - , Tag "form" [("method", "get"), ("action", "forward/")] - [ Tag "label" [("for", "openid")] [cs "OpenID: "] + , 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")] @@ -82,7 +83,7 @@ authOpenidForm = do case dest of Just dest' -> addCookie 120 "DEST" dest' Nothing -> return () - return $ toHtmlObject $ Html $ cs html + return $ cs html authOpenidForward :: Handler y HtmlObject authOpenidForward = do diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index b59686ea..9c4eb487 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -109,6 +109,8 @@ instance ConvertSuccess ByteString Content where convertSuccess = Content instance ConvertSuccess String Content where convertSuccess = Content . cs +instance ConvertSuccess Html Content where + convertSuccess = Content . cs type ContentPair = (ContentType, Content) type RepChooser = [ContentType] -> IO ContentPair From dc355edf7d1a32f909e06e7699f770f97df2e8ee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Dec 2009 23:18:17 +0200 Subject: [PATCH 103/624] Location datatype --- TODO | 4 ---- Yesod/Definitions.hs | 11 +++++++++++ Yesod/Helpers/AtomFeed.hs | 41 ++++++++++++++++++++++++--------------- Yesod/Helpers/Sitemap.hs | 23 +++++++++------------- 4 files changed, 45 insertions(+), 34 deletions(-) diff --git a/TODO b/TODO index 394ef3dc..b87b2101 100644 --- a/TODO +++ b/TODO @@ -1,9 +1,5 @@ -HTML sitemap generation Cleanup Data.Object.Translate Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). -Is there a mimetype package on hackage for Yesod.Helpers.Static? Native support for HStringTemplate groups. -AtomFeed uses RelLoc and AbsLoc like Sitemap -Fix type of sitemap diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index f77d8fcc..e86fc6b9 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -19,6 +19,8 @@ module Yesod.Definitions , Resource , Approot (..) , Language + , Location (..) + , showLocation ) where import qualified Hack @@ -55,3 +57,12 @@ type Resource = [String] newtype Approot = Approot { unApproot :: 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 (Approot ar) (RelLoc s) = ar ++ s diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index ed93952d..ca63fba0 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -17,6 +17,8 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) + , AtomFeedResponse (..) + , atomFeed ) where import Yesod @@ -26,58 +28,65 @@ import qualified Data.Text.Lazy as TL import Data.Time.Clock import Web.Encodings +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 :: String - , atomLinkHome :: String + , atomLinkSelf :: Location + , atomLinkHome :: Location , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance HasReps AtomFeed where +instance HasReps AtomFeedResponse where reps = [ (TypeAtom, return . cs) ] data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: String + { atomEntryLink :: Location , atomEntryUpdated :: UTCTime , atomEntryTitle :: String , atomEntryContent :: Html } -instance ConvertSuccess AtomFeed Content where - convertSuccess = cs . (cs :: AtomFeed -> Text) -instance ConvertSuccess AtomFeed Text where - convertSuccess f = TL.concat +instance ConvertSuccess AtomFeedResponse Content where + convertSuccess = (cs :: Text -> Content) . cs +instance ConvertSuccess AtomFeedResponse Text where + convertSuccess (AtomFeedResponse f ar) = TL.concat [ cs "\n" , cs "" , cs "" , encodeHtml $ cs $ atomTitle f , cs "" , cs "" , cs "" , cs "" , cs $ formatW3 $ atomUpdated f , cs "" , cs "" - , encodeHtml $ cs $ atomLinkHome f + , encodeHtml $ cs $ showLocation ar $ atomLinkHome f , cs "" - , TL.concat $ map cs $ atomEntries f + , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar , cs "" ] -instance ConvertSuccess AtomFeedEntry Text where - convertSuccess e = TL.concat +instance ConvertSuccess (AtomFeedEntry, Approot) Text where + convertSuccess (e, ar) = TL.concat [ cs "" , cs "" - , encodeHtml $ cs $ atomEntryLink e + , encodeHtml $ cs $ showLocation ar $ atomEntryLink e , cs "" , cs "" , cs "" , cs $ formatW3 $ atomEntryUpdated e diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 581b363b..d41c1ebc 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -19,7 +19,6 @@ module Yesod.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) - , SitemapLoc (..) , SitemapChangeFreq (..) , SitemapResponse (..) ) where @@ -34,7 +33,6 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import Yesod.Yesod -data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always | Hourly | Daily @@ -52,7 +50,7 @@ instance ConvertSuccess SitemapChangeFreq String where convertSuccess Never = "never" data SitemapUrl = SitemapUrl - { sitemapLoc :: SitemapLoc + { sitemapLoc :: Location , sitemapLastMod :: UTCTime , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double @@ -61,7 +59,7 @@ data SitemapResponse = SitemapResponse [SitemapUrl] Approot instance ConvertSuccess SitemapResponse Content where convertSuccess = cs . (cs :: SitemapResponse -> Text) instance ConvertSuccess SitemapResponse Text where - convertSuccess (SitemapResponse urls (Approot ar)) = TL.concat + convertSuccess (SitemapResponse urls ar) = TL.concat [ cs "\n" , cs "" , TL.concat $ map helper urls @@ -69,8 +67,9 @@ instance ConvertSuccess SitemapResponse Text where ] where helper (SitemapUrl loc modTime freq pri) = cs $ concat + -- FIXME use HTML? [ "" - , encodeHtml $ showLoc loc + , encodeHtml $ showLocation ar loc , "" , formatW3 modTime , "" @@ -79,24 +78,20 @@ instance ConvertSuccess SitemapResponse Text where , show pri , "" ] - showLoc (AbsLoc s) = s - showLoc (RelLoc s) = ar ++ s instance HasReps SitemapResponse where reps = [ (TypeXml, return . cs) ] -sitemap :: YesodApproot yesod - => IO [SitemapUrl] - -> Handler yesod SitemapResponse -sitemap urls' = do +sitemap :: YesodApproot y => [SitemapUrl] -> Handler y SitemapResponse +sitemap urls = do yesod <- getYesod - urls <- liftIO urls' return $ SitemapResponse urls $ approot yesod robots :: YesodApproot yesod => Handler yesod Plain robots = do yesod <- getYesod - return $ plain $ "Sitemap: " ++ unApproot (approot yesod) - ++ "sitemap.xml" + return $ plain $ "Sitemap: " ++ showLocation + (approot yesod) + (RelLoc "sitemap.xml") From 579583c1d2381141dc47a819be545534cde8b3f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Dec 2009 23:52:10 +0200 Subject: [PATCH 104/624] Added basic XML support --- Data/Object/Html.hs | 60 +++++++++++++++++++++++----------- Yesod/Helpers/AtomFeed.hs | 68 +++++++++++++-------------------------- Yesod/Helpers/Sitemap.hs | 47 +++++++++++---------------- Yesod/Rep.hs | 2 ++ 4 files changed, 84 insertions(+), 93 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 0b03716f..7fa1e602 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -20,6 +20,9 @@ module Data.Object.Html Html (..) , HtmlDoc (..) , HtmlObject + -- * XML helpers + , XmlDoc (..) + , cdata -- * Standard 'Object' functions , toHtmlObject , fromHtmlObject @@ -85,26 +88,47 @@ showAttribs = TL.concat . map helper where , cs "\"" ] +htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML + -> Html + -> Text +htmlToText _ (Html t) = t +htmlToText _ (Text t) = encodeHtml t +htmlToText xml (Tag n as content) = TL.concat + [ cs "<" + , cs n + , showAttribs as + , cs ">" + , htmlToText xml content + , cs "" + ] +htmlToText xml (EmptyTag n as) = TL.concat + [ cs "<" + , cs n + , showAttribs as + , cs $ if xml then "/>" else ">" + ] +htmlToText xml (HtmlList l) = TL.concat $ map (htmlToText xml) l + instance ConvertSuccess Html Text where - convertSuccess (Html t) = t - convertSuccess (Text t) = encodeHtml t - convertSuccess (Tag n as content) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs ">" - , cs content - , cs "" + convertSuccess = htmlToText False +-- | 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.concat + [ cs "\n" + , htmlToText True h ] - convertSuccess (EmptyTag n as) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs ">" - ] - convertSuccess (HtmlList l) = TL.concat $ map cs l + +-- | Wrap an 'Html' in CDATA for XML output. +cdata :: Html -> Html +cdata h = HtmlList + [ Html $ cs "" + ] instance ConvertSuccess Html String where convertSuccess = cs . (cs :: Html -> Text) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index ca63fba0..b0377c32 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -22,11 +22,8 @@ module Yesod.Helpers.AtomFeed ) where import Yesod -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL - -import Data.Time.Clock -import Web.Encodings +import Data.Time.Clock (UTCTime) +import Web.Encodings (formatW3) data AtomFeedResponse = AtomFeedResponse AtomFeed Approot @@ -55,47 +52,26 @@ data AtomFeedEntry = AtomFeedEntry } instance ConvertSuccess AtomFeedResponse Content where - convertSuccess = (cs :: Text -> Content) . cs -instance ConvertSuccess AtomFeedResponse Text where - convertSuccess (AtomFeedResponse f ar) = TL.concat - [ cs "\n" - , cs "" - , cs "" - , encodeHtml $ cs $ atomTitle f - , cs "" - , cs "" - , cs "" - , cs "" - , cs $ formatW3 $ atomUpdated f - , cs "" - , cs "" - , encodeHtml $ cs $ showLocation ar $ atomLinkHome f - , cs "" - , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar - , cs "" + 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) Text where - convertSuccess (e, ar) = TL.concat - [ cs "" - , cs "" - , encodeHtml $ cs $ showLocation ar $ atomEntryLink e - , cs "" - , cs "" - , cs "" - , cs $ formatW3 $ atomEntryUpdated e - , cs "" - , cs "" - , encodeHtml $ cs $ atomEntryTitle e - , cs "" - , cs "" - , cs "" +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 ] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index d41c1ebc..04780092 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -23,15 +23,9 @@ module Yesod.Helpers.Sitemap , SitemapResponse (..) ) where -import Yesod.Definitions -import Yesod.Handler -import Yesod.Rep -import Web.Encodings +import Yesod +import Web.Encodings (formatW3) import Data.Time (UTCTime) -import Data.Convertible.Text -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL -import Yesod.Yesod data SitemapChangeFreq = Always | Hourly @@ -48,6 +42,8 @@ instance ConvertSuccess SitemapChangeFreq String where convertSuccess Monthly = "monthly" convertSuccess Yearly = "yearly" convertSuccess Never = "never" +instance ConvertSuccess SitemapChangeFreq Html where + convertSuccess = (cs :: String -> Html) . cs data SitemapUrl = SitemapUrl { sitemapLoc :: Location @@ -57,27 +53,20 @@ data SitemapUrl = SitemapUrl } data SitemapResponse = SitemapResponse [SitemapUrl] Approot instance ConvertSuccess SitemapResponse Content where - convertSuccess = cs . (cs :: SitemapResponse -> Text) -instance ConvertSuccess SitemapResponse Text where - convertSuccess (SitemapResponse urls ar) = TL.concat - [ cs "\n" - , cs "" - , TL.concat $ map helper urls - , cs "" - ] - where - helper (SitemapUrl loc modTime freq pri) = cs $ concat - -- FIXME use HTML? - [ "" - , encodeHtml $ showLocation ar loc - , "" - , formatW3 modTime - , "" - , cs freq - , "" - , show pri - , "" - ] + 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 reps = diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 9c4eb487..c69d3ffa 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -111,6 +111,8 @@ instance ConvertSuccess String Content where convertSuccess = Content . cs instance ConvertSuccess Html Content where convertSuccess = Content . cs +instance ConvertSuccess XmlDoc Content where + convertSuccess = cs . unXmlDoc type ContentPair = (ContentType, Content) type RepChooser = [ContentType] -> IO ContentPair From 3cbcac8c416b50449ce39e7833120b6f69c5a799 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 29 Dec 2009 02:55:26 +0200 Subject: [PATCH 105/624] Basic template group support added --- .gitignore | 1 + TODO | 1 + Yesod.hs | 2 ++ Yesod/Rep.hs | 5 +++-- examples/hellotemplate.lhs | 14 ++++++++++++-- examples/real-template.st | 1 + yesod.cabal | 1 + 7 files changed, 21 insertions(+), 4 deletions(-) create mode 100644 examples/real-template.st diff --git a/.gitignore b/.gitignore index 39b806f8..c17db52f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ dist *.swp +client_session_key.aes diff --git a/TODO b/TODO index b87b2101..adda8355 100644 --- a/TODO +++ b/TODO @@ -3,3 +3,4 @@ Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). Native support for HStringTemplate groups. +Use Text for HStringTemplate throughout diff --git a/Yesod.hs b/Yesod.hs index 6aa47888..5e98a749 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,6 +21,7 @@ module Yesod , module Yesod.Resource , module Data.Object.Html , module Yesod.Rep + , module Yesod.Templates , module Data.Convertible.Text , Application ) where @@ -33,5 +34,6 @@ import Yesod.Handler import Yesod.Resource import Hack (Application) import Yesod.Rep +import Yesod.Templates import Data.Object.Html import Data.Convertible.Text diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index c69d3ffa..84e42f6b 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -47,6 +47,7 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL import Data.Maybe (mapMaybe) import Data.Function (on) @@ -161,11 +162,11 @@ instance HasReps Plain where plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs -data Template = Template (StringTemplate String) HtmlObject +data Template = Template (StringTemplate Text) HtmlObject instance HasReps Template where reps = [ (TypeHtml, \(Template t h) -> - return $ cs $ toString $ setAttribute "o" h t) + return $ cs $ render $ setAttribute "o" h t) , (TypeJson, \(Template _ ho) -> return $ cs $ unJsonDoc $ cs ho) ] diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index 869f06c6..eed35ddd 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -4,19 +4,29 @@ import Yesod import Hack.Handler.SimpleServer -data HelloWorld = HelloWorld +data HelloWorld = HelloWorld TemplateGroup instance Yesod HelloWorld where handlers = [$resources| /: Get: helloWorld +/groups: + Get: helloGroup |] +instance YesodTemplates HelloWorld where + templates (HelloWorld g) = g + helloWorld :: Handler HelloWorld TemplateFile helloWorld = return $ TemplateFile "examples/template.html" $ cs [ ("title", "Hello world!") , ("content", "Hey look!! I'm !") ] +helloGroup = template "real-template" $ cs "foo" + main :: IO () -main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +main = do + putStrLn "Running..." + stg <- loadTemplates "examples" + run 3000 (toHackApp $ HelloWorld stg) \end{code} diff --git a/examples/real-template.st b/examples/real-template.st new file mode 100644 index 00000000..4348e29e --- /dev/null +++ b/examples/real-template.st @@ -0,0 +1 @@ +This is a more realistic template. diff --git a/yesod.cabal b/yesod.cabal index 67c30672..05820d8e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -62,6 +62,7 @@ library Yesod.Handler Yesod.Resource Yesod.Yesod + Yesod.Templates Data.Object.Html Hack.Middleware.MethodOverride Hack.Middleware.ClientSession From 911934bff0bbbcd897d3d4949b5147a1b809d445 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 29 Dec 2009 23:07:38 +0200 Subject: [PATCH 106/624] Basic implementation of template groups --- Data/Object/Html.hs | 2 +- TODO | 4 +--- Yesod.hs | 4 ++-- Yesod/Handler.hs | 20 ++++++++++++-------- Yesod/Rep.hs | 20 ++++++++++++++------ Yesod/Resource.hs | 3 +-- Yesod/Template.hs | 38 ++++++++++++++++++++++++++++++++++++++ Yesod/Yesod.hs | 12 +++++++++++- examples/hellotemplate.lhs | 11 ++++------- examples/real-template.st | 1 + test/quasi-resource.hs | 3 ++- yesod.cabal | 5 +++-- 12 files changed, 90 insertions(+), 33 deletions(-) create mode 100644 Yesod/Template.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 7fa1e602..8ed6ff77 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -186,7 +186,7 @@ instance ToSElem HtmlObject where #if TEST caseHtmlToText :: Assertion caseHtmlToText = do - let actual = Tag "div" [("id", "foo"), ("class", "bar")] + let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList [ Html $ cs "
                Some HTML
                " , Text $ cs "<'this should be escaped'>" , EmptyTag "img" [("src", "baz&")] diff --git a/TODO b/TODO index adda8355..e2c54485 100644 --- a/TODO +++ b/TODO @@ -1,6 +1,4 @@ -Cleanup Data.Object.Translate +Some form of i18n. Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). -Native support for HStringTemplate groups. -Use Text for HStringTemplate throughout diff --git a/Yesod.hs b/Yesod.hs index 5e98a749..8f8fa700 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,7 +21,7 @@ module Yesod , module Yesod.Resource , module Data.Object.Html , module Yesod.Rep - , module Yesod.Templates + , module Yesod.Template , module Data.Convertible.Text , Application ) where @@ -34,6 +34,6 @@ import Yesod.Handler import Yesod.Resource import Hack (Application) import Yesod.Rep -import Yesod.Templates +import Yesod.Template import Data.Object.Html import Data.Convertible.Text diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2ba325a6..882e3cb1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -38,6 +38,7 @@ module Yesod.Handler import Yesod.Request import Yesod.Response import Yesod.Rep +import Yesod.Template import Control.Exception hiding (Handler) import Control.Applicative @@ -49,11 +50,10 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html ---import Data.Typeable - ------ Handler monad newtype Handler yesod a = Handler { - unHandler :: (RawRequest, yesod) -> IO ([Header], HandlerContents a) + unHandler :: (RawRequest, yesod, TemplateGroup) + -> IO ([Header], HandlerContents a) } data HandlerContents a = forall e. Exception e => HCError e @@ -81,22 +81,26 @@ instance MonadIO (Handler yesod) where instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance MonadRequestReader (Handler yesod) where - askRawRequest = Handler $ \(rr, _) -> return ([], HCContent rr) + askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) invalidParam _pt pn pe = invalidArgs [(pn, pe)] authRequired = permissionDenied getYesod :: Handler yesod yesod -getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod) +getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) + +instance HasTemplateGroup (Handler yesod) where + getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) runHandler :: Handler yesod RepChooser -> (ErrorResult -> Handler yesod RepChooser) -> RawRequest -> yesod + -> TemplateGroup -> [ContentType] -> IO Response -runHandler (Handler handler) eh rr y cts = do +runHandler (Handler handler) eh rr y tg cts = do (headers, contents) <- Control.Exception.catch - (handler (rr, y)) + (handler (rr, y, tg)) (\e -> return ([], HCError (e :: Control.Exception.SomeException))) let contents' = case contents of @@ -105,7 +109,7 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - Response _ hs ct c <- runHandler (eh e) specialEh rr y cts + Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c Right a -> do diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 84e42f6b..1b95523d 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -47,7 +47,6 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as TL import Data.Maybe (mapMaybe) import Data.Function (on) @@ -162,15 +161,24 @@ instance HasReps Plain where plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs -data Template = Template (StringTemplate Text) HtmlObject +data Template = Template (StringTemplate Text) + String + HtmlObject + (IO [(String, HtmlObject)]) instance HasReps Template where reps = [ (TypeHtml, - \(Template t h) -> - return $ cs $ render $ setAttribute "o" h t) - , (TypeJson, \(Template _ ho) -> + \(Template t name ho attrsIO) -> do + attrs <- attrsIO + return + $ cs + $ render + $ setAttribute name ho + $ setManyAttrib attrs t) + , (TypeJson, \(Template _ _ ho _) -> return $ cs $ unJsonDoc $ cs ho) ] +-- FIXME data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where reps = [ (TypeHtml, @@ -231,7 +239,7 @@ caseChooseRepTemplate = do ho = toHtmlObject [ ("foo", toHtmlObject "") , ("bar", toHtmlObject ["bar1", "bar2"]) ] - hasreps = Template temp ho + hasreps = Template temp "o" ho $ return [] res1 = cs "foo:<fooval>, bar:bar1bar2" res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ "\"foo\":\"<fooval>\"}" diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 8e6e5f7c..81a5cf31 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -43,7 +43,7 @@ import Language.Haskell.TH.Ppr import System.IO -} -import Data.Typeable (Typeable) +import Data.Typeable import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Object.Text @@ -62,7 +62,6 @@ import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck import Control.Monad (when) -import Data.Typeable #endif resources :: QuasiQuoter diff --git a/Yesod/Template.hs b/Yesod/Template.hs new file mode 100644 index 00000000..84431566 --- /dev/null +++ b/Yesod/Template.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Template + ( HasTemplateGroup (..) + , template + , NoSuchTemplate + , TemplateGroup + ) where + +import Data.Object.Html +import Data.Typeable (Typeable) +import Control.Exception (Exception) +import Control.Failure +import Yesod.Rep +import Data.Object.Text (Text) +import Text.StringTemplate + +type TemplateGroup = STGroup Text + +class HasTemplateGroup a where + getTemplateGroup :: a TemplateGroup + +-- FIXME better home +template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) + => String -- ^ template name + -> String -- ^ object name + -> HtmlObject -- ^ object + -> IO [(String, HtmlObject)] -- ^ template attributes + -> t Template +template tn on o attrs = do + tg <- getTemplateGroup + t <- case getStringTemplate tn tg of + Nothing -> failure $ NoSuchTemplate tn + Just x -> return x + return $ Template t on o attrs +newtype NoSuchTemplate = NoSuchTemplate String + deriving (Show, Typeable) +instance Exception NoSuchTemplate diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 83ae306f..294fb6db 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -16,6 +16,7 @@ import Yesod.Utils import Data.Maybe (fromMaybe) import Data.Convertible.Text +import Text.StringTemplate import qualified Hack import Hack.Middleware.CleanPath @@ -41,6 +42,10 @@ class Yesod a where errorHandler :: ErrorResult -> Handler a RepChooser errorHandler = defaultErrorHandler + -- | The template directory. Blank means no templates. + templateDir :: a -> FilePath + templateDir _ = "" + class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot @@ -80,7 +85,12 @@ toHackApp' y env = do verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - res <- runHandler handler errorHandler rr y types + -- FIXME don't do the templateDir thing for each request + let td = templateDir y + tg <- if null td + then return nullGroup + else directoryGroupRecursiveLazy td + res <- runHandler handler errorHandler rr y tg types let langs = ["en"] -- FIXME responseToHackResponse langs res diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index eed35ddd..69aa4a87 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -4,7 +4,7 @@ import Yesod import Hack.Handler.SimpleServer -data HelloWorld = HelloWorld TemplateGroup +data HelloWorld = HelloWorld instance Yesod HelloWorld where handlers = [$resources| /: @@ -12,9 +12,7 @@ instance Yesod HelloWorld where /groups: Get: helloGroup |] - -instance YesodTemplates HelloWorld where - templates (HelloWorld g) = g + templateDir _ = "examples" helloWorld :: Handler HelloWorld TemplateFile helloWorld = return $ TemplateFile "examples/template.html" $ cs @@ -22,11 +20,10 @@ helloWorld = return $ TemplateFile "examples/template.html" $ cs , ("content", "Hey look!! I'm !") ] -helloGroup = template "real-template" $ cs "foo" +helloGroup = template "real-template" "foo" (cs "bar") $ return [] main :: IO () main = do putStrLn "Running..." - stg <- loadTemplates "examples" - run 3000 (toHackApp $ HelloWorld stg) + run 3000 $ toHackApp HelloWorld \end{code} diff --git a/examples/real-template.st b/examples/real-template.st index 4348e29e..5adaa77d 100644 --- a/examples/real-template.st +++ b/examples/real-template.st @@ -1 +1,2 @@ This is a more realistic template. +foo: $foo$ diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index c0f03e3a..03c0b88c 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod +import Text.StringTemplate (nullGroup) data MyYesod = MyYesod @@ -54,7 +55,7 @@ ph h = do rr = error "No raw request" y = MyYesod cts = [TypeHtml] - res <- runHandler h eh rr y cts + res <- runHandler h eh rr y nullGroup cts print res main :: IO () diff --git a/yesod.cabal b/yesod.cabal index 05820d8e..d0d71895 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -51,7 +51,8 @@ library HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, - template-haskell + template-haskell, + failure >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Constants Yesod.Rep @@ -62,7 +63,7 @@ library Yesod.Handler Yesod.Resource Yesod.Yesod - Yesod.Templates + Yesod.Template Data.Object.Html Hack.Middleware.MethodOverride Hack.Middleware.ClientSession From 13d344488185b314c4b2208faaaa71239886ff8b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 31 Dec 2009 02:40:32 +0200 Subject: [PATCH 107/624] Method override is case insensitive --- Hack/Middleware/MethodOverride.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Hack/Middleware/MethodOverride.hs b/Hack/Middleware/MethodOverride.hs index 940c168d..a26de677 100644 --- a/Hack/Middleware/MethodOverride.hs +++ b/Hack/Middleware/MethodOverride.hs @@ -18,6 +18,7 @@ module Hack.Middleware.MethodOverride (methodOverride) where import Hack import Web.Encodings (decodeUrlPairs) import Data.Monoid (mappend) +import Data.Char methodOverride :: Middleware methodOverride app env = do @@ -28,7 +29,7 @@ methodOverride app env = do app $ case mo1 `mappend` mo2 of Nothing -> env - Just nm -> env { requestMethod = safeRead cm nm } + Just nm -> env { requestMethod = safeRead cm $ map toUpper nm } safeRead :: Read a => a -> String -> a safeRead d s = From 40875730884db87354e05d63d637cb98c6b7bfd7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 31 Dec 2009 02:41:20 +0200 Subject: [PATCH 108/624] authIdentifier (automatic login redirection) --- Yesod/Helpers/Auth.hs | 52 +++++++++++++++++++++++++++++++------------ Yesod/Request.hs | 22 +++++++----------- Yesod/Yesod.hs | 4 ++++ 3 files changed, 50 insertions(+), 28 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 5d964c43..a2f7b13e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -16,9 +16,9 @@ module Yesod.Helpers.Auth ( authHandler , YesodAuth (..) + , authIdentifier ) where -import qualified Hack import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId @@ -31,10 +31,27 @@ import Control.Monad.Attempt import Data.Maybe (fromMaybe) -class Yesod a => YesodAuth a where +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/" + + defaultLoginPath :: a -> String + defaultLoginPath a = authRoot a ++ "openid/" + rpxnowApiKey :: a -> Maybe String rpxnowApiKey _ = Nothing +getFullAuthRoot :: YesodAuth y => Handler y String +getFullAuthRoot = do + y <- getYesod + let (Approot ar) = approot y + return $ ar ++ authRoot y + data AuthResource = Check | Logout @@ -85,13 +102,11 @@ authOpenidForm = do Nothing -> return () return $ cs html -authOpenidForward :: Handler y HtmlObject +authOpenidForward :: YesodAuth y => Handler y HtmlObject authOpenidForward = do oid <- getParam "openid" - env <- parseEnv - let complete = "http://" ++ Hack.serverName env ++ ":" ++ - show (Hack.serverPort env) ++ - "/auth/openid/complete/" + authroot <- getFullAuthRoot + let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err)) @@ -145,15 +160,24 @@ rpxnowLogin = do authCheck :: Handler y HtmlObject authCheck = do - ident <- maybeIdentifier - case ident of - Nothing -> return $ toHtmlObject [("status", "notloggedin")] - Just i -> return $ toHtmlObject - [ ("status", "loggedin") - , ("ident", i) - ] + ident <- identifier + return $ toHtmlObject [("identifier", fromMaybe "" ident)] authLogout :: Handler y HtmlObject authLogout = do deleteCookie authCookieName return $ toHtmlObject [("status", "loggedout")] + +authIdentifier :: YesodAuth y => Handler y String +authIdentifier = do + mi <- identifier + Approot ar <- getApproot + case mi of + Nothing -> do + rp <- requestPath + let dest = ar ++ rp + liftIO $ print ("authIdentifier", dest, ar, rp) + lp <- defaultLoginPath `fmap` getYesod + addCookie 120 "DEST" dest + redirect $ ar ++ lp + Just x -> return x diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 01cdf535..9373776b 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -36,7 +36,6 @@ module Yesod.Request , anyParam , cookieParam , identifier - , maybeIdentifier , acceptedLanguages , requestPath , parseEnv @@ -164,19 +163,10 @@ anyParam = genParam anyParams PostParam -- FIXME cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a cookieParam = genParam cookies CookieParam --- | Extract the cookie which specifies the identifier for a logged in --- user. -identifier :: MonadRequestReader m => m String -identifier = do - mi <- maybeIdentifier - case mi of - Nothing -> authRequired - Just x -> return x - -- | Extract the cookie which specifies the identifier for a logged in -- user, if available. -maybeIdentifier :: MonadRequestReader m => m (Maybe String) -maybeIdentifier = do +identifier :: MonadRequestReader m => m (Maybe String) +identifier = do env <- parseEnv case lookup authCookieName $ Hack.hackHeaders env of Nothing -> return Nothing @@ -203,7 +193,10 @@ requestPath = do "" -> "" q'@('?':_) -> q' q' -> q' - return $! Hack.pathInfo env ++ q + return $! dropSlash (Hack.pathInfo env) ++ q + where + dropSlash ('/':x) = x + dropSlash x = x type PathInfo = [String] @@ -285,9 +278,10 @@ instance Parameter Day where then Right $ fromGregorian y m d else Left $ "Invalid date: " ++ s --- for checkboxes; checks for presence +-- for checkboxes; checks for presence or a "false" value instance Parameter Bool where readParams [] = Right False + readParams [RawParam _ _ "false"] = Right False readParams [_] = Right True readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 294fb6db..7866277b 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -2,6 +2,7 @@ module Yesod.Yesod ( Yesod (..) , YesodApproot (..) + , getApproot , toHackApp ) where @@ -50,6 +51,9 @@ class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot +getApproot :: YesodApproot y => Handler y Approot +getApproot = approot `fmap` getYesod + defaultErrorHandler :: Yesod y => ErrorResult -> Handler y RepChooser From 24c9e5c54ae1c919f485dd3a835f1aead1d206ad Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 31 Dec 2009 15:27:36 +0200 Subject: [PATCH 109/624] Integrated tests into test suite --- test/errors.hs => Test/Errors.hs | 27 +++++++++---- .../QuasiResource.hs | 38 +++++++++++++------ {test => Test}/rep.st | 0 {test => Test}/resource-patterns.yaml | 0 Yesod.hs | 17 +++++++-- Yesod/Helpers/Auth.hs | 1 - Yesod/Rep.hs | 2 +- Yesod/Resource.hs | 4 +- examples/fact.lhs | 1 + examples/hellotemplate.lhs | 1 + runtests.hs | 4 ++ 11 files changed, 68 insertions(+), 27 deletions(-) rename test/errors.hs => Test/Errors.hs (54%) rename test/quasi-resource.hs => Test/QuasiResource.hs (68%) rename {test => Test}/rep.st (100%) rename {test => Test}/resource-patterns.yaml (100%) diff --git a/test/errors.hs b/Test/Errors.hs similarity index 54% rename from test/errors.hs rename to Test/Errors.hs index b841f1ba..f4d142d3 100644 --- a/test/errors.hs +++ b/Test/Errors.hs @@ -1,8 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} +module Test.Errors (testSuite) where + import Yesod +import Yesod.Helpers.Auth import Hack import Data.Default import Data.List +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) data Errors = Errors instance Yesod Errors where @@ -14,13 +20,16 @@ instance Yesod Errors where /has-args: Get: hasArgs |] +instance YesodApproot Errors where + approot _ = Approot "IGNORED/" +instance YesodAuth Errors denied :: Handler Errors () denied = permissionDenied needsIdent :: Handler Errors HtmlObject needsIdent = do - i <- identifier + i <- authIdentifier return $ toHtmlObject i hasArgs :: Handler Errors HtmlObject @@ -30,14 +39,18 @@ hasArgs = do b <- getParam "secondParam" return $ toHtmlObject [a :: String, b] -main = do +caseErrorMessages :: Assertion +caseErrorMessages = do let app = toHackApp Errors res <- app $ def { pathInfo = "/denied/" } - print res - print $ "Permission denied" `isInfixOf` show res + assertBool "/denied/" $ "Permission denied" `isInfixOf` show res res' <- app $ def { pathInfo = "/needs-ident/" } print res' - print $ "Permission denied" `isInfixOf` show res' + assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' res3 <- app $ def { pathInfo = "/has-args/" } - print res3 - print $ "secondParam" `isInfixOf` show res3 + assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 + +testSuite :: Test +testSuite = testGroup "Test.Errors" + [ testCase "errorMessages" caseErrorMessages + ] diff --git a/test/quasi-resource.hs b/Test/QuasiResource.hs similarity index 68% rename from test/quasi-resource.hs rename to Test/QuasiResource.hs index 03c0b88c..0e610c98 100644 --- a/test/quasi-resource.hs +++ b/Test/QuasiResource.hs @@ -1,8 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} +module Test.QuasiResource (testSuite) where + import Yesod import Text.StringTemplate (nullGroup) +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Data.List data MyYesod = MyYesod @@ -49,21 +55,29 @@ handler = [$resources| Get: userPage |] -ph :: Handler MyYesod RepChooser -> IO () -ph h = do +ph :: [String] -> Handler MyYesod RepChooser -> Assertion +ph ss h = do let eh = return . chooseRep . toHtmlObject . show rr = error "No raw request" y = MyYesod cts = [TypeHtml] res <- runHandler h eh rr y nullGroup cts - print res + mapM_ (helper $ show res) ss + where + helper haystack needle = + assertBool needle $ needle `isInfixOf` haystack -main :: IO () -main = do - ph $ handler ["static", "foo", "bar", "baz"] Get - ph $ handler ["foo", "bar", "baz"] Get - ph $ handler ["page"] Get - ph $ handler ["user"] Get - ph $ handler ["user", "five"] Get - ph $ handler ["user", "5"] Get - ph $ handler ["user", "5", "profile", "email"] Get +caseQuasi :: Assertion +caseQuasi = do + ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] Get + ph ["404"] $ handler ["foo", "bar", "baz"] Get + ph ["200", "pageIndex"] $ handler ["page"] Get + ph ["404"] $ handler ["user"] Get + ph ["404"] $ handler ["user", "five"] Get + ph ["200", "userInfo", "5"] $ handler ["user", "5"] Get + ph ["200", "userVar"] $ handler ["user", "5", "profile", "email"] Get + +testSuite :: Test +testSuite = testGroup "Test.QuasiResource" + [ testCase "quasi" caseQuasi + ] diff --git a/test/rep.st b/Test/rep.st similarity index 100% rename from test/rep.st rename to Test/rep.st diff --git a/test/resource-patterns.yaml b/Test/resource-patterns.yaml similarity index 100% rename from test/resource-patterns.yaml rename to Test/resource-patterns.yaml diff --git a/Yesod.hs b/Yesod.hs index 8f8fa700..c96f9d7b 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod @@ -26,14 +27,22 @@ module Yesod , Application ) where -import Yesod.Request +#if TEST +import Yesod.Resource hiding (testSuite) +import Yesod.Response hiding (testSuite) +import Data.Object.Html hiding (testSuite) +import Yesod.Rep hiding (testSuite) +#else +import Yesod.Resource import Yesod.Response +import Data.Object.Html +import Yesod.Rep +#endif + +import Yesod.Request import Yesod.Yesod import Yesod.Definitions import Yesod.Handler -import Yesod.Resource import Hack (Application) -import Yesod.Rep import Yesod.Template -import Data.Object.Html import Data.Convertible.Text diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index a2f7b13e..3f7831a7 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -176,7 +176,6 @@ authIdentifier = do Nothing -> do rp <- requestPath let dest = ar ++ rp - liftIO $ print ("authIdentifier", dest, ar, rp) lp <- defaultLoginPath `fmap` getYesod addCookie 120 "DEST" dest redirect $ ar ++ lp diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 1b95523d..54bcc786 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -250,7 +250,7 @@ caseChooseRepTemplate = do caseChooseRepTemplateFile :: Assertion caseChooseRepTemplateFile = do - let temp = "test/rep.st" + let temp = "Test/rep.st" ho = toHtmlObject [ ("foo", toHtmlObject "") , ("bar", toHtmlObject ["bar1", "bar2"]) ] diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 81a5cf31..6a77c233 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -479,7 +479,7 @@ instance Arbitrary RPP where caseFromYaml :: Assertion caseFromYaml = do - contents <- readYamlDoc "test/resource-patterns.yaml" + contents <- readYamlDoc "Test/resource-patterns.yaml" rp1 <- readRP "static/*filepath" rp2 <- readRP "page" rp3 <- readRP "page/$page" @@ -498,7 +498,7 @@ caseFromYaml = do caseCheckRPNodes :: Assertion caseCheckRPNodes = do - good' <- readYamlDoc "test/resource-patterns.yaml" + good' <- readYamlDoc "Test/resource-patterns.yaml" good <- fa $ ca good' Just good @=? checkRPNodes good rp1 <- readRP "foo/bar" diff --git a/examples/fact.lhs b/examples/fact.lhs index 70e74c4f..49a6f867 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -87,6 +87,7 @@ 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 > i <- getParam "num" > redirect $ "../" ++ i ++ "/" diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index 69aa4a87..6bb06cb3 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -20,6 +20,7 @@ helloWorld = return $ TemplateFile "examples/template.html" $ cs , ("content", "Hey look!! I'm !") ] +helloGroup :: Handler y Template helloGroup = template "real-template" "foo" (cs "bar") $ return [] main :: IO () diff --git a/runtests.hs b/runtests.hs index e4a7eaca..b7b64c3e 100644 --- a/runtests.hs +++ b/runtests.hs @@ -5,6 +5,8 @@ import qualified Yesod.Utils import qualified Yesod.Resource import qualified Yesod.Rep import qualified Data.Object.Html +import qualified Test.Errors +import qualified Test.QuasiResource main :: IO () main = defaultMain @@ -13,4 +15,6 @@ main = defaultMain , Yesod.Resource.testSuite , Yesod.Rep.testSuite , Data.Object.Html.testSuite + , Test.Errors.testSuite + , Test.QuasiResource.testSuite ] From 58f9f3e0547910e3d78b33ce6b172987b2aa9120 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Jan 2010 03:50:52 +0200 Subject: [PATCH 110/624] Passed the hasArgs in Test.Errors test; ugly hacks, needs cleanup --- TODO | 1 + Test/Errors.hs | 7 +- Yesod.hs | 5 +- Yesod/Definitions.hs | 5 +- Yesod/Handler.hs | 10 +- Yesod/Helpers/Auth.hs | 25 ++--- Yesod/Request.hs | 239 +++++++++++++++--------------------------- Yesod/Yesod.hs | 2 +- runtests.hs | 2 + yesod.cabal | 7 +- 10 files changed, 120 insertions(+), 183 deletions(-) diff --git a/TODO b/TODO index e2c54485..a09e2e82 100644 --- a/TODO +++ b/TODO @@ -2,3 +2,4 @@ Some form of i18n. Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). +Languages (read languages header, set language cookie) diff --git a/Test/Errors.hs b/Test/Errors.hs index f4d142d3..84cbe86f 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -9,6 +9,7 @@ import Data.List import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) +import Control.Applicative data Errors = Errors instance Yesod Errors where @@ -34,9 +35,8 @@ needsIdent = do hasArgs :: Handler Errors HtmlObject hasArgs = do - -- FIXME this test needs more work - a <- getParam "firstParam" - b <- getParam "secondParam" + (a, b) <- runRequest $ (,) <$> getParam "firstParam" + <*> getParam "secondParam" return $ toHtmlObject [a :: String, b] caseErrorMessages :: Assertion @@ -45,7 +45,6 @@ caseErrorMessages = do res <- app $ def { pathInfo = "/denied/" } assertBool "/denied/" $ "Permission denied" `isInfixOf` show res res' <- app $ def { pathInfo = "/needs-ident/" } - print res' assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' res3 <- app $ def { pathInfo = "/has-args/" } assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 diff --git a/Yesod.hs b/Yesod.hs index c96f9d7b..fdc2ce15 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,6 +21,7 @@ module Yesod , module Yesod.Handler , module Yesod.Resource , module Data.Object.Html + , module Yesod.Parameter , module Yesod.Rep , module Yesod.Template , module Data.Convertible.Text @@ -32,14 +33,16 @@ import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) import Data.Object.Html hiding (testSuite) import Yesod.Rep hiding (testSuite) +import Yesod.Request hiding (testSuite) #else import Yesod.Resource import Yesod.Response import Data.Object.Html import Yesod.Rep +import Yesod.Request #endif -import Yesod.Request +import Yesod.Parameter import Yesod.Yesod import Yesod.Definitions import Yesod.Handler diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index e86fc6b9..b3ff2d8d 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -21,6 +21,7 @@ module Yesod.Definitions , Language , Location (..) , showLocation + , PathInfo ) where import qualified Hack @@ -54,7 +55,7 @@ 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. -newtype Approot = Approot { unApproot :: String } +newtype Approot = Approot { unApproot :: String } -- FIXME make type syn? type Language = String @@ -66,3 +67,5 @@ data Location = AbsLoc String | RelLoc String showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s showLocation (Approot ar) (RelLoc s) = ar ++ s + +type PathInfo = [String] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 882e3cb1..ca89257d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,8 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html +import Yesod.Parameter + ------ Handler monad newtype Handler yesod a = Handler { unHandler :: (RawRequest, yesod, TemplateGroup) @@ -80,10 +82,10 @@ instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) -instance MonadRequestReader (Handler yesod) where - askRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) - invalidParam _pt pn pe = invalidArgs [(pn, pe)] - authRequired = permissionDenied +instance RequestReader (Handler yesod) where + getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) + invalidParams = invalidArgs . map helper where + helper ((_pt, pn, _pvs), e) = (pn, show e) getYesod :: Handler yesod yesod getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 3f7831a7..675044b8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -76,8 +76,6 @@ authHandler _ ["login", "rpxnow"] = rc rpxnowLogin authHandler _ _ = notFound data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) -instance Request OIDFormReq where - parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" instance ConvertSuccess OIDFormReq Html where convertSuccess (OIDFormReq Nothing _) = cs "" convertSuccess (OIDFormReq (Just s) _) = @@ -85,7 +83,9 @@ instance ConvertSuccess OIDFormReq Html where authOpenidForm :: Handler y HtmlObject authOpenidForm = do - m@(OIDFormReq _ dest) <- parseRequest + message <- runRequest $ getParam "message" + dest <- runRequest $ getParam "dest" + let m = OIDFormReq message dest let html = HtmlList [ cs m @@ -104,7 +104,7 @@ authOpenidForm = do authOpenidForward :: YesodAuth y => Handler y HtmlObject authOpenidForward = do - oid <- getParam "openid" + oid <- runRequest $ getParam "openid" authroot <- getFullAuthRoot let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete @@ -115,8 +115,8 @@ authOpenidForward = do authOpenidComplete :: Handler y HtmlObject authOpenidComplete = do - gets' <- rawGetParams <$> askRawRequest - dest <- cookieParam "DEST" + gets' <- rawGetParams <$> getRawRequest + dest <- runRequest $ cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' let onFailure err = redirect $ "/auth/openid/?message=" ++ encodeUrl (show err) @@ -127,13 +127,6 @@ authOpenidComplete = do attempt onFailure onSuccess res -- | token dest -data RpxnowRequest = RpxnowRequest String (Maybe String) -instance Request RpxnowRequest where - parseRequest = do - token <- anyParam "token" - dest <- anyParam "dest" - return $! RpxnowRequest token $ chopHash `fmap` dest - chopHash :: String -> String chopHash ('#':rest) = rest chopHash x = x @@ -144,10 +137,10 @@ rpxnowLogin = do apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound - token <- anyParam "token" - postDest <- postParam "dest" + token <- runRequest $ anyParam "token" + postDest <- runRequest $ postParam "dest" dest' <- case postDest of - Nothing -> getParam "dest" + Nothing -> runRequest $ getParam "dest" Just d -> return d let dest = case dest' of Nothing -> "/" diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 9373776b..a0ab2153 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -- Parameter String {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -17,20 +18,11 @@ --------------------------------------------------------- module Yesod.Request ( - -- * Parameter - -- $param_overview - Parameter (..) - , ParamError - , ParamType - , ParamName - , ParamValue - , RawParam (..) -- * RawRequest - , RawRequest (..) - , PathInfo + RawRequest (..) -- * Parameter type class -- * MonadRequestReader type class and helpers - , MonadRequestReader (..) + , RequestReader (..) , getParam , postParam , anyParam @@ -39,88 +31,64 @@ module Yesod.Request , acceptedLanguages , requestPath , parseEnv + , runRequest -- * Building actual request , Request (..) , Hack.RequestMethod (..) -- * Parameter restrictions - , notBlank + -- FIXME , notBlank +#if TEST + , testSuite +#endif ) where import qualified Hack import Data.Function.Predicate (equals) import Yesod.Constants -import Yesod.Utils +import Yesod.Utils (tryLookup, parseHttpAccept) import Yesod.Definitions +import Yesod.Parameter import Control.Applicative (Applicative (..)) import Web.Encodings -import Data.Time.Calendar (Day, fromGregorian) -import Data.Char (isDigit) import qualified Data.ByteString.Lazy as BL import Data.Convertible.Text import Hack.Middleware.CleanPath (splitPath) import Control.Arrow ((***)) +import Control.Exception (Exception, SomeException (..)) +import Data.Typeable (Typeable) +import Data.Attempt --- $param_overview --- In Restful, all of the underlying parameter values are strings. They can --- come from multiple sources: GET parameters, URL rewriting (FIXME: link), --- cookies, etc. However, most applications eventually want to convert --- those strings into something else, like 'Int's. Additionally, it is --- often desirable to allow multiple values, or no value at all. --- --- That is what the parameter concept is for. A 'Parameter' is any value --- which can be converted from a 'String', or list of 'String's. +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif --- | Where this parameter came from. -data ParamType = - GetParam - | PostParam - | CookieParam - deriving (Eq, Show) +newtype Request v = Request { unRequest :: RawRequest + -> Either ParamException v } +instance Functor Request where + fmap f (Request r) = Request $ fmap f . r +instance Applicative Request where + pure = Request . const . Right + (Request f) <*> (Request r) = Request helper where + helper rr = helper2 (f rr) (r rr) + helper2 (Left e1) (Left e2) = Left $ e1 ++ e2 + helper2 (Left e) _ = Left e + helper2 _ (Left e) = Left e + helper2 (Right f') (Right r') = Right $ f' r' --- | Any kind of error message generated in the parsing stage. -type ParamError = String - --- | In GET parameters, the key. In cookies, the cookie name. So on and so --- forth. -type ParamName = String - --- | The 'String' value of a parameter, such as cookie content. -type ParamValue = String - -data RawParam = RawParam - { paramType :: ParamType - , paramName :: ParamName - , paramValue :: ParamValue - } - --- | Anything which can be converted from a 'String' or list of 'String's. --- --- The default implementation of 'readParams' will error out if given --- anything but 1 'ParamValue'. This is usually what you want. --- --- Minimal complete definition: either 'readParam' or 'readParams'. -class Parameter a where - -- | Convert a string into the desired value, or explain why that can't - -- happen. - readParam :: RawParam -> Either ParamError a - readParam = readParams . return - - -- | Convert a list of strings into the desired value, or explain why - -- that can't happen. - readParams :: [RawParam] -> Either ParamError a - readParams [x] = readParam x - readParams [] = Left "Missing parameter" - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 1" - -instance Parameter RawParam where - readParam = Right - -class (Monad m, Functor m, Applicative m) => MonadRequestReader m where - askRawRequest :: m RawRequest - invalidParam :: ParamType -> ParamName -> ParamError -> m a - authRequired :: m a +class RequestReader m where + getRawRequest :: m RawRequest + invalidParams :: ParamException -> m a +instance RequestReader Request where + getRawRequest = Request $ Right + invalidParams = Request . const . Left +runRequest :: (Monad m, RequestReader m) => Request a -> m a +runRequest (Request f) = do + rr <- getRawRequest + either invalidParams return $ f rr +{- FIXME -- | Attempt to parse a list of param values using 'readParams'. -- If that fails, return an error message and an undefined value. This way, -- we can process all of the parameters and get all of the error messages. @@ -133,39 +101,41 @@ tryReadParams:: (Parameter a, MonadRequestReader m) -> m a tryReadParams ptype name params = case readParams params of - Left s -> invalidParam ptype name s - Right x -> return x + Failure s -> invalidParam ptype name s + Success x -> return x +-} -- | Helper function for generating 'RequestParser's from various -- 'ParamValue' lists. -genParam :: (Parameter a, MonadRequestReader m) +genParam :: Parameter a => (RawRequest -> ParamName -> [ParamValue]) -> ParamType -> ParamName - -> m a -genParam f ptype name = do - req <- askRawRequest - tryReadParams ptype name $ map (RawParam ptype name) $ f req name + -> Request a +genParam f ptype name = Request helper where + helper req = attempt failureH Right $ readParams pvs where + pvs = f req name + failureH e = Left [((ptype, name, pvs), SomeException e)] -- | Parse a value passed as a GET parameter. -getParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +getParam :: (Parameter a) => ParamName -> Request a getParam = genParam getParams GetParam -- | Parse a value passed as a POST parameter. -postParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +postParam :: (Parameter a) => ParamName -> Request a postParam = genParam postParams PostParam -- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +anyParam :: (Parameter a) => ParamName -> Request a anyParam = genParam anyParams PostParam -- FIXME -- | Parse a value passed as a raw cookie. -cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a +cookieParam :: (Parameter a) => ParamName -> Request a cookieParam = genParam cookies CookieParam -- | Extract the cookie which specifies the identifier for a logged in -- user, if available. -identifier :: MonadRequestReader m => m (Maybe String) +identifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) identifier = do env <- parseEnv case lookup authCookieName $ Hack.hackHeaders env of @@ -173,20 +143,20 @@ identifier = do Just x -> return (Just x) -- | Get the raw 'Hack.Env' value. -parseEnv :: MonadRequestReader m => m Hack.Env -parseEnv = rawEnv `fmap` askRawRequest +parseEnv :: (Functor m, RequestReader m) => m Hack.Env +parseEnv = rawEnv `fmap` getRawRequest -- | Determine the ordered list of language preferences. -- -- FIXME: Future versions should account for some cookie. -acceptedLanguages :: MonadRequestReader m => m [String] +acceptedLanguages :: (Functor m, Monad m, RequestReader m) => m [String] acceptedLanguages = do env <- parseEnv let rawLang = tryLookup "" "Accept-Language" $ Hack.http env return $! parseHttpAccept rawLang -- | Determinge the path requested by the user (ie, the path info). -requestPath :: MonadRequestReader m => m String +requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath = do env <- parseEnv let q = case Hack.queryString env of @@ -198,8 +168,6 @@ requestPath = do dropSlash ('/':x) = x dropSlash x = x -type PathInfo = [String] - -- | The raw information passed through Hack, cleaned up a bit. data RawRequest = RawRequest { rawPathInfo :: PathInfo @@ -235,73 +203,18 @@ anyParams req name = getParams req name ++ cookies :: RawRequest -> ParamName -> [ParamValue] cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr -instance Parameter a => Parameter (Maybe a) where - readParams [] = Right Nothing - readParams [x] = Just `fmap` readParam x - readParams xs = Left $ "Given " ++ show (length xs) ++ - " values, expecting 0 or 1" - -instance Parameter a => Parameter [a] where - readParams = mapM' readParam where - mapM' f = sequence' . map f - sequence' :: [Either String v] -> Either String [v] - sequence' [] = Right [] - sequence' (Left l:_) = Left l - sequence' (Right r:rest) = - case sequence' rest of - Left l -> Left l - Right rest' -> Right $ r : rest' - -instance Parameter String where - readParam = Right . paramValue - -instance Parameter Int where - readParam (RawParam _ _ s) = case reads s of - ((x, _):_) -> Right x - _ -> Left $ "Invalid integer: " ++ s - -instance Parameter Day where - readParam (RawParam _ _ s) = - let t1 = length s == 10 - t2 = s !! 4 == '-' - t3 = s !! 7 == '-' - t4 = all isDigit $ concat - [ take 4 s - , take 2 $ drop 5 s - , take 2 $ drop 8 s - ] - t = and [t1, t2, t3, t4] - y = read $ take 4 s - m = read $ take 2 $ drop 5 s - d = read $ take 2 $ drop 8 s - in if t - then Right $ fromGregorian y m d - else Left $ "Invalid date: " ++ s - --- for checkboxes; checks for presence or a "false" value -instance Parameter Bool where - readParams [] = Right False - readParams [RawParam _ _ "false"] = Right False - readParams [_] = Right True - readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x) - --- | The input for a resource. --- --- Each resource can define its own instance of 'Request' and then more --- easily ensure that it received the correct input (ie, correct variables, --- properly typed). -class Request a where - parseRequest :: MonadRequestReader m => m a - -instance Request () where - parseRequest = return () - +{- FIXME -- | Ensures that a String parameter is not blank. notBlank :: MonadRequestReader m => RawParam -> m String notBlank rp = case paramValue rp of - "" -> invalidParam (paramType rp) (paramName rp) "Required field" + "" -> invalidParam (paramType rp) (paramName rp) RequiredField s -> return s +-} + +data RequiredField = RequiredField + deriving (Show, Typeable) +instance Exception RequiredField instance ConvertSuccess Hack.Env RawRequest where convertSuccess env = @@ -318,3 +231,21 @@ instance ConvertSuccess Hack.Env RawRequest where cookies' = decodeCookies rawCookie :: [(String, String)] langs = ["en"] -- FIXME in RawRequest rawPieces gets' posts cookies' files env langs + +#if TEST +testSuite :: Test +testSuite = testGroup "Yesod.Request" + [ testCase "Request applicative instance" caseAppInst + ] + +caseAppInst :: Assertion +caseAppInst = do + let r5 = Request $ const $ Right 5 + rAdd2 = Request $ const $ Right (+ 2) + r7 = Request $ const $ Right 7 + rr = undefined + myEquals e t = (unRequest e) rr `myEquals2` (unRequest t) rr + myEquals2 x y = show x @=? show y + r5 `myEquals` pure 5 + r7 `myEquals` (rAdd2 <*> r5) +#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7866277b..c6d5edb8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -58,7 +58,7 @@ defaultErrorHandler :: Yesod y => ErrorResult -> Handler y RepChooser defaultErrorHandler NotFound = do - rr <- askRawRequest + rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr defaultErrorHandler (Redirect url) = return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url diff --git a/runtests.hs b/runtests.hs index b7b64c3e..6da45977 100644 --- a/runtests.hs +++ b/runtests.hs @@ -4,6 +4,7 @@ import qualified Yesod.Response import qualified Yesod.Utils import qualified Yesod.Resource import qualified Yesod.Rep +import qualified Yesod.Request import qualified Data.Object.Html import qualified Test.Errors import qualified Test.QuasiResource @@ -14,6 +15,7 @@ main = defaultMain , Yesod.Utils.testSuite , Yesod.Resource.testSuite , Yesod.Rep.testSuite + , Yesod.Request.testSuite , Data.Object.Html.testSuite , Test.Errors.testSuite , Test.QuasiResource.testSuite diff --git a/yesod.cabal b/yesod.cabal index d0d71895..a6e4ff0f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -52,7 +52,8 @@ library data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, template-haskell, - failure >= 0.0.0 && < 0.1 + failure >= 0.0.0 && < 0.1, + safe-failure >= 0.4.0 && < 0.5 exposed-modules: Yesod Yesod.Constants Yesod.Rep @@ -61,6 +62,7 @@ library Yesod.Utils Yesod.Definitions Yesod.Handler + Yesod.Parameter Yesod.Resource Yesod.Yesod Yesod.Template @@ -84,7 +86,8 @@ executable runtests test-framework-quickcheck, test-framework-hunit, HUnit, - QuickCheck >= 1 && < 2 + QuickCheck >= 1 && < 2, + data-default >= 0.2 && < 0.3 else Buildable: False ghc-options: -Wall From db1d0b306a6d85aac0cda72a6d7970317f3778e2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Jan 2010 03:51:12 +0200 Subject: [PATCH 111/624] Adding missing Parameter file --- Yesod/Parameter.hs | 124 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) create mode 100644 Yesod/Parameter.hs diff --git a/Yesod/Parameter.hs b/Yesod/Parameter.hs new file mode 100644 index 00000000..d8e2bb7e --- /dev/null +++ b/Yesod/Parameter.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverlappingInstances #-} -- Parameter String +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +module Yesod.Parameter + ( + -- * Parameter + -- $param_overview + Parameter (..) + , ParamType (..) + , ParamName + , ParamValue + , ParamAttempt (..) + , ParamException + -- * Exceptions + , ParameterCountException (..) + , InvalidBool (..) + ) where + +import Data.Time.Calendar (Day) +import Control.Applicative +import Data.Typeable (Typeable) +import Control.Exception (Exception, SomeException (..)) +import Data.Attempt +import qualified Safe.Failure as SF +import Data.Convertible.Text + +-- FIXME instead of plain Attempt, an Attempt that defines better error +-- reporting (eg, multilingual) + +-- $param_overview +-- In Restful, all of the underlying parameter values are strings. They can +-- come from multiple sources: GET parameters, URL rewriting (FIXME: link), +-- cookies, etc. However, most applications eventually want to convert +-- those strings into something else, like 'Int's. Additionally, it is +-- often desirable to allow multiple values, or no value at all. +-- +-- That is what the parameter concept is for. A 'Parameter' is any value +-- which can be converted from a 'String', or list of 'String's. + +-- | Where this parameter came from. +data ParamType = + GetParam + | PostParam + | CookieParam + deriving (Eq, Show) + +-- | In GET parameters, the key. In cookies, the cookie name. So on and so +-- forth. +type ParamName = String + +-- | The 'String' value of a parameter, such as cookie content. +type ParamValue = String + +-- | Anything which can be converted from a list of 'String's. +-- +-- The default implementation of 'readParams' will error out if given +-- anything but 1 'ParamValue'. This is usually what you want. +-- +-- Minimal complete definition: either 'readParam' or 'readParams'. +class Parameter a where + -- | Convert a string into the desired value, or explain why that can't + -- happen. + readParam :: ParamValue -> Attempt a + readParam = readParams . return + + -- | Convert a list of strings into the desired value, or explain why + -- that can't happen. + readParams :: [ParamValue] -> Attempt a + readParams [x] = readParam x + readParams [] = failure MissingParameter + readParams xs = failure $ ExtraParameters $ length xs + +data ParamAttempt v = ParamSuccess v + | ParamFailure ParamException +instance Functor ParamAttempt where + fmap _ (ParamFailure pf) = ParamFailure pf + fmap f (ParamSuccess v) = ParamSuccess $ f v +instance Applicative ParamAttempt where + pure = ParamSuccess + (ParamFailure pf1) <*> (ParamFailure pf2) = ParamFailure $ pf1 ++ pf2 + (ParamFailure pf) <*> _ = ParamFailure pf + _ <*> ParamFailure pf = ParamFailure pf + (ParamSuccess f) <*> (ParamSuccess v) = ParamSuccess $ f v +instance Try ParamAttempt where + type Error ParamAttempt = ParamException + try (ParamSuccess v) = pure v + try (ParamFailure f) = failure f +type ParamException = [((ParamType, ParamName, [ParamValue]), SomeException)] + +data ParameterCountException = MissingParameter | ExtraParameters Int + deriving (Show, Typeable) +instance Exception ParameterCountException + +instance Parameter a => Parameter (Maybe a) where + readParams [] = return Nothing + readParams [x] = Just `fmap` readParam x + readParams xs = failure $ ExtraParameters $ length xs + +instance Parameter a => Parameter [a] where + readParams = mapM readParam where + +instance Parameter String where + readParam = return + +instance Parameter Int where + readParam = ca + +instance Parameter Integer where + readParam = SF.read + +instance Parameter Day where + readParam = ca + +-- for checkboxes; checks for presence or a "false" value +instance Parameter Bool where + readParams [] = return False + readParams ["false"] = return False -- FIXME more values? + readParams [_] = return True + readParams x = failure $ InvalidBool x + +data InvalidBool = InvalidBool [ParamValue] + deriving (Show, Typeable) +instance Exception InvalidBool From f21db91a0fa85fe98307c30bc942894d429bc806 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Jan 2010 22:46:58 +0200 Subject: [PATCH 112/624] Removed unnecesary code from Auth --- Yesod/Helpers/Auth.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 675044b8..7e919402 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -26,7 +26,7 @@ import qualified Web.Authenticate.OpenId as OpenId import Yesod import Yesod.Constants -import Control.Applicative ((<$>), Applicative (..)) +import Control.Applicative ((<$>)) import Control.Monad.Attempt import Data.Maybe (fromMaybe) @@ -126,11 +126,6 @@ authOpenidComplete = do redirect $ fromMaybe "/" dest attempt onFailure onSuccess res --- | token dest -chopHash :: String -> String -chopHash ('#':rest) = rest -chopHash x = x - rpxnowLogin :: YesodAuth y => Handler y HtmlObject rpxnowLogin = do ay <- getYesod From 12a43ef90b365d28bc13d7ac47cd4672b8fbd58c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Jan 2010 22:35:41 +0200 Subject: [PATCH 113/624] Logout redirect to approot; displayname --- Yesod/Constants.hs | 8 ++++++++ Yesod/Helpers/Auth.hs | 23 ++++++++++++++++++++--- Yesod/Request.hs | 8 ++++++++ Yesod/Yesod.hs | 2 +- 4 files changed, 37 insertions(+), 4 deletions(-) diff --git a/Yesod/Constants.hs b/Yesod/Constants.hs index 3fe16922..9879f625 100644 --- a/Yesod/Constants.hs +++ b/Yesod/Constants.hs @@ -13,7 +13,15 @@ --------------------------------------------------------- module Yesod.Constants ( authCookieName + , authDisplayName + , encryptedCookies ) where authCookieName :: String authCookieName = "IDENTIFIER" + +authDisplayName :: String +authDisplayName = "DISPLAY_NAME" + +encryptedCookies :: [String] +encryptedCookies = [authDisplayName, authCookieName] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 7e919402..be5914eb 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -144,17 +144,34 @@ rpxnowLogin = do Just s -> s ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident + header authDisplayName $ getDisplayName ident redirect dest +-- | 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 :: Handler y HtmlObject authCheck = do ident <- identifier - return $ toHtmlObject [("identifier", fromMaybe "" ident)] + dn <- displayName + return $ toHtmlObject + [ ("identifier", fromMaybe "" ident) + , ("displayName", fromMaybe "" dn) + ] -authLogout :: Handler y HtmlObject +authLogout :: YesodAuth y => Handler y HtmlObject authLogout = do deleteCookie authCookieName - return $ toHtmlObject [("status", "loggedout")] + y <- getYesod + let (Approot ar) = approot y + redirect ar + -- FIXME check the DEST information authIdentifier :: YesodAuth y => Handler y String authIdentifier = do diff --git a/Yesod/Request.hs b/Yesod/Request.hs index a0ab2153..fecaf724 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -28,6 +28,7 @@ module Yesod.Request , anyParam , cookieParam , identifier + , displayName , acceptedLanguages , requestPath , parseEnv @@ -142,6 +143,13 @@ identifier = do Nothing -> return Nothing Just x -> return (Just x) +displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) +displayName = do + env <- parseEnv + case lookup authDisplayName $ Hack.hackHeaders env of + Nothing -> return Nothing + Just x -> return (Just x) + -- | Get the raw 'Hack.Env' value. parseEnv :: (Functor m, RequestReader m) => m Hack.Env parseEnv = rawEnv `fmap` getRawRequest diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c6d5edb8..6344bf3e 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -80,7 +80,7 @@ toHackApp a env = do let app' = toHackApp' a let mins = clientSessionDuration a (gzip $ cleanPath $ jsonp $ methodOverride - $ clientsession [authCookieName] key mins $ app') env + $ clientsession encryptedCookies key mins $ app') env toHackApp' :: Yesod y => y -> Hack.Application toHackApp' y env = do From aff7722e12fc3cbd6ad66c94f5852dd12b1fd074 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 6 Jan 2010 21:27:56 +0200 Subject: [PATCH 114/624] Approot used in rpxnow login --- TODO | 1 + Yesod/Helpers/Auth.hs | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/TODO b/TODO index a09e2e82..a44ffdf5 100644 --- a/TODO +++ b/TODO @@ -3,3 +3,4 @@ Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). Languages (read languages header, set language cookie) +Approot and trailing slash missing diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index be5914eb..ed28c533 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -129,6 +129,7 @@ authOpenidComplete = do rpxnowLogin :: YesodAuth y => Handler y HtmlObject rpxnowLogin = do ay <- getYesod + let (Approot ar) = approot ay apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound @@ -138,8 +139,8 @@ rpxnowLogin = do Nothing -> runRequest $ getParam "dest" Just d -> return d let dest = case dest' of - Nothing -> "/" - Just "" -> "/" + Nothing -> ar + Just "" -> ar Just ('#':rest) -> rest Just s -> s ident <- Rpxnow.authenticate apiKey token From 1f9d11eb292f50e9a20cd8e2c19b293855011707 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Jan 2010 00:18:28 +0200 Subject: [PATCH 115/624] Building lists of strict text in HtmlObject --- Data/Object/Html.hs | 79 +++++++++++++++++++++++---------------------- 1 file changed, 41 insertions(+), 38 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 8ed6ff77..c1eaeed8 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -26,6 +26,8 @@ module Data.Object.Html -- * Standard 'Object' functions , toHtmlObject , fromHtmlObject + -- * Re-export + , module Data.Object #if TEST , testSuite #endif @@ -35,11 +37,13 @@ import Data.Generics import Data.Object.Text import Data.Object.Json import qualified Data.Text.Lazy as TL +import qualified Data.Text as TS import Data.ByteString.Lazy (ByteString) import Web.Encodings import Text.StringTemplate.Classes import Control.Arrow (second) import Data.Attempt +import Data.Object #if TEST import Test.Framework (testGroup, Test) @@ -50,8 +54,8 @@ import Text.StringTemplate -- | A single piece of HTML code. data Html = - Html Text -- ^ Already encoded HTML. - | Text Text -- ^ Text which should be HTML escaped. + 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] @@ -70,57 +74,56 @@ fromHtmlObject = ca instance ConvertSuccess String Html where convertSuccess = Text . cs -instance ConvertSuccess Text Html where +instance ConvertSuccess TS.Text Html where convertSuccess = Text +instance ConvertSuccess Text Html where + convertSuccess = Text . cs $(deriveAttempts [ (''String, ''Html) , (''Text, ''Html) + , (''TS.Text, ''Html) ]) -showAttribs :: [(String, String)] -> Text -showAttribs = TL.concat . map helper where - helper :: (String, String) -> Text - helper (k, v) = TL.concat - [ cs " " - , encodeHtml $ cs k - , cs "=\"" - , encodeHtml $ cs v - , cs "\"" - ] +showAttribs :: [(String, String)] -> String -> String +showAttribs pairs rest = foldr ($) rest $ map helper 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 - -> Text -htmlToText _ (Html t) = t -htmlToText _ (Text t) = encodeHtml t -htmlToText xml (Tag n as content) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs ">" - , htmlToText xml content - , cs "" - ] -htmlToText xml (EmptyTag n as) = TL.concat - [ cs "<" - , cs n - , showAttribs as - , cs $ if xml then "/>" else ">" - ] -htmlToText xml (HtmlList l) = TL.concat $ map (htmlToText xml) l + -> ([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) = \rest -> + foldr ($) rest $ map (htmlToText xml) l +newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text } +instance ConvertSuccess Html HtmlFragment where + convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ [] +-- FIXME remove the next instance instance ConvertSuccess Html Text where - convertSuccess = htmlToText False + convertSuccess h = TL.fromChunks . htmlToText False h $ [] -- | 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.concat - [ cs "\n" - , htmlToText True h - ] + convertSuccess h = XmlDoc $ TL.fromChunks $ + cs "\n" + : htmlToText True h [] -- | Wrap an 'Html' in CDATA for XML output. cdata :: Html -> Html From a5893f5621ad5edb9f8da21943ac1d79b79dcb40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Jan 2010 00:59:10 +0200 Subject: [PATCH 116/624] Fixed other code to reflect HtmlObject changes --- Data/Object/Html.hs | 44 ++++++++++++++++++++++++-------------------- Yesod.hs | 2 -- Yesod/Rep.hs | 5 ++--- 3 files changed, 26 insertions(+), 25 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index c1eaeed8..3a228cf1 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -19,6 +19,7 @@ module Data.Object.Html ( -- * Data type Html (..) , HtmlDoc (..) + , HtmlFragment (..) , HtmlObject -- * XML helpers , XmlDoc (..) @@ -38,7 +39,6 @@ import Data.Object.Text import Data.Object.Json import qualified Data.Text.Lazy as TL import qualified Data.Text as TS -import Data.ByteString.Lazy (ByteString) import Web.Encodings import Text.StringTemplate.Classes import Control.Arrow (second) @@ -84,6 +84,19 @@ $(deriveAttempts , (''TS.Text, ''Html) ]) +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, 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 ($) rest $ map helper pairs where helper :: (String, String) -> String -> String @@ -114,9 +127,8 @@ htmlToText xml (HtmlList l) = \rest -> newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text } instance ConvertSuccess Html HtmlFragment where convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ [] --- FIXME remove the next instance -instance ConvertSuccess Html Text where - convertSuccess h = 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 } @@ -133,18 +145,11 @@ cdata h = HtmlList , Html $ cs "]]>" ] -instance ConvertSuccess Html String where - convertSuccess = cs . (cs :: Html -> Text) -instance ConvertSuccess Html ByteString where - convertSuccess = cs . (cs :: Html -> Text) - instance ConvertSuccess Html HtmlDoc where - convertSuccess h = HtmlDoc $ TL.concat - [ cs "HtmlDoc (autogenerated)" - , cs "" - , cs h - , cs "" - ] + convertSuccess h = HtmlDoc $ TL.fromChunks $ + cs "\nHtmlDoc (autogenerated)" + : htmlToText False h + [cs ""] instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h @@ -162,25 +167,24 @@ instance ConvertSuccess HtmlObject HtmlDoc where convertSuccess = cs . (cs :: HtmlObject -> Html) instance ConvertSuccess Html JsonScalar where - convertSuccess = cs . (cs :: Html -> Text) + convertSuccess = cs . unHtmlFragment . cs instance ConvertSuccess HtmlObject JsonObject where convertSuccess = mapKeysValues convertSuccess convertSuccess instance ConvertSuccess HtmlObject JsonDoc where convertSuccess = cs . (cs :: HtmlObject -> JsonObject) $(deriveAttempts - [ (''Html, ''String) - , (''Html, ''Text) + [ (''Html, ''HtmlFragment) , (''Html, ''HtmlDoc) , (''Html, ''JsonScalar) ]) $(deriveSuccessConvs ''String ''Html [''String, ''Text] - [''Html, ''String, ''Text]) + [''Html, ''HtmlFragment]) instance ToSElem HtmlObject where - toSElem (Scalar h) = STR $ TL.unpack $ cs h + 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 diff --git a/Yesod.hs b/Yesod.hs index fdc2ce15..8ebda038 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -24,7 +24,6 @@ module Yesod , module Yesod.Parameter , module Yesod.Rep , module Yesod.Template - , module Data.Convertible.Text , Application ) where @@ -48,4 +47,3 @@ import Yesod.Definitions import Yesod.Handler import Hack (Application) import Yesod.Template -import Data.Convertible.Text diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 54bcc786..509a9f32 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -57,7 +57,6 @@ import Data.Object.Html #endif import Data.Object.Json -import Data.Convertible.Text import Text.StringTemplate #if TEST @@ -109,8 +108,8 @@ instance ConvertSuccess ByteString Content where convertSuccess = Content instance ConvertSuccess String Content where convertSuccess = Content . cs -instance ConvertSuccess Html Content where - convertSuccess = Content . cs +instance ConvertSuccess HtmlDoc Content where + convertSuccess = cs . unHtmlDoc instance ConvertSuccess XmlDoc Content where convertSuccess = cs . unXmlDoc From 953d66542a8a5ab5430b1ec1773c18f8c4b7d08f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 21 Jan 2010 20:00:22 +0200 Subject: [PATCH 117/624] Basic upgrade to data-object-yaml 0.2.0 --- Yesod/Resource.hs | 4 +--- yesod.cabal | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 6a77c233..ad28b3cf 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -216,8 +216,6 @@ data RPNode = RPNode RP VerbMap deriving (Show, Eq) data VerbMap = AllVerbs String | Verbs [(Verb, String)] deriving (Show, Eq) -instance ConvertAttempt YamlDoc [RPNode] where - convertAttempt = fromTextObject <=< ca instance ConvertAttempt TextObject [RPNode] where convertAttempt = mapM helper <=< fromMapping where helper :: (Text, TextObject) -> Attempt RPNode @@ -384,7 +382,7 @@ liftVerbMap (Verbs vs) r rp = do strToExp :: Bool -> String -> Q Exp strToExp toCheck s = do - rpnodes <- runIO $ convertAttemptWrap $ YamlDoc $ cs s + rpnodes <- runIO $ decode (cs s) >>= \to -> convertAttemptWrap (to :: TextObject) (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes #if TEST diff --git a/yesod.cabal b/yesod.cabal index a6e4ff0f..57dfd552 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -39,7 +39,7 @@ library bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.0 && < 0.3, data-object >= 0.2.0 && < 0.3, - data-object-yaml >= 0.0.0 && < 0.1, + 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, From b460e9d4778614ddbed0827de47f7f4b56b38a92 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 00:56:08 +0200 Subject: [PATCH 118/624] Does not reload template dir on each request --- Yesod/Yesod.hs | 35 ++++++++++++++++++++++------------- examples/fact.lhs | 4 ++-- examples/hellotemplate.lhs | 2 +- examples/helloworld.lhs | 2 +- 4 files changed, 26 insertions(+), 17 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6344bf3e..0a5e0d32 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -14,6 +14,7 @@ import Yesod.Constants import Yesod.Definitions import Yesod.Handler import Yesod.Utils +import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) import Data.Convertible.Text @@ -27,7 +28,8 @@ import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride class Yesod a where - -- | Please use the Quasi-Quoter, you\'ll be happier. FIXME more info. + -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, + -- see the examples/fact.lhs sample. handlers :: Resource -> Verb -> Handler a RepChooser -- | The encryption key to be used for encrypting client sessions. @@ -74,26 +76,33 @@ defaultErrorHandler (InternalError e) = [ ("Internal server error", e) ] -toHackApp :: Yesod y => y -> Hack.Application -toHackApp a env = do +toHackApp :: Yesod y => y -> IO Hack.Application +toHackApp a = do key <- encryptKey a - let app' = toHackApp' a + app' <- toHackApp' a let mins = clientSessionDuration a - (gzip $ cleanPath $ jsonp $ methodOverride - $ clientsession encryptedCookies key mins $ app') env + return $ gzip + $ cleanPath + $ jsonp + $ methodOverride + $ clientsession encryptedCookies key mins + $ app' -toHackApp' :: Yesod y => y -> Hack.Application -toHackApp' y env = do +toHackApp' :: Yesod y => y -> IO Hack.Application +toHackApp' y = do + let td = templateDir y + tg <- if null td + then return nullGroup + else directoryGroupRecursiveLazy td + return $ toHackApp'' y tg + +toHackApp'' :: Yesod y => y -> TemplateGroup -> Hack.Env -> IO Hack.Response +toHackApp'' y tg env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - -- FIXME don't do the templateDir thing for each request - let td = templateDir y - tg <- if null td - then return nullGroup - else directoryGroupRecursiveLazy td res <- runHandler handler errorHandler rr y tg types let langs = ["en"] -- FIXME responseToHackResponse langs res diff --git a/examples/fact.lhs b/examples/fact.lhs index 49a6f867..9b1e7e31 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -89,7 +89,7 @@ one piece of data. > factRedirect :: Handler y () > factRedirect = do -> i <- getParam "num" +> i <- runRequest $ getParam "num" > redirect $ "../" ++ i ++ "/" The following line would be unnecesary if we had a type signature on @@ -102,4 +102,4 @@ 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..." >> run 3000 (toHackApp Fact) +> main = putStrLn "Running..." >> toHackApp Fact >>= run 3000 diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index 6bb06cb3..b5ee0924 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -26,5 +26,5 @@ helloGroup = template "real-template" "foo" (cs "bar") $ return [] main :: IO () main = do putStrLn "Running..." - run 3000 $ toHackApp HelloWorld + toHackApp HelloWorld >>= run 3000 \end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index de8a90de..371e8a04 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -15,5 +15,5 @@ helloWorld :: Handler HelloWorld HtmlObject helloWorld = return $ cs "Hello world!" main :: IO () -main = putStrLn "Running..." >> run 3000 (toHackApp HelloWorld) +main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000 \end{code} From 1c3e02a2cd927036dade2af84b53b2d025770616 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 01:14:35 +0200 Subject: [PATCH 119/624] Cleaned up some FIXMEs --- Yesod/Definitions.hs | 6 +++--- Yesod/Helpers/Auth.hs | 7 +++---- Yesod/Helpers/Static.hs | 19 +++++++++++++++---- Yesod/Resource.hs | 2 +- Yesod/Response.hs | 3 +-- 5 files changed, 23 insertions(+), 14 deletions(-) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index b3ff2d8d..8ad89f93 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -17,7 +17,7 @@ module Yesod.Definitions ( Verb (..) , Resource - , Approot (..) + , Approot , Language , Location (..) , showLocation @@ -55,7 +55,7 @@ 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. -newtype Approot = Approot { unApproot :: String } -- FIXME make type syn? +type Approot = String type Language = String @@ -66,6 +66,6 @@ data Location = AbsLoc String | RelLoc String -- | Display a 'Location' in absolute form. showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s -showLocation (Approot ar) (RelLoc s) = ar ++ s +showLocation ar (RelLoc s) = ar ++ s type PathInfo = [String] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index be5914eb..43341b03 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,7 +49,7 @@ class YesodApproot a => YesodAuth a where getFullAuthRoot :: YesodAuth y => Handler y String getFullAuthRoot = do y <- getYesod - let (Approot ar) = approot y + ar <- getApproot return $ ar ++ authRoot y data AuthResource = @@ -168,15 +168,14 @@ authCheck = do authLogout :: YesodAuth y => Handler y HtmlObject authLogout = do deleteCookie authCookieName - y <- getYesod - let (Approot ar) = approot y + ar <- getApproot redirect ar -- FIXME check the DEST information authIdentifier :: YesodAuth y => Handler y String authIdentifier = do mi <- identifier - Approot ar <- getApproot + ar <- getApproot case mi of Nothing -> do rp <- requestPath diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 2b8ba726..61461248 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -25,19 +25,25 @@ module Yesod.Helpers.Static import qualified Data.ByteString.Lazy as B import System.Directory (doesFileExist) import Control.Applicative ((<$>)) +import Control.Monad import Yesod import Data.List (intercalate) type FileLookup = FilePath -> IO (Maybe B.ByteString) --- | A 'FileLookup' for files in a directory. +-- | 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 -- FIXME incredibly insecure... + let fp' = dir ++ '/' : fp exists <- doesFileExist fp' if exists - then Just <$> B.readFile fp' + then Just <$> B.readFile fp' -- FIXME replace lazy I/O when possible else return Nothing serveStatic :: FileLookup -> Verb -> [String] @@ -47,11 +53,16 @@ serveStatic _ _ _ = notFound getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] getStatic fl fp' = do - let fp = intercalate "/" fp' -- FIXME check for . or .. + when (any isUnsafe fp') $ notFound + let fp = intercalate "/" fp' content <- liftIO $ fl fp case content of Nothing -> notFound Just bs -> return [(mimeType $ ext fp, Content bs)] + where + isUnsafe [] = True + isUnsafe ('.':_) = True + isUnsafe _ = False mimeType :: String -> ContentType mimeType "jpg" = TypeJpeg diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index ad28b3cf..581bfdad 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -244,7 +244,7 @@ checkRPNodes :: (MonadFailure OverlappingPatterns m, => [RPNode] -> m [RPNode] checkRPNodes nodes = do - _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes -- FIXME ugly + _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes return nodes where diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 6dc61c1c..b226684e 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} @@ -97,7 +97,6 @@ toPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") toPair (Header key value) = return (key, value) --- FIXME add test responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response responseToHackResponse _FIXMEls (Response sc hs ct c) = do From 405fb3ac259a4eca768af5b789e3974a896e87e1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 00:58:55 +0200 Subject: [PATCH 120/624] Factored mime-type code into its own module --- Web/Mime.hs | 65 +++++++++++++++++++++++++++++++++++++++++ Yesod.hs | 2 ++ Yesod/Handler.hs | 1 + Yesod/Helpers/Auth.hs | 2 +- Yesod/Helpers/Static.hs | 18 +----------- Yesod/Rep.hs | 40 ++----------------------- Yesod/Request.hs | 2 +- Yesod/Response.hs | 1 + Yesod/Yesod.hs | 1 + yesod.cabal | 1 + 10 files changed, 76 insertions(+), 57 deletions(-) create mode 100644 Web/Mime.hs diff --git a/Web/Mime.hs b/Web/Mime.hs new file mode 100644 index 00000000..900daf7c --- /dev/null +++ b/Web/Mime.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Generic MIME type module. Could be spun off into its own package. +module Web.Mime + ( ContentType (..) + , typeByExt + , ext + ) where + +import Data.Function (on) +import Data.Convertible.Text + +data ContentType = + TypeHtml + | TypePlain + | TypeJson + | TypeXml + | TypeAtom + | TypeJpeg + | TypePng + | TypeGif + | TypeJavascript + | TypeCss + | TypeFlv + | TypeOgv + | TypeOctet + | TypeOther String + deriving (Show) + +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 + +instance Eq ContentType where + (==) = (==) `on` (cs :: ContentType -> String) + +-- | 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 diff --git a/Yesod.hs b/Yesod.hs index 8ebda038..574bf690 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -24,6 +24,7 @@ module Yesod , module Yesod.Parameter , module Yesod.Rep , module Yesod.Template + , module Web.Mime , Application ) where @@ -47,3 +48,4 @@ import Yesod.Definitions import Yesod.Handler import Hack (Application) import Yesod.Template +import Web.Mime diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ca89257d..d2def0c6 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -39,6 +39,7 @@ import Yesod.Request import Yesod.Response import Yesod.Rep import Yesod.Template +import Web.Mime import Control.Exception hiding (Handler) import Control.Applicative diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e5e38ecc..e9d2fb72 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -129,7 +129,7 @@ authOpenidComplete = do rpxnowLogin :: YesodAuth y => Handler y HtmlObject rpxnowLogin = do ay <- getYesod - let (Approot ar) = approot ay + let ar = approot ay apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 61461248..606dfaa0 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -58,24 +58,8 @@ getStatic fl fp' = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return [(mimeType $ ext fp, Content bs)] + Just bs -> return [(typeByExt $ ext fp, Content bs)] where isUnsafe [] = True isUnsafe ('.':_) = True isUnsafe _ = False - -mimeType :: String -> ContentType -mimeType "jpg" = TypeJpeg -mimeType "jpeg" = TypeJpeg -mimeType "js" = TypeJavascript -mimeType "css" = TypeCss -mimeType "html" = TypeHtml -mimeType "png" = TypePng -mimeType "gif" = TypeGif -mimeType "txt" = TypePlain -mimeType "flv" = TypeFlv -mimeType "ogv" = TypeOgv -mimeType _ = TypeOctet - -ext :: String -> String -ext = reverse . fst . break (== '.') . reverse diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 509a9f32..7531fbb8 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -26,9 +26,7 @@ -- all data can be contained in an 'Object'; however, some of it requires more -- effort. module Yesod.Rep - ( - ContentType (..) - , Content (..) + ( Content (..) , RepChooser , ContentPair , HasReps (..) @@ -48,7 +46,7 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) import Data.Maybe (mapMaybe) -import Data.Function (on) +import Web.Mime #if TEST import Data.Object.Html hiding (testSuite) @@ -65,40 +63,6 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #endif -data ContentType = - TypeHtml - | TypePlain - | TypeJson - | TypeXml - | TypeAtom - | TypeJpeg - | TypePng - | TypeGif - | TypeJavascript - | TypeCss - | TypeFlv - | TypeOgv - | TypeOctet - | TypeOther String - deriving (Show) -instance ConvertSuccess ContentType String where - convertSuccess TypeHtml = "text/html" - convertSuccess TypePlain = "text/plain" - convertSuccess TypeJson = "application/json" - 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" - convertSuccess TypeCss = "text/css" - convertSuccess TypeFlv = "video/x-flv" - convertSuccess TypeOgv = "video/ogg" - convertSuccess TypeOctet = "application/octet-stream" - convertSuccess (TypeOther s) = s -instance Eq ContentType where - (==) = (==) `on` (cs :: ContentType -> String) - newtype Content = Content { unContent :: ByteString } deriving (Eq, Show) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index fecaf724..6be3a6f1 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -46,7 +46,7 @@ module Yesod.Request import qualified Hack import Data.Function.Predicate (equals) import Yesod.Constants -import Yesod.Utils (tryLookup, parseHttpAccept) +import Yesod.Utils (tryLookup) import Yesod.Definitions import Yesod.Parameter import Control.Applicative (Applicative (..)) diff --git a/Yesod/Response.hs b/Yesod/Response.hs index b226684e..e3089441 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -52,6 +52,7 @@ import Test.Framework (testGroup, Test) import Data.Generics import Control.Exception (Exception) import Data.Convertible.Text (cs) +import Web.Mime data Response = Response Int [Header] ContentType Content deriving Show diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 0a5e0d32..85b41f4c 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -19,6 +19,7 @@ import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) import Data.Convertible.Text import Text.StringTemplate +import Web.Mime import qualified Hack import Hack.Middleware.CleanPath diff --git a/yesod.cabal b/yesod.cabal index 57dfd552..bc87bf3a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -76,6 +76,7 @@ library Yesod.Helpers.Static Yesod.Helpers.AtomFeed Yesod.Helpers.Sitemap + Web.Mime ghc-options: -Wall -Werror executable runtests From 309757c22daa4510670636cafa881d73ba805fc8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 01:31:09 +0200 Subject: [PATCH 121/624] Separate ErrorResponse and SpecialResponse; added SendFile --- Yesod/Handler.hs | 56 ++++++++++++++++++++++------------------ Yesod/Helpers/Auth.hs | 16 +++++++----- Yesod/Response.hs | 59 ++++++++++++++++++++++++++----------------- Yesod/Yesod.hs | 6 ++--- 4 files changed, 79 insertions(+), 58 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d2def0c6..f00c24ef 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,7 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html +import qualified Data.ByteString.Lazy as BL import Yesod.Parameter @@ -59,8 +60,8 @@ newtype Handler yesod a = Handler { -> IO ([Header], HandlerContents a) } data HandlerContents a = - forall e. Exception e => HCError e - | HCSpecial ErrorResult + HCSpecial SpecialResponse + | HCError ErrorResponse | HCContent a instance Functor (Handler yesod) where @@ -82,7 +83,7 @@ instance Monad (Handler yesod) where instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') instance Exception e => Failure e (Handler yesod) where - failure e = Handler $ \_ -> return ([], HCError e) + failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e) instance RequestReader (Handler yesod) where getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) invalidParams = invalidArgs . map helper where @@ -95,7 +96,7 @@ instance HasTemplateGroup (Handler yesod) where getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) runHandler :: Handler yesod RepChooser - -> (ErrorResult -> Handler yesod RepChooser) + -> (ErrorResponse -> Handler yesod RepChooser) -> RawRequest -> yesod -> TemplateGroup @@ -104,43 +105,50 @@ runHandler :: Handler yesod RepChooser runHandler (Handler handler) eh rr y tg cts = do (headers, contents) <- Control.Exception.catch (handler (rr, y, tg)) - (\e -> return ([], HCError (e :: Control.Exception.SomeException))) - let contents' = - case contents of - HCError e -> Left $ InternalError $ show e - HCSpecial e -> Left e - HCContent a -> Right a - case contents' of - Left e -> do - Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts - let hs' = headers ++ hs ++ getHeaders e + (\e -> return ([], HCError $ InternalError $ show + (e :: Control.Exception.SomeException))) + case contents of + HCError e -> do + Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts + let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c - Right a -> do + HCSpecial (Redirect rt loc) -> do + let hs = Header "Location" loc : headers + return $ Response (getRedirectStatus rt) hs TypePlain $ cs "" + HCSpecial (SendFile ct fp) -> do + -- FIXME do error handling on this, or leave it to the app? + -- FIXME avoid lazy I/O by switching to WAI + c <- BL.readFile fp + return $ Response 200 headers ct $ Content c + HCContent a -> do (ct, c) <- a cts return $ Response 200 headers ct c -specialEh :: ErrorResult -> Handler yesod RepChooser -specialEh er = do +safeEh :: ErrorResponse -> Handler yesod RepChooser +safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" ------ Special handlers -errorResult :: ErrorResult -> Handler yesod a -errorResult er = Handler $ \_ -> return ([], HCSpecial er) +specialResponse :: SpecialResponse -> Handler yesod a +specialResponse er = Handler $ \_ -> return ([], HCSpecial er) + +errorResponse :: ErrorResponse -> Handler yesod a +errorResponse er = Handler $ \_ -> return ([], HCError er) -- | Redirect to the given URL. -redirect :: String -> Handler yesod a -redirect = errorResult . Redirect +redirect :: RedirectType -> String -> Handler yesod a +redirect rt = specialResponse . Redirect rt -- | Return a 404 not found page. Also denotes no handler available. notFound :: Handler yesod a -notFound = errorResult NotFound +notFound = errorResponse NotFound permissionDenied :: Handler yesod a -permissionDenied = errorResult PermissionDenied +permissionDenied = errorResponse PermissionDenied invalidArgs :: [(ParamName, ParamValue)] -> Handler yesod a -invalidArgs = errorResult . InvalidArgs +invalidArgs = errorResponse . InvalidArgs ------- Headers -- | Set the cookie on the client. diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e9d2fb72..32d941bd 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -109,8 +109,9 @@ authOpenidForward = do let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt - (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err)) - redirect + (\err -> redirect RedirectTemporary + $ "/auth/openid/?message=" ++ encodeUrl (show err)) + (redirect RedirectTemporary) res authOpenidComplete :: Handler y HtmlObject @@ -118,12 +119,13 @@ authOpenidComplete = do gets' <- rawGetParams <$> getRawRequest dest <- runRequest $ cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' - let onFailure err = redirect $ "/auth/openid/?message=" + let onFailure err = redirect RedirectTemporary + $ "/auth/openid/?message=" ++ encodeUrl (show err) let onSuccess (OpenId.Identifier ident) = do deleteCookie "DEST" header authCookieName ident - redirect $ fromMaybe "/" dest + redirect RedirectTemporary $ fromMaybe "/" dest attempt onFailure onSuccess res rpxnowLogin :: YesodAuth y => Handler y HtmlObject @@ -146,7 +148,7 @@ rpxnowLogin = do ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident - redirect dest + redirect RedirectTemporary dest -- | Get some form of a display name, defaulting to the identifier. getDisplayName :: Rpxnow.Identifier -> String @@ -170,7 +172,7 @@ authLogout :: YesodAuth y => Handler y HtmlObject authLogout = do deleteCookie authCookieName ar <- getApproot - redirect ar + redirect RedirectTemporary ar -- FIXME check the DEST information authIdentifier :: YesodAuth y => Handler y String @@ -183,5 +185,5 @@ authIdentifier = do let dest = ar ++ rp lp <- defaultLoginPath `fmap` getYesod addCookie 120 "DEST" dest - redirect $ ar ++ lp + redirect RedirectTemporary $ ar ++ lp Just x -> return x diff --git a/Yesod/Response.hs b/Yesod/Response.hs index e3089441..13e9ea99 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -19,13 +19,16 @@ --------------------------------------------------------- module Yesod.Response ( Response (..) - -- * Abnormal responses - , ErrorResult (..) - , getHeaders + -- * Special responses + , RedirectType (..) + , getRedirectStatus + , SpecialResponse (..) + -- * Error responses + , ErrorResponse (..) , getStatus -- * Header , Header (..) - , toPair + , headerToPair -- * Converting to Hack values , responseToHackResponse #if TEST @@ -49,35 +52,45 @@ import qualified Hack import Test.Framework (testGroup, Test) #endif -import Data.Generics -import Control.Exception (Exception) import Data.Convertible.Text (cs) import Web.Mime data Response = Response Int [Header] ContentType Content deriving Show --- | Abnormal return codes. -data ErrorResult = - Redirect String - | NotFound +-- | Different types of redirects. +data RedirectType = RedirectPermanent + | RedirectTemporary + | RedirectSeeOther + deriving (Show, Eq) + +getRedirectStatus :: RedirectType -> Int +getRedirectStatus RedirectPermanent = 301 +getRedirectStatus RedirectTemporary = 302 +getRedirectStatus RedirectSeeOther = 303 + +-- | 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 [(String, String)] | PermissionDenied - deriving (Show, Typeable) -instance Exception ErrorResult + deriving (Show, Eq) -getStatus :: ErrorResult -> Int -getStatus (Redirect _) = 303 +getStatus :: ErrorResponse -> Int getStatus NotFound = 404 getStatus (InternalError _) = 500 getStatus (InvalidArgs _) = 400 getStatus PermissionDenied = 403 -getHeaders :: ErrorResult -> [Header] -getHeaders (Redirect s) = [Header "Location" s] -getHeaders _ = [] - ----- header stuff -- | Headers to be added to a 'Result'. data Header = @@ -87,21 +100,21 @@ data Header = deriving (Eq, Show) -- | Convert Header to a key/value pair. -toPair :: Header -> IO (String, String) -toPair (AddCookie minutes key value) = do +headerToPair :: Header -> IO (String, String) +headerToPair (AddCookie minutes key value) = do now <- getCurrentTime let expires = addUTCTime (fromIntegral $ minutes * 60) now return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) -toPair (DeleteCookie key) = return +headerToPair (DeleteCookie key) = return ("Set-Cookie", key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -toPair (Header key value) = return (key, value) +headerToPair (Header key value) = return (key, value) responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response responseToHackResponse _FIXMEls (Response sc hs ct c) = do - hs' <- mapM toPair hs + hs' <- mapM headerToPair hs let hs'' = ("Content-Type", cs ct) : hs' let asLBS = unContent c return $ Hack.Response sc hs'' asLBS diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 85b41f4c..3b9411a9 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -43,7 +43,7 @@ class Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: ErrorResult -> Handler a RepChooser + errorHandler :: ErrorResponse -> Handler a RepChooser errorHandler = defaultErrorHandler -- | The template directory. Blank means no templates. @@ -58,13 +58,11 @@ getApproot :: YesodApproot y => Handler y Approot getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y - => ErrorResult + => ErrorResponse -> Handler y RepChooser defaultErrorHandler NotFound = do rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr -defaultErrorHandler (Redirect url) = - return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url defaultErrorHandler PermissionDenied = return $ chooseRep $ toHtmlObject "Permission denied" defaultErrorHandler (InvalidArgs ia) = From 9ccfe9ba907e7a68f47d3e45ebc590d14fdefc61 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 01:44:54 +0200 Subject: [PATCH 122/624] Removed cookie as a parameter type --- Yesod/Helpers/Auth.hs | 13 ++++++++----- Yesod/Parameter.hs | 5 +---- Yesod/Request.hs | 6 +----- 3 files changed, 10 insertions(+), 14 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 32d941bd..1ff77111 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -26,7 +26,6 @@ import qualified Web.Authenticate.OpenId as OpenId import Yesod import Yesod.Constants -import Control.Applicative ((<$>)) import Control.Monad.Attempt import Data.Maybe (fromMaybe) @@ -114,10 +113,14 @@ authOpenidForward = do (redirect RedirectTemporary) res -authOpenidComplete :: Handler y HtmlObject +authOpenidComplete :: YesodApproot y => Handler y HtmlObject authOpenidComplete = do - gets' <- rawGetParams <$> getRawRequest - dest <- runRequest $ cookieParam "DEST" + ar <- getApproot + rr <- getRawRequest + let gets' = rawGetParams rr + let dest = case cookies rr "DEST" of + [] -> ar + (x:_) -> x res <- runAttemptT $ OpenId.authenticate gets' let onFailure err = redirect RedirectTemporary $ "/auth/openid/?message=" @@ -125,7 +128,7 @@ authOpenidComplete = do let onSuccess (OpenId.Identifier ident) = do deleteCookie "DEST" header authCookieName ident - redirect RedirectTemporary $ fromMaybe "/" dest + redirect RedirectTemporary dest attempt onFailure onSuccess res rpxnowLogin :: YesodAuth y => Handler y HtmlObject diff --git a/Yesod/Parameter.hs b/Yesod/Parameter.hs index d8e2bb7e..9aa1db4a 100644 --- a/Yesod/Parameter.hs +++ b/Yesod/Parameter.hs @@ -42,14 +42,11 @@ import Data.Convertible.Text data ParamType = GetParam | PostParam - | CookieParam deriving (Eq, Show) --- | In GET parameters, the key. In cookies, the cookie name. So on and so --- forth. type ParamName = String --- | The 'String' value of a parameter, such as cookie content. +-- | The 'String' value of a parameter. type ParamValue = String -- | Anything which can be converted from a list of 'String's. diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 6be3a6f1..441ef611 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -26,13 +26,13 @@ module Yesod.Request , getParam , postParam , anyParam - , cookieParam , identifier , displayName , acceptedLanguages , requestPath , parseEnv , runRequest + , cookies -- * Building actual request , Request (..) , Hack.RequestMethod (..) @@ -130,10 +130,6 @@ postParam = genParam postParams PostParam anyParam :: (Parameter a) => ParamName -> Request a anyParam = genParam anyParams PostParam -- FIXME --- | Parse a value passed as a raw cookie. -cookieParam :: (Parameter a) => ParamName -> Request a -cookieParam = genParam cookies CookieParam - -- | Extract the cookie which specifies the identifier for a logged in -- user, if available. identifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) From 254018e3c34c13b3d23f281f634a0e952198ecfd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 00:23:55 +0200 Subject: [PATCH 123/624] Removed more from Yesod.Request, with cascading removals --- Data/Object/Html.hs | 8 ++- Test/Errors.hs | 4 +- Yesod/Definitions.hs | 3 -- Yesod/Helpers/Auth.hs | 51 ++++++++++++++++-- Yesod/Rep.hs | 4 +- Yesod/Request.hs | 121 ++++++------------------------------------ Yesod/Resource.hs | 10 ++-- Yesod/Utils.hs | 59 -------------------- Yesod/Yesod.hs | 2 +- runtests.hs | 2 - yesod.cabal | 3 +- 11 files changed, 82 insertions(+), 185 deletions(-) delete mode 100644 Yesod/Utils.hs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 3a228cf1..32938049 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -90,6 +90,12 @@ 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 @@ -202,7 +208,7 @@ caseHtmlToText = do "

                Some HTML
                " ++ "<'this should be escaped'>" ++ "
                " - cs actual @?= (cs expected :: Text) + unHtmlFragment (cs actual) @?= (cs expected :: Text) caseStringTemplate :: Assertion caseStringTemplate = do diff --git a/Test/Errors.hs b/Test/Errors.hs index 84cbe86f..1363987a 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -22,7 +22,7 @@ instance Yesod Errors where Get: hasArgs |] instance YesodApproot Errors where - approot _ = Approot "IGNORED/" + approot _ = "IGNORED/" instance YesodAuth Errors denied :: Handler Errors () @@ -41,7 +41,7 @@ hasArgs = do caseErrorMessages :: Assertion caseErrorMessages = do - let app = toHackApp Errors + app <- toHackApp Errors res <- app $ def { pathInfo = "/denied/" } assertBool "/denied/" $ "Permission denied" `isInfixOf` show res res' <- app $ def { pathInfo = "/needs-ident/" } diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 8ad89f93..5340f864 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -21,7 +21,6 @@ module Yesod.Definitions , Language , Location (..) , showLocation - , PathInfo ) where import qualified Hack @@ -67,5 +66,3 @@ data Location = AbsLoc String | RelLoc String showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s showLocation ar (RelLoc s) = ar ++ s - -type PathInfo = [String] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1ff77111..35194413 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -16,7 +17,9 @@ module Yesod.Helpers.Auth ( authHandler , YesodAuth (..) + , maybeIdentifier , authIdentifier + , displayName ) where import Web.Encodings @@ -29,6 +32,9 @@ import Yesod.Constants import Control.Monad.Attempt import Data.Maybe (fromMaybe) +import qualified Hack +import Data.Typeable (Typeable) +import Control.Exception (Exception) class YesodApproot a => YesodAuth a where -- | The following breaks DRY, but I cannot think of a better solution @@ -138,7 +144,10 @@ rpxnowLogin = do apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound - token <- runRequest $ anyParam "token" + rr <- getRawRequest + let token = case getParams rr "token" ++ postParams rr "token" of + [] -> failure MissingToken + (x:_) -> x postDest <- runRequest $ postParam "dest" dest' <- case postDest of Nothing -> runRequest $ getParam "dest" @@ -153,6 +162,10 @@ rpxnowLogin = do header authDisplayName $ getDisplayName ident redirect 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 @@ -164,7 +177,7 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where authCheck :: Handler y HtmlObject authCheck = do - ident <- identifier + ident <- maybeIdentifier dn <- displayName return $ toHtmlObject [ ("identifier", fromMaybe "" ident) @@ -178,9 +191,27 @@ authLogout = do redirect RedirectTemporary ar -- FIXME check the DEST information +-- | Gets the identifier for a user if available. +maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) +maybeIdentifier = do + env <- parseEnv + case lookup authCookieName $ Hack.hackHeaders env of + Nothing -> return Nothing + Just x -> return (Just x) + +-- | Gets the display name for a user if available. +displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) +displayName = do + env <- parseEnv + case lookup authDisplayName $ Hack.hackHeaders env of + Nothing -> return Nothing + Just x -> return (Just x) + +-- | 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 = do - mi <- identifier + mi <- maybeIdentifier ar <- getApproot case mi of Nothing -> do @@ -190,3 +221,17 @@ authIdentifier = do addCookie 120 "DEST" dest redirect RedirectTemporary $ ar ++ lp Just x -> return x + +-- | 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 <- parseEnv + let q = case Hack.queryString env of + "" -> "" + q'@('?':_) -> q' + q' -> '?' : q' + return $! dropSlash (Hack.pathInfo env) ++ q + where + dropSlash ('/':x) = x + dropSlash x = x diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 7531fbb8..5d81cdb3 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -200,7 +200,7 @@ caseChooseRepTemplate :: Assertion caseChooseRepTemplate = do let temp = newSTMP "foo:$o.foo$, bar:$o.bar$" ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", toHtmlObject ["bar1", "bar2"]) + , ("bar", Sequence $ map cs ["bar1", "bar2"]) ] hasreps = Template temp "o" ho $ return [] res1 = cs "foo:<fooval>, bar:bar1bar2" @@ -215,7 +215,7 @@ caseChooseRepTemplateFile :: Assertion caseChooseRepTemplateFile = do let temp = "Test/rep.st" ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", toHtmlObject ["bar1", "bar2"]) + , ("bar", Sequence $ map cs ["bar1", "bar2"]) ] hasreps = TemplateFile temp ho res1 = cs "foo:<fooval>, bar:bar1bar2" diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 441ef611..5e3458b3 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -20,24 +20,17 @@ module Yesod.Request ( -- * RawRequest RawRequest (..) - -- * Parameter type class - -- * MonadRequestReader type class and helpers , RequestReader (..) , getParam , postParam - , anyParam - , identifier - , displayName - , acceptedLanguages - , requestPath , parseEnv , runRequest , cookies + , getParams + , postParams -- * Building actual request , Request (..) , Hack.RequestMethod (..) - -- * Parameter restrictions - -- FIXME , notBlank #if TEST , testSuite #endif @@ -45,19 +38,15 @@ module Yesod.Request import qualified Hack import Data.Function.Predicate (equals) -import Yesod.Constants -import Yesod.Utils (tryLookup) -import Yesod.Definitions import Yesod.Parameter import Control.Applicative (Applicative (..)) import Web.Encodings import qualified Data.ByteString.Lazy as BL import Data.Convertible.Text -import Hack.Middleware.CleanPath (splitPath) import Control.Arrow ((***)) -import Control.Exception (Exception, SomeException (..)) -import Data.Typeable (Typeable) +import Control.Exception (SomeException (..)) import Data.Attempt +import Data.Maybe (fromMaybe) #if TEST import Test.Framework (testGroup, Test) @@ -89,22 +78,6 @@ runRequest :: (Monad m, RequestReader m) => Request a -> m a runRequest (Request f) = do rr <- getRawRequest either invalidParams return $ f rr -{- FIXME --- | Attempt to parse a list of param values using 'readParams'. --- If that fails, return an error message and an undefined value. This way, --- we can process all of the parameters and get all of the error messages. --- Be careful not to use the value inside until you can be certain the --- reading succeeded. -tryReadParams:: (Parameter a, MonadRequestReader m) - => ParamType - -> ParamName - -> [RawParam] - -> m a -tryReadParams ptype name params = - case readParams params of - Failure s -> invalidParam ptype name s - Success x -> return x --} -- | Helper function for generating 'RequestParser's from various -- 'ParamValue' lists. @@ -126,61 +99,19 @@ getParam = genParam getParams GetParam postParam :: (Parameter a) => ParamName -> Request a postParam = genParam postParams PostParam --- | Parse a value passed as a GET, POST or URL parameter. -anyParam :: (Parameter a) => ParamName -> Request a -anyParam = genParam anyParams PostParam -- FIXME - --- | Extract the cookie which specifies the identifier for a logged in --- user, if available. -identifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) -identifier = do - env <- parseEnv - case lookup authCookieName $ Hack.hackHeaders env of - Nothing -> return Nothing - Just x -> return (Just x) - -displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) -displayName = do - env <- parseEnv - case lookup authDisplayName $ Hack.hackHeaders env of - Nothing -> return Nothing - Just x -> return (Just x) - -- | Get the raw 'Hack.Env' value. parseEnv :: (Functor m, RequestReader m) => m Hack.Env parseEnv = rawEnv `fmap` getRawRequest --- | Determine the ordered list of language preferences. --- --- FIXME: Future versions should account for some cookie. -acceptedLanguages :: (Functor m, Monad m, RequestReader m) => m [String] -acceptedLanguages = do - env <- parseEnv - let rawLang = tryLookup "" "Accept-Language" $ Hack.http env - return $! parseHttpAccept rawLang - --- | Determinge the path requested by the user (ie, the path info). -requestPath :: (Functor m, Monad m, RequestReader m) => m String -requestPath = do - env <- parseEnv - let q = case Hack.queryString env of - "" -> "" - q'@('?':_) -> q' - q' -> q' - return $! dropSlash (Hack.pathInfo env) ++ q - where - dropSlash ('/':x) = x - dropSlash x = x - -- | The raw information passed through Hack, cleaned up a bit. data RawRequest = RawRequest - { rawPathInfo :: PathInfo - , rawGetParams :: [(ParamName, ParamValue)] - , rawPostParams :: [(ParamName, ParamValue)] + { rawGetParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] + -- FIXME when we switch to WAI, the following two should be combined and + -- wrapped in the IO monad + , rawPostParams :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawEnv :: Hack.Env - , rawLanguages :: [Language] } deriving Show @@ -198,43 +129,23 @@ postParams rr name = map snd . rawPostParams $ rr --- | All GET and POST paramater values (see rewriting) with the given name. -anyParams :: RawRequest -> ParamName -> [ParamValue] -anyParams req name = getParams req name ++ - postParams req name - -- | All cookies with the given name. cookies :: RawRequest -> ParamName -> [ParamValue] cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr -{- FIXME --- | Ensures that a String parameter is not blank. -notBlank :: MonadRequestReader m => RawParam -> m String -notBlank rp = - case paramValue rp of - "" -> invalidParam (paramType rp) (paramName rp) RequiredField - s -> return s --} - -data RequiredField = RequiredField - deriving (Show, Typeable) -instance Exception RequiredField - instance ConvertSuccess Hack.Env RawRequest where convertSuccess env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = tryLookup "0" "Content-Length" $ Hack.http env - ctype = tryLookup "" "Content-Type" $ Hack.http env + let gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env + ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c (posts, files) = map (convertSuccess *** convertSuccess) *** map (convertSuccess *** convertFileInfo) $ parsePost ctype clength $ Hack.hackInput env - rawCookie = tryLookup "" "Cookie" $ Hack.http env + rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - langs = ["en"] -- FIXME - in RawRequest rawPieces gets' posts cookies' files env langs + in RawRequest gets' cookies' posts files env #if TEST testSuite :: Test @@ -244,12 +155,12 @@ testSuite = testGroup "Yesod.Request" caseAppInst :: Assertion caseAppInst = do - let r5 = Request $ const $ Right 5 + let r5 = Request $ const $ Right (5 :: Int) rAdd2 = Request $ const $ Right (+ 2) - r7 = Request $ const $ Right 7 + r7 = Request $ const $ Right (7 :: Int) rr = undefined myEquals e t = (unRequest e) rr `myEquals2` (unRequest t) rr myEquals2 x y = show x @=? show y - r5 `myEquals` pure 5 + r5 `myEquals` pure (5 :: Int) r7 `myEquals` (rAdd2 <*> r5) #endif diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 581bfdad..0b1917a4 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -477,7 +477,6 @@ instance Arbitrary RPP where caseFromYaml :: Assertion caseFromYaml = do - contents <- readYamlDoc "Test/resource-patterns.yaml" rp1 <- readRP "static/*filepath" rp2 <- readRP "page" rp3 <- readRP "page/$page" @@ -491,13 +490,14 @@ caseFromYaml = do ] , RPNode rp4 $ Verbs [(Get, "userInfo")] ] - contents' <- fa $ ca contents - expected @=? contents' + contents' <- decodeFile "Test/resource-patterns.yaml" + contents <- convertAttemptWrap (contents' :: TextObject) + expected @=? contents caseCheckRPNodes :: Assertion caseCheckRPNodes = do - good' <- readYamlDoc "Test/resource-patterns.yaml" - good <- fa $ ca good' + good' <- decodeFile "Test/resource-patterns.yaml" + good <- convertAttemptWrap (good' :: TextObject) Just good @=? checkRPNodes good rp1 <- readRP "foo/bar" rp2 <- readRP "$foo/bar" diff --git a/Yesod/Utils.hs b/Yesod/Utils.hs deleted file mode 100644 index e8959e88..00000000 --- a/Yesod/Utils.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Utils --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Utility functions for Restful. --- These are all functions which could be exported to another library. --- ---------------------------------------------------------- -module Yesod.Utils - ( parseHttpAccept - , tryLookup -#if TEST - , testSuite -#endif - ) where - -import Data.List.Split (splitOneOf) -import Data.Maybe (fromMaybe) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | Parse the HTTP accept string to determine supported content types. -parseHttpAccept :: String -> [String] -parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," - -specialHttpAccept :: String -> Bool -specialHttpAccept ('q':'=':_) = True -specialHttpAccept ('*':_) = True -specialHttpAccept _ = False - --- | Attempt a lookup, returning a default value on failure. -tryLookup :: Eq k => v -> k -> [(k, v)] -> v -tryLookup def key = fromMaybe def . lookup key - -#if TEST ------ Testing -testSuite :: Test -testSuite = testGroup "Yesod.Utils" - [ testCase "tryLookup1" caseTryLookup1 - , testCase "tryLookup2" caseTryLookup2 - ] - -caseTryLookup1 :: Assertion -caseTryLookup1 = tryLookup "default" "foo" [] @?= "default" - -caseTryLookup2 :: Assertion -caseTryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" -#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3b9411a9..c5ab7843 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -13,13 +13,13 @@ import Yesod.Request import Yesod.Constants import Yesod.Definitions import Yesod.Handler -import Yesod.Utils import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) import Data.Convertible.Text import Text.StringTemplate import Web.Mime +import Web.Encodings (parseHttpAccept) import qualified Hack import Hack.Middleware.CleanPath diff --git a/runtests.hs b/runtests.hs index 6da45977..a5e8e423 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,7 +1,6 @@ import Test.Framework (defaultMain) import qualified Yesod.Response -import qualified Yesod.Utils import qualified Yesod.Resource import qualified Yesod.Rep import qualified Yesod.Request @@ -12,7 +11,6 @@ import qualified Test.QuasiResource main :: IO () main = defaultMain [ Yesod.Response.testSuite - , Yesod.Utils.testSuite , Yesod.Resource.testSuite , Yesod.Rep.testSuite , Yesod.Request.testSuite diff --git a/yesod.cabal b/yesod.cabal index bc87bf3a..7ad4eeaf 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -37,7 +37,7 @@ library authenticate >= 0.4.0 && < 0.5, predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.0 && < 0.3, + web-encodings >= 0.2.1 && < 0.3, data-object >= 0.2.0 && < 0.3, data-object-yaml >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, @@ -59,7 +59,6 @@ library Yesod.Rep Yesod.Request Yesod.Response - Yesod.Utils Yesod.Definitions Yesod.Handler Yesod.Parameter From b784ef935ac9feaff8ab19bdfbb966256fb9e282 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 00:33:38 +0200 Subject: [PATCH 124/624] Merged Yesod.Constants into Yesod.Definitions --- Yesod/Constants.hs | 27 --------------------------- Yesod/Definitions.hs | 13 +++++++++++++ Yesod/Helpers/Auth.hs | 1 - Yesod/Yesod.hs | 1 - yesod.cabal | 1 - 5 files changed, 13 insertions(+), 30 deletions(-) delete mode 100644 Yesod/Constants.hs diff --git a/Yesod/Constants.hs b/Yesod/Constants.hs deleted file mode 100644 index 9879f625..00000000 --- a/Yesod/Constants.hs +++ /dev/null @@ -1,27 +0,0 @@ ---------------------------------------------------------- --- --- Module : Yesod.Constants --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Constants used throughout Yesod. --- ---------------------------------------------------------- -module Yesod.Constants - ( authCookieName - , authDisplayName - , encryptedCookies - ) where - -authCookieName :: String -authCookieName = "IDENTIFIER" - -authDisplayName :: String -authDisplayName = "DISPLAY_NAME" - -encryptedCookies :: [String] -encryptedCookies = [authDisplayName, authCookieName] diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 5340f864..554eb183 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -21,6 +21,10 @@ module Yesod.Definitions , Language , Location (..) , showLocation + -- * Constant values + , authCookieName + , authDisplayName + , encryptedCookies ) where import qualified Hack @@ -66,3 +70,12 @@ data Location = AbsLoc String | RelLoc String showLocation :: Approot -> Location -> String showLocation _ (AbsLoc s) = s showLocation ar (RelLoc s) = ar ++ s + +authCookieName :: String +authCookieName = "IDENTIFIER" + +authDisplayName :: String +authDisplayName = "DISPLAY_NAME" + +encryptedCookies :: [String] +encryptedCookies = [authDisplayName, authCookieName] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 35194413..39ff7114 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -27,7 +27,6 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Yesod -import Yesod.Constants import Control.Monad.Attempt diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c5ab7843..b46ed294 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -10,7 +10,6 @@ import Yesod.Rep import Data.Object.Html (toHtmlObject) import Yesod.Response import Yesod.Request -import Yesod.Constants import Yesod.Definitions import Yesod.Handler import Yesod.Template (TemplateGroup) diff --git a/yesod.cabal b/yesod.cabal index 7ad4eeaf..ee6c943f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -55,7 +55,6 @@ library failure >= 0.0.0 && < 0.1, safe-failure >= 0.4.0 && < 0.5 exposed-modules: Yesod - Yesod.Constants Yesod.Rep Yesod.Request Yesod.Response From 7275d9ecfcbcbd14b1f18a056e27b7befce6a7bb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 22 Jan 2010 09:39:15 +0200 Subject: [PATCH 125/624] Switch Content to be a function on language list --- Test/QuasiResource.hs | 11 ++++++++++- Yesod/Handler.hs | 2 +- Yesod/Helpers/Static.hs | 2 +- Yesod/Rep.hs | 30 +++++++++++++++++++++--------- Yesod/Response.hs | 5 ++--- Yesod/Yesod.hs | 4 +++- 6 files changed, 38 insertions(+), 16 deletions(-) diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 0e610c98..4aebc768 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -62,11 +62,20 @@ ph ss h = do y = MyYesod cts = [TypeHtml] res <- runHandler h eh rr y nullGroup cts - mapM_ (helper $ show res) ss + res' <- myShow res + mapM_ (helper res') ss where helper haystack needle = assertBool needle $ needle `isInfixOf` haystack +myShow :: Response -> IO String +myShow (Response sc hs ct (Content c)) = c [] >>= \c' -> return $ unlines + [ show sc + , unlines $ map show hs + , show ct + , show c' + ] + caseQuasi :: Assertion caseQuasi = do ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] Get diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f00c24ef..2a2fb082 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -119,7 +119,7 @@ runHandler (Handler handler) eh rr y tg cts = do -- FIXME do error handling on this, or leave it to the app? -- FIXME avoid lazy I/O by switching to WAI c <- BL.readFile fp - return $ Response 200 headers ct $ Content c + return $ Response 200 headers ct $ cs c HCContent a -> do (ct, c) <- a cts return $ Response 200 headers ct c diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 606dfaa0..6d9a91a1 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -58,7 +58,7 @@ getStatic fl fp' = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return [(typeByExt $ ext fp, Content bs)] + Just bs -> return [(typeByExt $ ext fp, cs bs)] where isUnsafe [] = True isUnsafe ('.':_) = True diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 5d81cdb3..e0f846a0 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -47,6 +47,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) import Data.Maybe (mapMaybe) import Web.Mime +import Yesod.Definitions #if TEST import Data.Object.Html hiding (testSuite) @@ -63,15 +64,14 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #endif -newtype Content = Content { unContent :: ByteString } - deriving (Eq, Show) +newtype Content = Content { unContent :: [Language] -> IO ByteString } instance ConvertSuccess Text Content where - convertSuccess = Content . cs + convertSuccess = Content . const . return . cs instance ConvertSuccess ByteString Content where - convertSuccess = Content + convertSuccess = Content . const . return instance ConvertSuccess String Content where - convertSuccess = Content . cs + convertSuccess = Content . const . return . cs instance ConvertSuccess HtmlDoc Content where convertSuccess = cs . unHtmlDoc instance ConvertSuccess XmlDoc Content where @@ -157,14 +157,14 @@ instance HasReps TemplateFile where data Static = Static ContentType ByteString instance HasReps Static where reps = error "reps of Static" - chooseRep (Static ct bs) _ = return (ct, Content bs) + chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) data StaticFile = StaticFile ContentType FilePath instance HasReps StaticFile where reps = error "reps of StaticFile" chooseRep (StaticFile ct fp) _ = do bs <- BL.readFile fp - return (ct, Content bs) + return (ct, Content $ const $ return bs) -- Useful instances of HasReps instance HasReps HtmlObject where @@ -176,17 +176,21 @@ instance HasReps HtmlObject where #if TEST caseChooseRepHO :: Assertion caseChooseRepHO = do + {- FIXME let content = "IGNOREME" a = toHtmlObject content - htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content - jsonbs = Content . cs $ "\"" ++ content ++ "\"" + htmlbs = cs . unHtmlDoc . cs $ toHtmlObject content + jsonbs = cs $ "\"" ++ content ++ "\"" chooseRep a [TypeHtml] >>= (@?= (TypeHtml, htmlbs)) chooseRep a [TypeJson] >>= (@?= (TypeJson, jsonbs)) chooseRep a [TypeHtml, TypeJson] >>= (@?= (TypeHtml, htmlbs)) chooseRep a [TypeOther "foo", TypeJson] >>= (@?= (TypeJson, jsonbs)) + -} + return () caseChooseRepRaw :: Assertion caseChooseRepRaw = do + {- FIXME let content = Content $ cs "FOO" foo = TypeOther "foo" bar = TypeOther "bar" @@ -195,9 +199,12 @@ caseChooseRepRaw = do chooseRep hasreps [foo, bar] >>= (@?= (foo, content)) chooseRep hasreps [bar, foo] >>= (@?= (foo, content)) chooseRep hasreps [bar] >>= (@?= (TypeHtml, content)) + -} + return () caseChooseRepTemplate :: Assertion caseChooseRepTemplate = do + {- FIXME let temp = newSTMP "foo:$o.foo$, bar:$o.bar$" ho = toHtmlObject [ ("foo", toHtmlObject "") , ("bar", Sequence $ map cs ["bar1", "bar2"]) @@ -210,9 +217,12 @@ caseChooseRepTemplate = do chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) + -} + return () caseChooseRepTemplateFile :: Assertion caseChooseRepTemplateFile = do + {- FIXME let temp = "Test/rep.st" ho = toHtmlObject [ ("foo", toHtmlObject "") , ("bar", Sequence $ map cs ["bar1", "bar2"]) @@ -225,6 +235,8 @@ caseChooseRepTemplateFile = do chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) + -} + return () testSuite :: Test testSuite = testGroup "Yesod.Rep" diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 13e9ea99..67de0456 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -56,7 +56,6 @@ import Data.Convertible.Text (cs) import Web.Mime data Response = Response Int [Header] ContentType Content - deriving Show -- | Different types of redirects. data RedirectType = RedirectPermanent @@ -113,10 +112,10 @@ headerToPair (Header key value) = return (key, value) responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response -responseToHackResponse _FIXMEls (Response sc hs ct c) = do +responseToHackResponse ls (Response sc hs ct c) = do hs' <- mapM headerToPair hs let hs'' = ("Content-Type", cs ct) : hs' - let asLBS = unContent c + asLBS <- unContent c ls return $ Hack.Response sc hs'' asLBS #if TEST diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b46ed294..1c5af9fa 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -102,7 +102,9 @@ toHackApp'' y tg env = do handler = handlers resource verb rr = cs env res <- runHandler handler errorHandler rr y tg types - let langs = ["en"] -- FIXME + let acceptLang = lookup "Accept-Language" $ Hack.http env + -- FIXME get languages from a cookie as well + let langs = maybe [] parseHttpAccept acceptLang responseToHackResponse langs res httpAccept :: Hack.Env -> [ContentType] From 79b780fec2024a573720fb9e070f13821d765128 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Jan 2010 00:44:16 +0200 Subject: [PATCH 126/624] Language GET param and cookie; simple i18n example --- Yesod/Definitions.hs | 4 ++++ Yesod/Yesod.hs | 9 +++++++-- examples/i18n.hs | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 45 insertions(+), 2 deletions(-) create mode 100644 examples/i18n.hs diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 554eb183..df82af52 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -25,6 +25,7 @@ module Yesod.Definitions , authCookieName , authDisplayName , encryptedCookies + , langKey ) where import qualified Hack @@ -79,3 +80,6 @@ authDisplayName = "DISPLAY_NAME" encryptedCookies :: [String] encryptedCookies = [authDisplayName, authCookieName] + +langKey :: String +langKey = "_LANG" diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 1c5af9fa..bd59f9b8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -103,9 +103,14 @@ toHackApp'' y tg env = do rr = cs env res <- runHandler handler errorHandler rr y tg types let acceptLang = lookup "Accept-Language" $ Hack.http env - -- FIXME get languages from a cookie as well let langs = maybe [] parseHttpAccept acceptLang - responseToHackResponse langs res + langs' = case lookup langKey $ rawCookies rr of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey $ rawGetParams rr of + Nothing -> langs' + Just x -> x : langs' + responseToHackResponse langs'' res httpAccept :: Hack.Env -> [ContentType] httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" diff --git a/examples/i18n.hs b/examples/i18n.hs new file mode 100644 index 00000000..1e5bc419 --- /dev/null +++ b/examples/i18n.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE QuasiQuotes #-} +import Yesod +import Yesod.Constants +import Hack.Handler.SimpleServer + +data I18N = I18N + +instance Yesod I18N where + handlers = [$resources| +/: + Get: homepage +/set/$lang: + Get: setLang +|] + +homepage = return Hello + +setLang lang = do + addCookie 1 langKey lang + redirect "/" + return () + +data Hello = Hello + +instance HasReps Hello where + reps = [(TypeHtml, const $ return $ Content $ return . cs . content)] + where + content [] = "Hello" + content ("he":_) = "שלום" + content ("es":_) = "Hola" + content (_:rest) = content rest + + +main = putStrLn "Running..." >> run 3000 (toHackApp I18N) From 3137ee9bee961822be1dd009b13710a6dfb8c81f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 01:59:38 +0200 Subject: [PATCH 127/624] Removed reps from HasReps --- Test/QuasiResource.hs | 16 +++++------ Yesod/Handler.hs | 6 ++--- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Auth.hs | 4 +-- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Rep.hs | 56 ++++++++++++++++++--------------------- Yesod/Yesod.hs | 6 ++--- 7 files changed, 44 insertions(+), 48 deletions(-) diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 4aebc768..a833d8c9 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -12,19 +12,19 @@ import Data.List data MyYesod = MyYesod -instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" +instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] pageIndex :: Handler MyYesod HtmlObject pageIndex = return $ toHtmlObject ["pageIndex"] -pageAdd :: Handler MyYesod RepChooser +pageAdd :: Handler MyYesod ChooseRep pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] -pageDetail :: String -> Handler MyYesod RepChooser +pageDetail :: String -> Handler MyYesod ChooseRep pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] pageDelete :: String -> Handler MyYesod HtmlObject pageDelete s = return $ toHtmlObject ["pageDelete", s] -pageUpdate :: String -> Handler MyYesod RepChooser +pageUpdate :: String -> Handler MyYesod ChooseRep pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] userInfo :: Int -> Handler MyYesod HtmlObject userInfo i = return $ toHtmlObject ["userInfo", show i] @@ -33,11 +33,11 @@ userVariable i s = return $ toHtmlObject ["userVariable", show i, s] userPage :: Int -> [String] -> Handler MyYesod HtmlObject userPage i p = return $ toHtmlObject ["userPage", show i, show p] -instance Show (Verb -> Handler MyYesod RepChooser) where +instance Show (Verb -> Handler MyYesod ChooseRep) where show _ = "verb -> handler" -instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where +instance Show (Resource -> Verb -> Handler MyYesod ChooseRep) where show _ = "resource -> verb -> handler" -handler :: Resource -> Verb -> Handler MyYesod RepChooser +handler :: Resource -> Verb -> Handler MyYesod ChooseRep handler = [$resources| /static/*filepath/: getStatic /page/: @@ -55,7 +55,7 @@ handler = [$resources| Get: userPage |] -ph :: [String] -> Handler MyYesod RepChooser -> Assertion +ph :: [String] -> Handler MyYesod ChooseRep -> Assertion ph ss h = do let eh = return . chooseRep . toHtmlObject . show rr = error "No raw request" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2a2fb082..46ef947c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -95,8 +95,8 @@ getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) instance HasTemplateGroup (Handler yesod) where getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) -runHandler :: Handler yesod RepChooser - -> (ErrorResponse -> Handler yesod RepChooser) +runHandler :: Handler yesod ChooseRep + -> (ErrorResponse -> Handler yesod ChooseRep) -> RawRequest -> yesod -> TemplateGroup @@ -124,7 +124,7 @@ runHandler (Handler handler) eh rr y tg cts = do (ct, c) <- a cts return $ Response 200 headers ct c -safeEh :: ErrorResponse -> Handler yesod RepChooser +safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index b0377c32..1e6854e5 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -40,7 +40,7 @@ data AtomFeed = AtomFeed , atomEntries :: [AtomFeedEntry] } instance HasReps AtomFeedResponse where - reps = + chooseRep = defChooseRep [ (TypeAtom, return . cs) ] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 39ff7114..900414c8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -65,10 +65,10 @@ data AuthResource = | LoginRpxnow deriving (Show, Eq, Enum, Bounded) -rc :: HasReps x => Handler y x -> Handler y RepChooser +rc :: HasReps x => Handler y x -> Handler y ChooseRep rc = fmap chooseRep -authHandler :: YesodAuth y => Verb -> [String] -> Handler y RepChooser +authHandler :: YesodAuth y => Verb -> [String] -> Handler y ChooseRep authHandler Get ["check"] = rc authCheck authHandler Get ["logout"] = rc authLogout authHandler Get ["openid"] = rc authOpenidForm diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 04780092..ca7687b4 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -69,7 +69,7 @@ instance ConvertSuccess SitemapResponse Html where ] instance HasReps SitemapResponse where - reps = + chooseRep = defChooseRep [ (TypeXml, return . cs) ] diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index e0f846a0..6e4ff037 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -27,9 +27,9 @@ -- effort. module Yesod.Rep ( Content (..) - , RepChooser - , ContentPair + , ChooseRep , HasReps (..) + , defChooseRep -- * Specific types of representations , Plain (..) , plain @@ -77,38 +77,36 @@ instance ConvertSuccess HtmlDoc Content where instance ConvertSuccess XmlDoc Content where convertSuccess = cs . unXmlDoc -type ContentPair = (ContentType, Content) -type RepChooser = [ContentType] -> IO ContentPair +type ChooseRep = [ContentType] -> IO (ContentType, Content) -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: [(ContentType, a -> IO Content)] - chooseRep :: a -> RepChooser - chooseRep 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 :: ContentType -> Maybe ContentPair - helper ct = do - c <- lookup ct reps - return (ct, c) + chooseRep :: a -> ChooseRep -instance HasReps RepChooser where - reps = error "reps of RepChooser" +-- | 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 - reps = [(TypePlain, const $ return $ cs "")] + chooseRep = defChooseRep [(TypePlain, const $ return $ cs "")] instance HasReps [(ContentType, Content)] where - reps = error "reps of [(ContentType, Content)]" chooseRep a cts = return $ case filter (\(ct, _) -> ct `elem` cts) a of ((ct, c):_) -> (ct, c) @@ -119,7 +117,7 @@ instance HasReps [(ContentType, Content)] where newtype Plain = Plain { unPlain :: Text } deriving (Eq, Show) instance HasReps Plain where - reps = [(TypePlain, return . cs . unPlain)] + chooseRep = defChooseRep [(TypePlain, return . cs . unPlain)] plain :: ConvertSuccess x Text => x -> Plain plain = Plain . cs @@ -129,7 +127,7 @@ data Template = Template (StringTemplate Text) HtmlObject (IO [(String, HtmlObject)]) instance HasReps Template where - reps = [ (TypeHtml, + chooseRep = defChooseRep [ (TypeHtml, \(Template t name ho attrsIO) -> do attrs <- attrsIO return @@ -144,7 +142,7 @@ instance HasReps Template where -- FIXME data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where - reps = [ (TypeHtml, + chooseRep = defChooseRep [ (TypeHtml, \(TemplateFile fp h) -> do contents <- readFile fp let t = newSTMP contents @@ -156,19 +154,17 @@ instance HasReps TemplateFile where data Static = Static ContentType ByteString instance HasReps Static where - reps = error "reps of Static" chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) data StaticFile = StaticFile ContentType FilePath instance HasReps StaticFile where - reps = error "reps of StaticFile" chooseRep (StaticFile ct fp) _ = do bs <- BL.readFile fp return (ct, Content $ const $ return bs) -- Useful instances of HasReps instance HasReps HtmlObject where - reps = + chooseRep = defChooseRep [ (TypeHtml, return . cs . unHtmlDoc . cs) , (TypeJson, return . cs . unJsonDoc . cs) ] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index bd59f9b8..daa9f15d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -30,7 +30,7 @@ import Hack.Middleware.MethodOverride class Yesod a where -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, -- see the examples/fact.lhs sample. - handlers :: Resource -> Verb -> Handler a RepChooser + handlers :: Resource -> Verb -> Handler a ChooseRep -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -42,7 +42,7 @@ class Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: ErrorResponse -> Handler a RepChooser + errorHandler :: ErrorResponse -> Handler a ChooseRep errorHandler = defaultErrorHandler -- | The template directory. Blank means no templates. @@ -58,7 +58,7 @@ getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y => ErrorResponse - -> Handler y RepChooser + -> Handler y ChooseRep defaultErrorHandler NotFound = do rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr From ec5b9863d57176e3fb73f6c4e3a170ca46427447 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 02:06:02 +0200 Subject: [PATCH 128/624] Moved the meat of Yesod.Rep to Yesod.Response --- Yesod/Rep.hs | 64 ++++------------------------------------- Yesod/Resource.hs | 2 +- Yesod/Response.hs | 73 ++++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 72 insertions(+), 67 deletions(-) diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 6e4ff037..10c44861 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -26,12 +26,8 @@ -- all data can be contained in an 'Object'; however, some of it requires more -- effort. module Yesod.Rep - ( Content (..) - , ChooseRep - , HasReps (..) - , defChooseRep - -- * Specific types of representations - , Plain (..) + ( -- * Specific types of representations + Plain (..) , plain , Template (..) , TemplateFile (..) @@ -43,16 +39,16 @@ module Yesod.Rep ) where import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL import Data.Text.Lazy (Text) -import Data.Maybe (mapMaybe) +import qualified Data.ByteString.Lazy as BL import Web.Mime -import Yesod.Definitions #if TEST import Data.Object.Html hiding (testSuite) +import Yesod.Response hiding (testSuite) #else import Data.Object.Html +import Yesod.Response #endif import Data.Object.Json @@ -64,56 +60,6 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #endif -newtype Content = Content { unContent :: [Language] -> IO ByteString } - -instance ConvertSuccess Text Content where - convertSuccess = Content . const . return . cs -instance ConvertSuccess ByteString Content where - convertSuccess = Content . const . return -instance ConvertSuccess String Content where - convertSuccess = Content . const . return . cs -instance ConvertSuccess HtmlDoc Content where - convertSuccess = cs . unHtmlDoc -instance ConvertSuccess XmlDoc Content where - convertSuccess = cs . unXmlDoc - -type ChooseRep = [ContentType] -> IO (ContentType, Content) - --- | Any type which can be converted to representations. There must be at least --- one representation for each type. -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, _) -> ct `elem` cts) a of - ((ct, c):_) -> (ct, c) - _ -> case a of - (x:_) -> x - _ -> error "chooseRep [(ContentType, Content)] of empty" - newtype Plain = Plain { unPlain :: Text } deriving (Eq, Show) instance HasReps Plain where diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 0b1917a4..8fa4b9e2 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -51,7 +51,7 @@ import Control.Monad ((<=<), unless) import Data.Object.Yaml import Yesod.Handler import Data.Maybe (fromJust) -import Yesod.Rep (chooseRep) +import Yesod.Response (chooseRep) import Control.Arrow #if TEST diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 67de0456..cc37d40b 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -18,7 +18,12 @@ -- --------------------------------------------------------- module Yesod.Response - ( Response (..) + ( -- * Representations + Content (..) + , ChooseRep + , HasReps (..) + , defChooseRep + , Response (..) -- * Special responses , RedirectType (..) , getRedirectStatus @@ -37,17 +42,21 @@ module Yesod.Response #endif ) where -#if TEST -import Yesod.Rep hiding (testSuite) -#else -import Yesod.Rep -#endif - import Data.Time.Clock +import Data.Maybe (mapMaybe) +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy (Text) +import Yesod.Definitions import Web.Encodings (formatW3) import qualified Hack +#if TEST +import Data.Object.Html hiding (testSuite) +#else +import Data.Object.Html +#endif + #if TEST import Test.Framework (testGroup, Test) #endif @@ -55,6 +64,56 @@ import Test.Framework (testGroup, Test) import Data.Convertible.Text (cs) import Web.Mime +newtype Content = Content { unContent :: [Language] -> IO ByteString } + +instance ConvertSuccess Text Content where + convertSuccess = Content . const . return . cs +instance ConvertSuccess ByteString Content where + convertSuccess = Content . const . return +instance ConvertSuccess String Content where + convertSuccess = Content . const . return . cs +instance ConvertSuccess HtmlDoc Content where + convertSuccess = cs . unHtmlDoc +instance ConvertSuccess XmlDoc Content where + convertSuccess = cs . unXmlDoc + +type ChooseRep = [ContentType] -> IO (ContentType, Content) + +-- | Any type which can be converted to representations. There must be at least +-- one representation for each type. +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, _) -> ct `elem` cts) a of + ((ct, c):_) -> (ct, c) + _ -> case a of + (x:_) -> x + _ -> error "chooseRep [(ContentType, Content)] of empty" + data Response = Response Int [Header] ContentType Content -- | Different types of redirects. From 90e197ae46ee827ac8d5cadd201892b79fddc64f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 02:16:55 +0200 Subject: [PATCH 129/624] Attempting to use SendFile throughout --- Yesod/Handler.hs | 5 ++++- Yesod/Helpers/Static.hs | 9 +++++---- Yesod/Rep.hs | 15 --------------- Yesod/Response.hs | 12 +++++++++--- Yesod/Yesod.hs | 1 - 5 files changed, 18 insertions(+), 24 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 46ef947c..0d6cd14c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -26,6 +26,7 @@ module Yesod.Handler --, ToHandler (..) -- * Special handlers , redirect + , sendFile , notFound , permissionDenied , invalidArgs @@ -37,7 +38,6 @@ module Yesod.Handler import Yesod.Request import Yesod.Response -import Yesod.Rep import Yesod.Template import Web.Mime @@ -140,6 +140,9 @@ errorResponse er = Handler $ \_ -> return ([], HCError er) 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 :: Handler yesod a notFound = errorResponse NotFound diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 6d9a91a1..83a98fc0 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -24,13 +24,13 @@ module Yesod.Helpers.Static import qualified Data.ByteString.Lazy as B import System.Directory (doesFileExist) -import Control.Applicative ((<$>)) import Control.Monad import Yesod import Data.List (intercalate) -type FileLookup = FilePath -> IO (Maybe B.ByteString) +-- FIXME this type is getting ugly... +type FileLookup = FilePath -> IO (Maybe (Either FilePath B.ByteString)) -- | 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 @@ -43,7 +43,7 @@ fileLookupDir dir fp = do let fp' = dir ++ '/' : fp exists <- doesFileExist fp' if exists - then Just <$> B.readFile fp' -- FIXME replace lazy I/O when possible + then return $ Just $ Left fp' else return Nothing serveStatic :: FileLookup -> Verb -> [String] @@ -58,7 +58,8 @@ getStatic fl fp' = do content <- liftIO $ fl fp case content of Nothing -> notFound - Just bs -> return [(typeByExt $ ext fp, cs bs)] + Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp'' + Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)] where isUnsafe [] = True isUnsafe ('.':_) = True diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 10c44861..a8facc6a 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -32,7 +32,6 @@ module Yesod.Rep , Template (..) , TemplateFile (..) , Static (..) - , StaticFile (..) #if TEST , testSuite #endif @@ -40,7 +39,6 @@ module Yesod.Rep import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) -import qualified Data.ByteString.Lazy as BL import Web.Mime #if TEST @@ -102,19 +100,6 @@ data Static = Static ContentType ByteString instance HasReps Static where chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) -data StaticFile = StaticFile ContentType FilePath -instance HasReps StaticFile where - chooseRep (StaticFile ct fp) _ = do - bs <- BL.readFile fp - return (ct, Content $ const $ return bs) - --- Useful instances of HasReps -instance HasReps HtmlObject where - chooseRep = defChooseRep - [ (TypeHtml, return . cs . unHtmlDoc . cs) - , (TypeJson, return . cs . unJsonDoc . cs) - ] - #if TEST caseChooseRepHO :: Assertion caseChooseRepHO = do diff --git a/Yesod/Response.hs b/Yesod/Response.hs index cc37d40b..621ebbfb 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -47,6 +47,7 @@ import Data.Maybe (mapMaybe) import Data.ByteString.Lazy (ByteString) import Data.Text.Lazy (Text) import Yesod.Definitions +import Data.Object.Json import Web.Encodings (formatW3) import qualified Hack @@ -61,7 +62,6 @@ import Data.Object.Html import Test.Framework (testGroup, Test) #endif -import Data.Convertible.Text (cs) import Web.Mime newtype Content = Content { unContent :: [Language] -> IO ByteString } @@ -79,8 +79,7 @@ instance ConvertSuccess XmlDoc Content where type ChooseRep = [ContentType] -> IO (ContentType, Content) --- | Any type which can be converted to representations. There must be at least --- one representation for each type. +-- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep @@ -114,6 +113,13 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" +-- FIXME remove this instance? only good for debugging, maybe special debugging newtype? +instance HasReps HtmlObject where + chooseRep = defChooseRep + [ (TypeHtml, return . cs . unHtmlDoc . cs) + , (TypeJson, return . cs . unJsonDoc . cs) + ] + data Response = Response Int [Header] ContentType Content -- | Different types of redirects. diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index daa9f15d..72abfd8b 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -6,7 +6,6 @@ module Yesod.Yesod , toHackApp ) where -import Yesod.Rep import Data.Object.Html (toHtmlObject) import Yesod.Response import Yesod.Request From e7a2e1cfca16cee75fa58c480e29601fa23244b7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 25 Jan 2010 21:52:27 +0200 Subject: [PATCH 130/624] Removed Yesod.Rep --- Yesod.hs | 3 - Yesod/Helpers/Sitemap.hs | 4 +- Yesod/Rep.hs | 175 --------------------------------------- Yesod/Response.hs | 10 +++ Yesod/Template.hs | 36 +++++++- examples/fact.lhs | 4 +- examples/i18n.hs | 8 +- runtests.hs | 2 - yesod.cabal | 1 - 9 files changed, 53 insertions(+), 190 deletions(-) delete mode 100644 Yesod/Rep.hs diff --git a/Yesod.hs b/Yesod.hs index 574bf690..aa2fc607 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -22,7 +22,6 @@ module Yesod , module Yesod.Resource , module Data.Object.Html , module Yesod.Parameter - , module Yesod.Rep , module Yesod.Template , module Web.Mime , Application @@ -32,13 +31,11 @@ module Yesod import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) import Data.Object.Html hiding (testSuite) -import Yesod.Rep hiding (testSuite) import Yesod.Request hiding (testSuite) #else import Yesod.Resource import Yesod.Response import Data.Object.Html -import Yesod.Rep import Yesod.Request #endif diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index ca7687b4..a22f26f4 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -78,9 +78,9 @@ sitemap urls = do yesod <- getYesod return $ SitemapResponse urls $ approot yesod -robots :: YesodApproot yesod => Handler yesod Plain +robots :: YesodApproot yesod => Handler yesod [(ContentType, Content)] robots = do yesod <- getYesod - return $ plain $ "Sitemap: " ++ showLocation + return $ staticRep TypePlain $ "Sitemap: " ++ showLocation (approot yesod) (RelLoc "sitemap.xml") diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs deleted file mode 100644 index a8facc6a..00000000 --- a/Yesod/Rep.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | Representations of data. A representation is basically how you display --- information in a certain mime-type. For example, tree-style data can easily --- be displayed as both JSON and Yaml. --- --- To save programmers\' fingers, the name of this module and all data types --- and classes replaces the full word Representation with Rep. --- --- This concept is core to a RESTful framework. For example, if a user goes to --- /movies/star-wars/, they'll want a HTML page describing the Star Wars movie. --- However, if you've written an Ajax front-end, they might want than --- information in XML or JSON format. There could also be another web service --- that requests this information in a binary format to save on bandwidth. --- --- Since the vast majority of information that is dealt with in web --- applications can be easily displayed using an 'Object', that is probably --- your best bet on internal data format to use. If you need HTML escaping, --- then specifically an 'HtmlObject' will be even better. --- --- By the way, I said above that the vast majority of information can be --- contained in an 'Object' easily. The key word here is \"easily\"; in fact, --- all data can be contained in an 'Object'; however, some of it requires more --- effort. -module Yesod.Rep - ( -- * Specific types of representations - Plain (..) - , plain - , Template (..) - , TemplateFile (..) - , Static (..) -#if TEST - , testSuite -#endif - ) where - -import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (Text) -import Web.Mime - -#if TEST -import Data.Object.Html hiding (testSuite) -import Yesod.Response hiding (testSuite) -#else -import Data.Object.Html -import Yesod.Response -#endif - -import Data.Object.Json -import Text.StringTemplate - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - -newtype Plain = Plain { unPlain :: Text } - deriving (Eq, Show) -instance HasReps Plain where - chooseRep = defChooseRep [(TypePlain, return . cs . unPlain)] - -plain :: ConvertSuccess x Text => x -> Plain -plain = Plain . cs - -data Template = Template (StringTemplate Text) - String - HtmlObject - (IO [(String, HtmlObject)]) -instance HasReps Template where - chooseRep = defChooseRep [ (TypeHtml, - \(Template t name ho attrsIO) -> do - attrs <- attrsIO - return - $ cs - $ render - $ setAttribute name ho - $ setManyAttrib attrs t) - , (TypeJson, \(Template _ _ ho _) -> - return $ cs $ unJsonDoc $ cs ho) - ] - --- FIXME -data TemplateFile = TemplateFile FilePath HtmlObject -instance HasReps TemplateFile where - chooseRep = defChooseRep [ (TypeHtml, - \(TemplateFile fp h) -> do - contents <- readFile fp - let t = newSTMP contents - return $ cs $ toString $ setAttribute "o" h t - ) - , (TypeJson, \(TemplateFile _ ho) -> - return $ cs $ unJsonDoc $ cs ho) - ] - -data Static = Static ContentType ByteString -instance HasReps Static where - chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) - -#if TEST -caseChooseRepHO :: Assertion -caseChooseRepHO = do - {- FIXME - let content = "IGNOREME" - a = toHtmlObject content - htmlbs = cs . unHtmlDoc . cs $ toHtmlObject content - jsonbs = cs $ "\"" ++ content ++ "\"" - chooseRep a [TypeHtml] >>= (@?= (TypeHtml, htmlbs)) - chooseRep a [TypeJson] >>= (@?= (TypeJson, jsonbs)) - chooseRep a [TypeHtml, TypeJson] >>= (@?= (TypeHtml, htmlbs)) - chooseRep a [TypeOther "foo", TypeJson] >>= (@?= (TypeJson, jsonbs)) - -} - return () - -caseChooseRepRaw :: Assertion -caseChooseRepRaw = do - {- FIXME - let content = Content $ cs "FOO" - foo = TypeOther "foo" - bar = TypeOther "bar" - hasreps = [(TypeHtml, content), (foo, content)] - chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, content)) - chooseRep hasreps [foo, bar] >>= (@?= (foo, content)) - chooseRep hasreps [bar, foo] >>= (@?= (foo, content)) - chooseRep hasreps [bar] >>= (@?= (TypeHtml, content)) - -} - return () - -caseChooseRepTemplate :: Assertion -caseChooseRepTemplate = do - {- FIXME - let temp = newSTMP "foo:$o.foo$, bar:$o.bar$" - ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", Sequence $ map cs ["bar1", "bar2"]) - ] - hasreps = Template temp "o" ho $ return [] - res1 = cs "foo:<fooval>, bar:bar1bar2" - res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ - "\"foo\":\"<fooval>\"}" - chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) - chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) - chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) - chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) - -} - return () - -caseChooseRepTemplateFile :: Assertion -caseChooseRepTemplateFile = do - {- FIXME - let temp = "Test/rep.st" - ho = toHtmlObject [ ("foo", toHtmlObject "") - , ("bar", Sequence $ map cs ["bar1", "bar2"]) - ] - hasreps = TemplateFile temp ho - res1 = cs "foo:<fooval>, bar:bar1bar2" - res2 = cs $ "{\"bar\":[\"bar1\",\"bar2\"]," ++ - "\"foo\":\"<fooval>\"}" - chooseRep hasreps [TypeHtml] >>= (@?= (TypeHtml, res1)) - chooseRep hasreps [TypeJson] >>= (@?= (TypeJson, res2)) - chooseRep hasreps [TypeHtml, TypeJson] >>= (@?= (TypeHtml, res1)) - chooseRep hasreps [TypeJson, TypeHtml] >>= (@?= (TypeJson, res2)) - -} - return () - -testSuite :: Test -testSuite = testGroup "Yesod.Rep" - [ testCase "caseChooseRep HtmlObject" caseChooseRepHO - , testCase "caseChooseRep raw" caseChooseRepRaw - , testCase "caseChooseRep Template" caseChooseRepTemplate - , testCase "caseChooseRep TemplateFile" caseChooseRepTemplateFile - ] -#endif diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 621ebbfb..3fb0ba17 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -23,6 +23,9 @@ module Yesod.Response , ChooseRep , HasReps (..) , defChooseRep + -- ** Convenience wrappers + , staticRep + -- * Response type , Response (..) -- * Special responses , RedirectType (..) @@ -120,6 +123,13 @@ instance HasReps HtmlObject where , (TypeJson, return . cs . unJsonDoc . cs) ] +-- | Data with a single representation. +staticRep :: ConvertSuccess x ByteString + => ContentType + -> x + -> [(ContentType, Content)] +staticRep ct x = [(ct, cs (cs x :: ByteString))] + data Response = Response Int [Header] ContentType Content -- | Different types of redirects. diff --git a/Yesod/Template.hs b/Yesod/Template.hs index 84431566..b145d95d 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -5,15 +5,19 @@ module Yesod.Template , template , NoSuchTemplate , TemplateGroup + , Template (..) + , TemplateFile (..) ) where import Data.Object.Html import Data.Typeable (Typeable) import Control.Exception (Exception) import Control.Failure -import Yesod.Rep import Data.Object.Text (Text) import Text.StringTemplate +import Data.Object.Json +import Web.Mime +import Yesod.Response type TemplateGroup = STGroup Text @@ -36,3 +40,33 @@ template tn on o attrs = do newtype NoSuchTemplate = NoSuchTemplate String deriving (Show, Typeable) instance Exception NoSuchTemplate + +data Template = Template (StringTemplate Text) + String + HtmlObject + (IO [(String, HtmlObject)]) +instance HasReps Template where + chooseRep = defChooseRep [ (TypeHtml, + \(Template t name ho attrsIO) -> do + attrs <- attrsIO + return + $ cs + $ render + $ setAttribute name ho + $ setManyAttrib attrs t) + , (TypeJson, \(Template _ _ ho _) -> + return $ cs $ unJsonDoc $ cs ho) + ] + +-- FIXME +data TemplateFile = TemplateFile FilePath HtmlObject +instance HasReps TemplateFile where + chooseRep = defChooseRep [ (TypeHtml, + \(TemplateFile fp h) -> do + contents <- readFile fp + let t = newSTMP contents + return $ cs $ toString $ setAttribute "o" h t + ) + , (TypeJson, \(TemplateFile _ ho) -> + return $ cs $ unJsonDoc $ cs ho) + ] diff --git a/examples/fact.lhs b/examples/fact.lhs index 9b1e7e31..87460d3a 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -66,7 +66,7 @@ request method.) This does what it looks like: serves a static HTML file. -> index = return $ StaticFile TypeHtml "examples/fact.html" +> 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: @@ -90,7 +90,7 @@ one piece of data. > factRedirect :: Handler y () > factRedirect = do > i <- runRequest $ getParam "num" -> redirect $ "../" ++ i ++ "/" +> redirect RedirectPermanent $ "../" ++ i ++ "/" The following line would be unnecesary if we had a type signature on factRedirect. diff --git a/examples/i18n.hs b/examples/i18n.hs index 1e5bc419..6e7cc36f 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -1,6 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Yesod.Constants import Hack.Handler.SimpleServer data I18N = I18N @@ -17,13 +16,14 @@ homepage = return Hello setLang lang = do addCookie 1 langKey lang - redirect "/" + redirect RedirectTemporary "/" return () data Hello = Hello instance HasReps Hello where - reps = [(TypeHtml, const $ return $ Content $ return . cs . content)] + chooseRep = defChooseRep + [(TypeHtml, const $ return $ Content $ return . cs . content)] where content [] = "Hello" content ("he":_) = "שלום" @@ -31,4 +31,4 @@ instance HasReps Hello where content (_:rest) = content rest -main = putStrLn "Running..." >> run 3000 (toHackApp I18N) +main = putStrLn "Running..." >> toHackApp I18N >>= run 3000 diff --git a/runtests.hs b/runtests.hs index a5e8e423..5abb4cbe 100644 --- a/runtests.hs +++ b/runtests.hs @@ -2,7 +2,6 @@ import Test.Framework (defaultMain) import qualified Yesod.Response import qualified Yesod.Resource -import qualified Yesod.Rep import qualified Yesod.Request import qualified Data.Object.Html import qualified Test.Errors @@ -12,7 +11,6 @@ main :: IO () main = defaultMain [ Yesod.Response.testSuite , Yesod.Resource.testSuite - , Yesod.Rep.testSuite , Yesod.Request.testSuite , Data.Object.Html.testSuite , Test.Errors.testSuite diff --git a/yesod.cabal b/yesod.cabal index ee6c943f..dc2fb2ba 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -55,7 +55,6 @@ library failure >= 0.0.0 && < 0.1, safe-failure >= 0.4.0 && < 0.5 exposed-modules: Yesod - Yesod.Rep Yesod.Request Yesod.Response Yesod.Definitions From 764b981f6c10cfd8868c6b665fecd249220d5df0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jan 2010 00:16:02 +0200 Subject: [PATCH 131/624] Changed Content data type. Removed i18n and pushed it back into RawRequest. Now prepared for the WAI interface, though this is less efficient for Hack. --- Yesod/Request.hs | 16 +++++++++++++++- Yesod/Response.hs | 38 +++++++++++++++++++++++++++----------- Yesod/Yesod.hs | 10 +--------- examples/i18n.hs | 22 +++++++++------------- 4 files changed, 52 insertions(+), 34 deletions(-) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5e3458b3..64927cc7 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -28,6 +28,7 @@ module Yesod.Request , cookies , getParams , postParams + , languages -- * Building actual request , Request (..) , Hack.RequestMethod (..) @@ -39,6 +40,7 @@ module Yesod.Request import qualified Hack import Data.Function.Predicate (equals) import Yesod.Parameter +import Yesod.Definitions import Control.Applicative (Applicative (..)) import Web.Encodings import qualified Data.ByteString.Lazy as BL @@ -99,6 +101,9 @@ getParam = genParam getParams GetParam postParam :: (Parameter a) => ParamName -> Request a postParam = genParam postParams PostParam +languages :: (Functor m, RequestReader m) => m [Language] +languages = rawLangs `fmap` getRawRequest + -- | Get the raw 'Hack.Env' value. parseEnv :: (Functor m, RequestReader m) => m Hack.Env parseEnv = rawEnv `fmap` getRawRequest @@ -112,6 +117,7 @@ data RawRequest = RawRequest , rawPostParams :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawEnv :: Hack.Env + , rawLangs :: [Language] } deriving Show @@ -145,7 +151,15 @@ instance ConvertSuccess Hack.Env RawRequest where $ Hack.hackInput env rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest gets' cookies' posts files env + acceptLang = lookup "Accept-Language" $ Hack.http env + langs = 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' + in RawRequest gets' cookies' posts files env langs'' #if TEST testSuite :: Test diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 3fb0ba17..645babf5 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- -- Module : Yesod.Response @@ -47,10 +48,12 @@ module Yesod.Response import Data.Time.Clock import Data.Maybe (mapMaybe) -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy (ByteString, toChunks, fromChunks) +import qualified Data.ByteString as B import Data.Text.Lazy (Text) -import Yesod.Definitions +import qualified Data.Text as T import Data.Object.Json +import Control.Monad (foldM) import Web.Encodings (formatW3) import qualified Hack @@ -67,14 +70,18 @@ import Test.Framework (testGroup, Test) import Web.Mime -newtype Content = Content { unContent :: [Language] -> IO ByteString } +data Content = Content (forall a. ((a -> B.ByteString -> IO a) -> a -> IO a)) -instance ConvertSuccess Text Content where - convertSuccess = Content . const . return . cs +instance ConvertSuccess B.ByteString Content where + convertSuccess bs = Content $ \f a -> f a bs instance ConvertSuccess ByteString Content where - convertSuccess = Content . const . return + convertSuccess lbs = Content $ \f a -> foldM f a $ toChunks lbs +instance ConvertSuccess T.Text Content where + convertSuccess t = cs (cs t :: B.ByteString) +instance ConvertSuccess Text Content where + convertSuccess lt = cs (cs lt :: ByteString) instance ConvertSuccess String Content where - convertSuccess = Content . const . return . cs + convertSuccess s = cs (cs s :: Text) instance ConvertSuccess HtmlDoc Content where convertSuccess = cs . unHtmlDoc instance ConvertSuccess XmlDoc Content where @@ -185,14 +192,23 @@ headerToPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair (Header key value) = return (key, value) -responseToHackResponse :: [String] -- ^ language list - -> Response -> IO Hack.Response -responseToHackResponse ls (Response sc hs ct c) = do +responseToHackResponse :: Response -> IO Hack.Response +responseToHackResponse (Response sc hs ct c) = do hs' <- mapM headerToPair hs let hs'' = ("Content-Type", cs ct) : hs' - asLBS <- unContent c ls + asLBS <- runContent c return $ Hack.Response sc hs'' asLBS +runContent :: Content -> IO ByteString +runContent (Content c) = do + front <- c helper id + return $ fromChunks $ front [] + where + helper :: ([B.ByteString] -> [B.ByteString]) + -> B.ByteString + -> IO ([B.ByteString] -> [B.ByteString]) + helper front bs = return $ front . (:) bs + #if TEST ----- Testing testSuite :: Test diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 72abfd8b..e77e7864 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -101,15 +101,7 @@ toHackApp'' y tg env = do handler = handlers resource verb rr = cs env res <- runHandler handler errorHandler rr y tg types - let acceptLang = lookup "Accept-Language" $ Hack.http env - let langs = maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey $ rawCookies rr of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey $ rawGetParams rr of - Nothing -> langs' - Just x -> x : langs' - responseToHackResponse langs'' res + responseToHackResponse res httpAccept :: Hack.Env -> [ContentType] httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" diff --git a/examples/i18n.hs b/examples/i18n.hs index 6e7cc36f..e393ba2a 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -12,23 +12,19 @@ instance Yesod I18N where Get: setLang |] -homepage = return Hello +homepage = do + ls <- languages + let hello = chooseHello ls + return [(TypePlain, cs hello :: Content)] + +chooseHello [] = "Hello" +chooseHello ("he":_) = "שלום" +chooseHello ("es":_) = "Hola" +chooseHello (_:rest) = chooseHello rest setLang lang = do addCookie 1 langKey lang redirect RedirectTemporary "/" return () -data Hello = Hello - -instance HasReps Hello where - chooseRep = defChooseRep - [(TypeHtml, const $ return $ Content $ return . cs . content)] - where - content [] = "Hello" - content ("he":_) = "שלום" - content ("es":_) = "Hola" - content (_:rest) = content rest - - main = putStrLn "Running..." >> toHackApp I18N >>= run 3000 From ecb4d2f3344b9df216c9ca07ac737743549e5e74 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jan 2010 00:48:10 +0200 Subject: [PATCH 132/624] Removed Yesod.Parameter --- Test/Errors.hs | 5 ++ Test/QuasiResource.hs | 2 +- Yesod.hs | 2 - Yesod/Handler.hs | 2 - Yesod/Helpers/Auth.hs | 54 ++++++++++++------- Yesod/Parameter.hs | 121 ------------------------------------------ Yesod/Request.hs | 69 ++++-------------------- Yesod/Response.hs | 1 + yesod.cabal | 1 - 9 files changed, 53 insertions(+), 204 deletions(-) delete mode 100644 Yesod/Parameter.hs diff --git a/Test/Errors.hs b/Test/Errors.hs index 1363987a..0861a5de 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -35,8 +35,11 @@ needsIdent = do hasArgs :: Handler Errors HtmlObject hasArgs = do + {- FIXME wait for new request API (a, b) <- runRequest $ (,) <$> getParam "firstParam" <*> getParam "secondParam" + -} + let (a, b) = ("foo", "bar") return $ toHtmlObject [a :: String, b] caseErrorMessages :: Assertion @@ -46,8 +49,10 @@ caseErrorMessages = do assertBool "/denied/" $ "Permission denied" `isInfixOf` show res res' <- app $ def { pathInfo = "/needs-ident/" } assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' + {- FIXME this test is not yet ready res3 <- app $ def { pathInfo = "/has-args/" } assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 + -} testSuite :: Test testSuite = testGroup "Test.Errors" diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index a833d8c9..43ac1495 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -69,7 +69,7 @@ ph ss h = do assertBool needle $ needle `isInfixOf` haystack myShow :: Response -> IO String -myShow (Response sc hs ct (Content c)) = c [] >>= \c' -> return $ unlines +myShow (Response sc hs ct c) = runContent c >>= \c' -> return $ unlines [ show sc , unlines $ map show hs , show ct diff --git a/Yesod.hs b/Yesod.hs index aa2fc607..08425265 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -21,7 +21,6 @@ module Yesod , module Yesod.Handler , module Yesod.Resource , module Data.Object.Html - , module Yesod.Parameter , module Yesod.Template , module Web.Mime , Application @@ -39,7 +38,6 @@ import Data.Object.Html import Yesod.Request #endif -import Yesod.Parameter import Yesod.Yesod import Yesod.Definitions import Yesod.Handler diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d6cd14c..c1a6bb9d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -52,8 +52,6 @@ import System.IO import Data.Object.Html import qualified Data.ByteString.Lazy as BL -import Yesod.Parameter - ------ Handler monad newtype Handler yesod a = Handler { unHandler :: (RawRequest, yesod, TemplateGroup) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 900414c8..332185ae 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -33,7 +33,7 @@ import Control.Monad.Attempt import Data.Maybe (fromMaybe) import qualified Hack import Data.Typeable (Typeable) -import Control.Exception (Exception) +import Control.Exception (Exception, SomeException (..)) class YesodApproot a => YesodAuth a where -- | The following breaks DRY, but I cannot think of a better solution @@ -85,14 +85,37 @@ instance ConvertSuccess OIDFormReq Html where convertSuccess (OIDFormReq (Just s) _) = Tag "p" [("class", "message")] $ cs s +someParam :: (Monad m, RequestReader m) + => ParamType + -> (RawRequest -> ParamName -> [ParamValue]) + -> ParamName + -> m ParamValue +someParam pt paramList pn = do + rr <- getRawRequest + case paramList rr pn of + [x] -> return x + x -> invalidParams [((pt, pn, x), SomeException ExpectedSingleParam)] + +data ExpectedSingleParam = ExpectedSingleParam + deriving (Show, Typeable) +instance Exception ExpectedSingleParam + +getParam :: (Monad m, RequestReader m) + => ParamName + -> m ParamValue +getParam = someParam GetParam getParams + authOpenidForm :: Handler y HtmlObject authOpenidForm = do - message <- runRequest $ getParam "message" - dest <- runRequest $ getParam "dest" - let m = OIDFormReq message dest + rr <- getRawRequest + case getParams rr "dest" of + [] -> return () + (x:_) -> addCookie 120 "DEST" x let html = HtmlList - [ cs m + [ 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: " @@ -101,14 +124,11 @@ authOpenidForm = do , EmptyTag "input" [("type", "submit"), ("value", "Login")] ] ] - case dest of - Just dest' -> addCookie 120 "DEST" dest' - Nothing -> return () return $ cs html authOpenidForward :: YesodAuth y => Handler y HtmlObject authOpenidForward = do - oid <- runRequest $ getParam "openid" + oid <- getParam "openid" authroot <- getFullAuthRoot let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete @@ -147,15 +167,13 @@ rpxnowLogin = do let token = case getParams rr "token" ++ postParams rr "token" of [] -> failure MissingToken (x:_) -> x - postDest <- runRequest $ postParam "dest" - dest' <- case postDest of - Nothing -> runRequest $ getParam "dest" - Just d -> return d - let dest = case dest' of - Nothing -> ar - Just "" -> ar - Just ('#':rest) -> rest - Just s -> s + let dest = case postParams rr "dest" of + [] -> case getParams rr "dest" of + [] -> ar + ("":_) -> ar + (('#':rest):_) -> rest + (s:_) -> s + (d:_) -> d ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident diff --git a/Yesod/Parameter.hs b/Yesod/Parameter.hs deleted file mode 100644 index 9aa1db4a..00000000 --- a/Yesod/Parameter.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} -- Parameter String -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -module Yesod.Parameter - ( - -- * Parameter - -- $param_overview - Parameter (..) - , ParamType (..) - , ParamName - , ParamValue - , ParamAttempt (..) - , ParamException - -- * Exceptions - , ParameterCountException (..) - , InvalidBool (..) - ) where - -import Data.Time.Calendar (Day) -import Control.Applicative -import Data.Typeable (Typeable) -import Control.Exception (Exception, SomeException (..)) -import Data.Attempt -import qualified Safe.Failure as SF -import Data.Convertible.Text - --- FIXME instead of plain Attempt, an Attempt that defines better error --- reporting (eg, multilingual) - --- $param_overview --- In Restful, all of the underlying parameter values are strings. They can --- come from multiple sources: GET parameters, URL rewriting (FIXME: link), --- cookies, etc. However, most applications eventually want to convert --- those strings into something else, like 'Int's. Additionally, it is --- often desirable to allow multiple values, or no value at all. --- --- That is what the parameter concept is for. A 'Parameter' is any value --- which can be converted from a 'String', or list of 'String's. - --- | Where this parameter came from. -data ParamType = - GetParam - | PostParam - deriving (Eq, Show) - -type ParamName = String - --- | The 'String' value of a parameter. -type ParamValue = String - --- | Anything which can be converted from a list of 'String's. --- --- The default implementation of 'readParams' will error out if given --- anything but 1 'ParamValue'. This is usually what you want. --- --- Minimal complete definition: either 'readParam' or 'readParams'. -class Parameter a where - -- | Convert a string into the desired value, or explain why that can't - -- happen. - readParam :: ParamValue -> Attempt a - readParam = readParams . return - - -- | Convert a list of strings into the desired value, or explain why - -- that can't happen. - readParams :: [ParamValue] -> Attempt a - readParams [x] = readParam x - readParams [] = failure MissingParameter - readParams xs = failure $ ExtraParameters $ length xs - -data ParamAttempt v = ParamSuccess v - | ParamFailure ParamException -instance Functor ParamAttempt where - fmap _ (ParamFailure pf) = ParamFailure pf - fmap f (ParamSuccess v) = ParamSuccess $ f v -instance Applicative ParamAttempt where - pure = ParamSuccess - (ParamFailure pf1) <*> (ParamFailure pf2) = ParamFailure $ pf1 ++ pf2 - (ParamFailure pf) <*> _ = ParamFailure pf - _ <*> ParamFailure pf = ParamFailure pf - (ParamSuccess f) <*> (ParamSuccess v) = ParamSuccess $ f v -instance Try ParamAttempt where - type Error ParamAttempt = ParamException - try (ParamSuccess v) = pure v - try (ParamFailure f) = failure f -type ParamException = [((ParamType, ParamName, [ParamValue]), SomeException)] - -data ParameterCountException = MissingParameter | ExtraParameters Int - deriving (Show, Typeable) -instance Exception ParameterCountException - -instance Parameter a => Parameter (Maybe a) where - readParams [] = return Nothing - readParams [x] = Just `fmap` readParam x - readParams xs = failure $ ExtraParameters $ length xs - -instance Parameter a => Parameter [a] where - readParams = mapM readParam where - -instance Parameter String where - readParam = return - -instance Parameter Int where - readParam = ca - -instance Parameter Integer where - readParam = SF.read - -instance Parameter Day where - readParam = ca - --- for checkboxes; checks for presence or a "false" value -instance Parameter Bool where - readParams [] = return False - readParams ["false"] = return False -- FIXME more values? - readParams [_] = return True - readParams x = failure $ InvalidBool x - -data InvalidBool = InvalidBool [ParamValue] - deriving (Show, Typeable) -instance Exception InvalidBool diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 64927cc7..cbe02d6f 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -21,17 +21,18 @@ module Yesod.Request -- * RawRequest RawRequest (..) , RequestReader (..) - , getParam - , postParam , parseEnv - , runRequest , cookies , getParams , postParams , languages -- * Building actual request - , Request (..) , Hack.RequestMethod (..) + -- * Parameter + , ParamType (..) + , ParamName + , ParamValue + , ParamException #if TEST , testSuite #endif @@ -39,15 +40,12 @@ module Yesod.Request import qualified Hack import Data.Function.Predicate (equals) -import Yesod.Parameter import Yesod.Definitions -import Control.Applicative (Applicative (..)) import Web.Encodings import qualified Data.ByteString.Lazy as BL import Data.Convertible.Text import Control.Arrow ((***)) import Control.Exception (SomeException (..)) -import Data.Attempt import Data.Maybe (fromMaybe) #if TEST @@ -56,50 +54,14 @@ import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) #endif -newtype Request v = Request { unRequest :: RawRequest - -> Either ParamException v } -instance Functor Request where - fmap f (Request r) = Request $ fmap f . r -instance Applicative Request where - pure = Request . const . Right - (Request f) <*> (Request r) = Request helper where - helper rr = helper2 (f rr) (r rr) - helper2 (Left e1) (Left e2) = Left $ e1 ++ e2 - helper2 (Left e) _ = Left e - helper2 _ (Left e) = Left e - helper2 (Right f') (Right r') = Right $ f' r' +data ParamType = GetParam | PostParam +type ParamName = String +type ParamValue = String +type ParamException = [((ParamType, ParamName, [ParamValue]), SomeException)] class RequestReader m where getRawRequest :: m RawRequest invalidParams :: ParamException -> m a -instance RequestReader Request where - getRawRequest = Request $ Right - invalidParams = Request . const . Left - -runRequest :: (Monad m, RequestReader m) => Request a -> m a -runRequest (Request f) = do - rr <- getRawRequest - either invalidParams return $ f rr - --- | Helper function for generating 'RequestParser's from various --- 'ParamValue' lists. -genParam :: Parameter a - => (RawRequest -> ParamName -> [ParamValue]) - -> ParamType - -> ParamName - -> Request a -genParam f ptype name = Request helper where - helper req = attempt failureH Right $ readParams pvs where - pvs = f req name - failureH e = Left [((ptype, name, pvs), SomeException e)] - --- | Parse a value passed as a GET parameter. -getParam :: (Parameter a) => ParamName -> Request a -getParam = genParam getParams GetParam - --- | Parse a value passed as a POST parameter. -postParam :: (Parameter a) => ParamName -> Request a -postParam = genParam postParams PostParam languages :: (Functor m, RequestReader m) => m [Language] languages = rawLangs `fmap` getRawRequest @@ -164,17 +126,6 @@ instance ConvertSuccess Hack.Env RawRequest where #if TEST testSuite :: Test testSuite = testGroup "Yesod.Request" - [ testCase "Request applicative instance" caseAppInst + [ ] - -caseAppInst :: Assertion -caseAppInst = do - let r5 = Request $ const $ Right (5 :: Int) - rAdd2 = Request $ const $ Right (+ 2) - r7 = Request $ const $ Right (7 :: Int) - rr = undefined - myEquals e t = (unRequest e) rr `myEquals2` (unRequest t) rr - myEquals2 x y = show x @=? show y - r5 `myEquals` pure (5 :: Int) - r7 `myEquals` (rAdd2 <*> r5) #endif diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 645babf5..d2bdbc3d 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -43,6 +43,7 @@ module Yesod.Response #if TEST -- * Tests , testSuite + , runContent #endif ) where diff --git a/yesod.cabal b/yesod.cabal index dc2fb2ba..65d2bc84 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -59,7 +59,6 @@ library Yesod.Response Yesod.Definitions Yesod.Handler - Yesod.Parameter Yesod.Resource Yesod.Yesod Yesod.Template From bfc9b224c0848706b9dd96d0250ab2b7d86657fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jan 2010 21:06:41 +0200 Subject: [PATCH 133/624] Removed all FIXMEs but Test.Errors and Yesod.Template --- Data/Object/Html.hs | 56 +++++++++++++++++++++++------------------ TODO | 5 ---- Test/Errors.hs | 9 +++---- Test/QuasiResource.hs | 38 ++++++++++++++++------------ Yesod/Handler.hs | 28 +++++++++++++-------- Yesod/Helpers/Auth.hs | 31 +++++++++++++++-------- Yesod/Helpers/Static.hs | 4 +-- Yesod/Request.hs | 2 +- Yesod/Response.hs | 3 +-- Yesod/Template.hs | 3 +-- Yesod/Yesod.hs | 24 ++++++++++++------ 11 files changed, 116 insertions(+), 87 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 32938049..369e4a23 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -4,7 +4,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -- | An 'Html' data type and associated 'ConvertSuccess' instances. This has -- useful conversions in web development: -- @@ -66,6 +65,17 @@ 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) + toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject toHtmlObject = cs @@ -78,11 +88,6 @@ instance ConvertSuccess TS.Text Html where convertSuccess = Text instance ConvertSuccess Text Html where convertSuccess = Text . cs -$(deriveAttempts - [ (''String, ''Html) - , (''Text, ''Html) - , (''TS.Text, ''Html) - ]) instance ConvertSuccess String HtmlObject where convertSuccess = Scalar . cs @@ -151,11 +156,19 @@ cdata h = HtmlList , Html $ cs "]]>" ] -instance ConvertSuccess Html HtmlDoc where - convertSuccess h = HtmlDoc $ TL.fromChunks $ - cs "\nHtmlDoc (autogenerated)" - : htmlToText False h - [cs ""] +instance ConvertSuccess (Html, Html) HtmlDoc where + convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $ + cs "\n" + : htmlToText False (Tag "html" [] $ HtmlList + [ Tag "head" [] h + , Tag "body" [] b + ] + ) [] +instance ConvertSuccess (HtmlObject, HtmlObject) HtmlDoc where + convertSuccess (x, y) = cs (cs' x :: Html, cs' y) where + cs' = cs +instance ConvertSuccess (HtmlObject, HtmlObject) JsonDoc where + convertSuccess (_, y) = cs y instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h @@ -169,25 +182,20 @@ instance ConvertSuccess HtmlObject Html where , Tag "dd" [] $ cs v ] -instance ConvertSuccess HtmlObject HtmlDoc where - convertSuccess = cs . (cs :: HtmlObject -> Html) - 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) - -$(deriveAttempts - [ (''Html, ''HtmlFragment) - , (''Html, ''HtmlDoc) - , (''Html, ''JsonScalar) - ]) - -$(deriveSuccessConvs ''String ''Html - [''String, ''Text] - [''Html, ''HtmlFragment]) +instance ConvertAttempt HtmlObject JsonDoc where + convertAttempt = return . cs instance ToSElem HtmlObject where toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h diff --git a/TODO b/TODO index a44ffdf5..6a6c07d0 100644 --- a/TODO +++ b/TODO @@ -1,6 +1 @@ -Some form of i18n. Cleanup Parameter stuff. Own module? Interface with formlets? -Authentication via e-mail address built in. (eaut.org) -OpenID 2 stuff (for direct Google login). -Languages (read languages header, set language cookie) -Approot and trailing slash missing diff --git a/Test/Errors.hs b/Test/Errors.hs index 0861a5de..ddb07346 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -9,7 +9,6 @@ import Data.List import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) -import Control.Applicative data Errors = Errors instance Yesod Errors where @@ -28,19 +27,19 @@ instance YesodAuth Errors denied :: Handler Errors () denied = permissionDenied -needsIdent :: Handler Errors HtmlObject +needsIdent :: Handler Errors (HtmlObject, HtmlObject) needsIdent = do i <- authIdentifier - return $ toHtmlObject i + return $ (toHtmlObject "", toHtmlObject i) -hasArgs :: Handler Errors HtmlObject +hasArgs :: Handler Errors (HtmlObject, HtmlObject) hasArgs = do {- FIXME wait for new request API (a, b) <- runRequest $ (,) <$> getParam "firstParam" <*> getParam "secondParam" -} let (a, b) = ("foo", "bar") - return $ toHtmlObject [a :: String, b] + return (toHtmlObject "", toHtmlObject [a :: String, b]) caseErrorMessages :: Assertion caseErrorMessages = do diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 43ac1495..4a4439d3 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -14,24 +14,30 @@ data MyYesod = MyYesod instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" -getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject -getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] -pageIndex :: Handler MyYesod HtmlObject -pageIndex = return $ toHtmlObject ["pageIndex"] +addHead' :: HtmlObject -> (HtmlObject, HtmlObject) +addHead' x = (cs "", x) + +addHead :: Monad m => HtmlObject -> m (HtmlObject, HtmlObject) +addHead = return . addHead' + +getStatic :: Verb -> [String] -> Handler MyYesod (HtmlObject, HtmlObject) +getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p] +pageIndex :: Handler MyYesod (HtmlObject, HtmlObject) +pageIndex = addHead $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod ChooseRep -pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] +pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"] pageDetail :: String -> Handler MyYesod ChooseRep -pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] -pageDelete :: String -> Handler MyYesod HtmlObject -pageDelete s = return $ toHtmlObject ["pageDelete", s] +pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s] +pageDelete :: String -> Handler MyYesod (HtmlObject, HtmlObject) +pageDelete s = addHead $ toHtmlObject ["pageDelete", s] pageUpdate :: String -> Handler MyYesod ChooseRep -pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] -userInfo :: Int -> Handler MyYesod HtmlObject -userInfo i = return $ toHtmlObject ["userInfo", show i] -userVariable :: Int -> String -> Handler MyYesod HtmlObject -userVariable i s = return $ toHtmlObject ["userVariable", show i, s] -userPage :: Int -> [String] -> Handler MyYesod HtmlObject -userPage i p = return $ toHtmlObject ["userPage", show i, show p] +pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s] +userInfo :: Int -> Handler MyYesod (HtmlObject, HtmlObject) +userInfo i = addHead $ toHtmlObject ["userInfo", show i] +userVariable :: Int -> String -> Handler MyYesod (HtmlObject, HtmlObject) +userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s] +userPage :: Int -> [String] -> Handler MyYesod (HtmlObject, HtmlObject) +userPage i p = addHead $ toHtmlObject ["userPage", show i, show p] instance Show (Verb -> Handler MyYesod ChooseRep) where show _ = "verb -> handler" @@ -57,7 +63,7 @@ handler = [$resources| ph :: [String] -> Handler MyYesod ChooseRep -> Assertion ph ss h = do - let eh = return . chooseRep . toHtmlObject . show + let eh = return . chooseRep . addHead' . toHtmlObject . show rr = error "No raw request" y = MyYesod cts = [TypeHtml] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index c1a6bb9d..68f7d32c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -101,23 +101,28 @@ runHandler :: Handler yesod ChooseRep -> [ContentType] -> IO Response runHandler (Handler handler) eh rr y tg cts = do + let toErrorHandler = + InternalError + . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch (handler (rr, y, tg)) - (\e -> return ([], HCError $ InternalError $ show - (e :: Control.Exception.SomeException))) - case contents of - HCError e -> do + (\e -> return ([], HCError $ toErrorHandler e)) + let handleError e = do Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c + let sendFile' ct fp = do + -- avoid lazy I/O by switching to WAI + c <- BL.readFile fp + return $ Response 200 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) -> do - -- FIXME do error handling on this, or leave it to the app? - -- FIXME avoid lazy I/O by switching to WAI - c <- BL.readFile fp - return $ Response 200 headers ct $ cs c + HCSpecial (SendFile ct fp) -> Control.Exception.catch + (sendFile' ct fp) + (handleError . toErrorHandler) HCContent a -> do (ct, c) <- a cts return $ Response 200 headers ct c @@ -125,7 +130,10 @@ runHandler (Handler handler) eh rr y tg cts = do safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ chooseRep $ toHtmlObject "Internal server error" + return $ chooseRep $ + ( toHtmlObject $ Tag "title" [] $ cs "Internal Server Error" + , toHtmlObject "Internal server error" + ) ------ Special handlers specialResponse :: SpecialResponse -> Handler yesod a diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 332185ae..9fcefe62 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -105,7 +105,7 @@ getParam :: (Monad m, RequestReader m) -> m ParamValue getParam = someParam GetParam getParams -authOpenidForm :: Handler y HtmlObject +authOpenidForm :: Handler y (HtmlObject, HtmlObject) authOpenidForm = do rr <- getRawRequest case getParams rr "dest" of @@ -124,9 +124,9 @@ authOpenidForm = do , EmptyTag "input" [("type", "submit"), ("value", "Login")] ] ] - return $ cs html + return $ (justTitle "Log in via OpenID", cs html) -authOpenidForward :: YesodAuth y => Handler y HtmlObject +authOpenidForward :: YesodAuth y => Handler y () authOpenidForward = do oid <- getParam "openid" authroot <- getFullAuthRoot @@ -138,7 +138,7 @@ authOpenidForward = do (redirect RedirectTemporary) res -authOpenidComplete :: YesodApproot y => Handler y HtmlObject +authOpenidComplete :: YesodApproot y => Handler y () authOpenidComplete = do ar <- getApproot rr <- getRawRequest @@ -156,7 +156,7 @@ authOpenidComplete = do redirect RedirectTemporary dest attempt onFailure onSuccess res -rpxnowLogin :: YesodAuth y => Handler y HtmlObject +rpxnowLogin :: YesodAuth y => Handler y () rpxnowLogin = do ay <- getYesod let ar = approot ay @@ -192,21 +192,30 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y -authCheck :: Handler y HtmlObject +-- FIXME use templates for all of the following + +justTitle :: String -> HtmlObject +justTitle = cs . Tag "title" [] . cs + +authCheck :: Handler y (HtmlObject, HtmlObject) authCheck = do ident <- maybeIdentifier dn <- displayName - return $ toHtmlObject + return $ (justTitle "Authentication Status", toHtmlObject [ ("identifier", fromMaybe "" ident) , ("displayName", fromMaybe "" dn) - ] + ]) -authLogout :: YesodAuth y => Handler y HtmlObject +authLogout :: YesodAuth y => Handler y () authLogout = do deleteCookie authCookieName + rr <- getRawRequest ar <- getApproot - redirect RedirectTemporary ar - -- FIXME check the DEST information + let dest = case cookies rr "DEST" of + [] -> ar + (x:_) -> x + deleteCookie "DEST" + redirect RedirectTemporary dest -- | Gets the identifier for a user if available. maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 83a98fc0..647ae240 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -22,15 +22,13 @@ module Yesod.Helpers.Static , fileLookupDir ) where -import qualified Data.ByteString.Lazy as B import System.Directory (doesFileExist) import Control.Monad import Yesod import Data.List (intercalate) --- FIXME this type is getting ugly... -type FileLookup = FilePath -> IO (Maybe (Either FilePath B.ByteString)) +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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index cbe02d6f..6b730a55 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -74,7 +74,7 @@ parseEnv = rawEnv `fmap` getRawRequest data RawRequest = RawRequest { rawGetParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] - -- FIXME when we switch to WAI, the following two should be combined and + -- when we switch to WAI, the following two should be combined and -- wrapped in the IO monad , rawPostParams :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index d2bdbc3d..23a27fb1 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -124,8 +124,7 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" --- FIXME remove this instance? only good for debugging, maybe special debugging newtype? -instance HasReps HtmlObject where +instance HasReps (HtmlObject, HtmlObject) where chooseRep = defChooseRep [ (TypeHtml, return . cs . unHtmlDoc . cs) , (TypeJson, return . cs . unJsonDoc . cs) diff --git a/Yesod/Template.hs b/Yesod/Template.hs index b145d95d..a13db2fa 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -1,3 +1,4 @@ +-- FIXME this whole module needs to be rethought {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Template @@ -24,7 +25,6 @@ type TemplateGroup = STGroup Text class HasTemplateGroup a where getTemplateGroup :: a TemplateGroup --- FIXME better home template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) => String -- ^ template name -> String -- ^ object name @@ -58,7 +58,6 @@ instance HasReps Template where return $ cs $ unJsonDoc $ cs ho) ] --- FIXME data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where chooseRep = defChooseRep [ (TypeHtml, diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index e77e7864..f6cb4bf2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -6,7 +6,7 @@ module Yesod.Yesod , toHackApp ) where -import Data.Object.Html (toHtmlObject) +import Data.Object.Html import Yesod.Response import Yesod.Request import Yesod.Definitions @@ -14,7 +14,6 @@ import Yesod.Handler import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) -import Data.Convertible.Text import Text.StringTemplate import Web.Mime import Web.Encodings (parseHttpAccept) @@ -55,23 +54,32 @@ class Yesod a => YesodApproot a where getApproot :: YesodApproot y => Handler y Approot getApproot = approot `fmap` getYesod +justTitle :: String -> HtmlObject +justTitle = cs . Tag "title" [] . cs + defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do rr <- getRawRequest - return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr + return $ chooseRep + ( justTitle "Not Found" + , toHtmlObject [("Not found", show rr)] + ) defaultErrorHandler PermissionDenied = - return $ chooseRep $ toHtmlObject "Permission denied" + return $ chooseRep + ( justTitle "Permission Denied" + , toHtmlObject "Permission denied" + ) defaultErrorHandler (InvalidArgs ia) = - return $ chooseRep $ toHtmlObject + return $ chooseRep (justTitle "Invalid Arguments", toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) - ] + ]) defaultErrorHandler (InternalError e) = - return $ chooseRep $ toHtmlObject + return $ chooseRep (justTitle "Internal Server Error", toHtmlObject [ ("Internal server error", e) - ] + ]) toHackApp :: Yesod y => y -> IO Hack.Application toHackApp a = do From 1ff54a574a9e8e652196b48062497a57d4581806 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 27 Jan 2010 09:11:23 +0200 Subject: [PATCH 134/624] applyLayout added to Yesod --- Data/Object/Html.hs | 7 +++--- Test/Errors.hs | 8 +++--- Test/QuasiResource.hs | 16 ++++++------ Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 18 ++++++-------- Yesod/Response.hs | 2 +- Yesod/Yesod.hs | 57 +++++++++++++++++++++++++++++++------------ 7 files changed, 65 insertions(+), 45 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 369e4a23..7964db92 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -164,10 +164,9 @@ instance ConvertSuccess (Html, Html) HtmlDoc where , Tag "body" [] b ] ) [] -instance ConvertSuccess (HtmlObject, HtmlObject) HtmlDoc where - convertSuccess (x, y) = cs (cs' x :: Html, cs' y) where - cs' = cs -instance ConvertSuccess (HtmlObject, HtmlObject) JsonDoc where +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 diff --git a/Test/Errors.hs b/Test/Errors.hs index ddb07346..9f694b51 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -27,19 +27,19 @@ instance YesodAuth Errors denied :: Handler Errors () denied = permissionDenied -needsIdent :: Handler Errors (HtmlObject, HtmlObject) +needsIdent :: Handler Errors (Html, HtmlObject) needsIdent = do i <- authIdentifier - return $ (toHtmlObject "", toHtmlObject i) + return $ (cs "", cs i) -hasArgs :: Handler Errors (HtmlObject, HtmlObject) +hasArgs :: Handler Errors (Html, HtmlObject) hasArgs = do {- FIXME wait for new request API (a, b) <- runRequest $ (,) <$> getParam "firstParam" <*> getParam "secondParam" -} let (a, b) = ("foo", "bar") - return (toHtmlObject "", toHtmlObject [a :: String, b]) + return (cs "", cs [a :: String, b]) caseErrorMessages :: Assertion caseErrorMessages = do diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 4a4439d3..c8424fbb 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -14,29 +14,29 @@ data MyYesod = MyYesod instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" -addHead' :: HtmlObject -> (HtmlObject, HtmlObject) +addHead' :: HtmlObject -> (Html, HtmlObject) addHead' x = (cs "", x) -addHead :: Monad m => HtmlObject -> m (HtmlObject, HtmlObject) +addHead :: Monad m => HtmlObject -> m (Html, HtmlObject) addHead = return . addHead' -getStatic :: Verb -> [String] -> Handler MyYesod (HtmlObject, HtmlObject) +getStatic :: Verb -> [String] -> Handler MyYesod (Html, HtmlObject) getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p] -pageIndex :: Handler MyYesod (HtmlObject, HtmlObject) +pageIndex :: Handler MyYesod (Html, HtmlObject) pageIndex = addHead $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod ChooseRep pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"] pageDetail :: String -> Handler MyYesod ChooseRep pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s] -pageDelete :: String -> Handler MyYesod (HtmlObject, HtmlObject) +pageDelete :: String -> Handler MyYesod (Html, HtmlObject) pageDelete s = addHead $ toHtmlObject ["pageDelete", s] pageUpdate :: String -> Handler MyYesod ChooseRep pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s] -userInfo :: Int -> Handler MyYesod (HtmlObject, HtmlObject) +userInfo :: Int -> Handler MyYesod (Html, HtmlObject) userInfo i = addHead $ toHtmlObject ["userInfo", show i] -userVariable :: Int -> String -> Handler MyYesod (HtmlObject, HtmlObject) +userVariable :: Int -> String -> Handler MyYesod (Html, HtmlObject) userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s] -userPage :: Int -> [String] -> Handler MyYesod (HtmlObject, HtmlObject) +userPage :: Int -> [String] -> Handler MyYesod (Html, HtmlObject) userPage i p = addHead $ toHtmlObject ["userPage", show i, show p] instance Show (Verb -> Handler MyYesod ChooseRep) where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 68f7d32c..6078e2c1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -131,7 +131,7 @@ safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ - ( toHtmlObject $ Tag "title" [] $ cs "Internal Server Error" + ( Tag "title" [] $ cs "Internal Server Error" , toHtmlObject "Internal server error" ) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 9fcefe62..f7d42eb0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -68,7 +68,8 @@ data AuthResource = rc :: HasReps x => Handler y x -> Handler y ChooseRep rc = fmap chooseRep -authHandler :: YesodAuth y => Verb -> [String] -> Handler y ChooseRep +authHandler :: YesodAuth y => + Verb -> [String] -> Handler y ChooseRep authHandler Get ["check"] = rc authCheck authHandler Get ["logout"] = rc authLogout authHandler Get ["openid"] = rc authOpenidForm @@ -105,7 +106,7 @@ getParam :: (Monad m, RequestReader m) -> m ParamValue getParam = someParam GetParam getParams -authOpenidForm :: Handler y (HtmlObject, HtmlObject) +authOpenidForm :: Yesod y => Handler y ChooseRep authOpenidForm = do rr <- getRawRequest case getParams rr "dest" of @@ -124,7 +125,7 @@ authOpenidForm = do , EmptyTag "input" [("type", "submit"), ("value", "Login")] ] ] - return $ (justTitle "Log in via OpenID", cs html) + applyLayout' "Log in via OpenID" html authOpenidForward :: YesodAuth y => Handler y () authOpenidForward = do @@ -192,19 +193,14 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y --- FIXME use templates for all of the following - -justTitle :: String -> HtmlObject -justTitle = cs . Tag "title" [] . cs - -authCheck :: Handler y (HtmlObject, HtmlObject) +authCheck :: Yesod y => Handler y ChooseRep authCheck = do ident <- maybeIdentifier dn <- displayName - return $ (justTitle "Authentication Status", toHtmlObject + applyLayoutJson "Authentication Status" $ cs [ ("identifier", fromMaybe "" ident) , ("displayName", fromMaybe "" dn) - ]) + ] authLogout :: YesodAuth y => Handler y () authLogout = do diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 23a27fb1..a1106eee 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -124,7 +124,7 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" -instance HasReps (HtmlObject, HtmlObject) where +instance HasReps (Html, HtmlObject) where chooseRep = defChooseRep [ (TypeHtml, return . cs . unHtmlDoc . cs) , (TypeJson, return . cs . unJsonDoc . cs) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f6cb4bf2..da6ae794 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -2,11 +2,14 @@ module Yesod.Yesod ( Yesod (..) , YesodApproot (..) + , applyLayout' + , applyLayoutJson , getApproot , toHackApp ) where import Data.Object.Html +import Data.Object.Json (unJsonDoc) import Yesod.Response import Yesod.Request import Yesod.Definitions @@ -47,39 +50,61 @@ class Yesod a where templateDir :: a -> FilePath templateDir _ = "" + -- | Applies some form of layout to and <body> contents of a page. + applyLayout :: a + -> String -- ^ title + -> Html -- ^ body + -> Content + applyLayout _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc) + 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 + return $ chooseRep + [ (TypeHtml, applyLayout y 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 + return $ chooseRep + [ (TypeJson, cs $ unJsonDoc $ cs b) + , (TypeHtml, applyLayout y t $ cs b) + ] + getApproot :: YesodApproot y => Handler y Approot getApproot = approot `fmap` getYesod -justTitle :: String -> HtmlObject -justTitle = cs . Tag "title" [] . cs - defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do rr <- getRawRequest - return $ chooseRep - ( justTitle "Not Found" - , toHtmlObject [("Not found", show rr)] - ) + applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", show rr)] defaultErrorHandler PermissionDenied = - return $ chooseRep - ( justTitle "Permission Denied" - , toHtmlObject "Permission denied" - ) + applyLayout' "Permission Denied" $ cs "Permission denied" defaultErrorHandler (InvalidArgs ia) = - return $ chooseRep (justTitle "Invalid Arguments", toHtmlObject + applyLayout' "Invalid Arguments" $ cs $ toHtmlObject [ ("errorMsg", toHtmlObject "Invalid arguments") , ("messages", toHtmlObject ia) - ]) + ] defaultErrorHandler (InternalError e) = - return $ chooseRep (justTitle "Internal Server Error", toHtmlObject - [ ("Internal server error", e) - ]) + applyLayout' "Internal Server Error" $ cs $ toHtmlObject + [ ("Internal server error", e) + ] toHackApp :: Yesod y => y -> IO Hack.Application toHackApp a = do From 097561b7aa015acd83869aa7a4404fe21402b103 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Jan 2010 09:32:58 +0200 Subject: [PATCH 135/624] Moved all StringTemplate support to own module --- Test/QuasiResource.hs | 3 +- Yesod/Handler.hs | 20 ++++++------- Yesod/Template.hs | 70 ++++++++++++++++++------------------------- Yesod/Yesod.hs | 22 +++----------- 4 files changed, 43 insertions(+), 72 deletions(-) diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index c8424fbb..8e7908b1 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -4,7 +4,6 @@ module Test.QuasiResource (testSuite) where import Yesod -import Text.StringTemplate (nullGroup) import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) @@ -67,7 +66,7 @@ ph ss h = do rr = error "No raw request" y = MyYesod cts = [TypeHtml] - res <- runHandler h eh rr y nullGroup cts + res <- runHandler h eh rr y cts res' <- myShow res mapM_ (helper res') ss where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6078e2c1..46ad998f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -38,7 +38,6 @@ module Yesod.Handler import Yesod.Request import Yesod.Response -import Yesod.Template import Web.Mime import Control.Exception hiding (Handler) @@ -52,9 +51,11 @@ import System.IO import Data.Object.Html import qualified Data.ByteString.Lazy as BL +data HandlerData yesod = HandlerData RawRequest yesod + ------ Handler monad newtype Handler yesod a = Handler { - unHandler :: (RawRequest, yesod, TemplateGroup) + unHandler :: HandlerData yesod -> IO ([Header], HandlerContents a) } data HandlerContents a = @@ -83,32 +84,29 @@ instance MonadIO (Handler yesod) where instance Exception e => Failure e (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e) instance RequestReader (Handler yesod) where - getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) + getRawRequest = Handler $ \(HandlerData rr _) + -> return ([], HCContent rr) invalidParams = invalidArgs . map helper where helper ((_pt, pn, _pvs), e) = (pn, show e) getYesod :: Handler yesod yesod -getYesod = Handler $ \(_, yesod, _) -> return ([], HCContent yesod) - -instance HasTemplateGroup (Handler yesod) where - getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) +getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod) runHandler :: Handler yesod ChooseRep -> (ErrorResponse -> Handler yesod ChooseRep) -> RawRequest -> yesod - -> TemplateGroup -> [ContentType] -> IO Response -runHandler (Handler handler) eh rr y tg cts = do +runHandler handler eh rr y cts = do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (handler (rr, y, tg)) + (unHandler handler $ HandlerData rr y) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts + 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 diff --git a/Yesod/Template.hs b/Yesod/Template.hs index a13db2fa..e52c8dfb 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -1,71 +1,59 @@ --- FIXME this whole module needs to be rethought {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Yesod.Template - ( HasTemplateGroup (..) + ( YesodTemplate (..) , template , NoSuchTemplate + , Template , TemplateGroup - , Template (..) - , TemplateFile (..) ) where import Data.Object.Html import Data.Typeable (Typeable) import Control.Exception (Exception) -import Control.Failure import Data.Object.Text (Text) import Text.StringTemplate import Data.Object.Json import Web.Mime import Yesod.Response +import Yesod.Yesod +import Yesod.Handler +import Control.Monad (foldM) +import Data.ByteString.Lazy (toChunks) +type Template = StringTemplate Text type TemplateGroup = STGroup Text -class HasTemplateGroup a where - getTemplateGroup :: a TemplateGroup +class Yesod y => YesodTemplate y where + getTemplateGroup :: y -> TemplateGroup -template :: (MonadFailure NoSuchTemplate t, HasTemplateGroup t) +getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup +getTemplateGroup' = getTemplateGroup `fmap` getYesod + +template :: YesodTemplate y => String -- ^ template name - -> String -- ^ object name -> HtmlObject -- ^ object - -> IO [(String, HtmlObject)] -- ^ template attributes - -> t Template -template tn on o attrs = do - tg <- getTemplateGroup + -> (HtmlObject -> Template -> IO Template) + -> Handler y ChooseRep +template tn ho f = do + tg <- getTemplateGroup' t <- case getStringTemplate tn tg of Nothing -> failure $ NoSuchTemplate tn Just x -> return x - return $ Template t on o attrs + return $ chooseRep + [ (TypeJson, cs $ unJsonDoc $ cs ho) + , (TypeHtml, tempToContent t ho f) + ] newtype NoSuchTemplate = NoSuchTemplate String deriving (Show, Typeable) instance Exception NoSuchTemplate -data Template = Template (StringTemplate Text) - String - HtmlObject - (IO [(String, HtmlObject)]) -instance HasReps Template where - chooseRep = defChooseRep [ (TypeHtml, - \(Template t name ho attrsIO) -> do - attrs <- attrsIO - return - $ cs - $ render - $ setAttribute name ho - $ setManyAttrib attrs t) - , (TypeJson, \(Template _ _ ho _) -> - return $ cs $ unJsonDoc $ cs ho) - ] +tempToContent :: Template + -> HtmlObject + -> (HtmlObject -> Template -> IO Template) + -> Content +tempToContent t ho f = ioTextToContent $ fmap render $ f ho t -data TemplateFile = TemplateFile FilePath HtmlObject -instance HasReps TemplateFile where - chooseRep = defChooseRep [ (TypeHtml, - \(TemplateFile fp h) -> do - contents <- readFile fp - let t = newSTMP contents - return $ cs $ toString $ setAttribute "o" h t - ) - , (TypeJson, \(TemplateFile _ ho) -> - return $ cs $ unJsonDoc $ cs ho) - ] +ioTextToContent :: IO Text -> Content +ioTextToContent iotext = Content $ \f a -> iotext >>= \t -> + foldM f a $ toChunks $ cs t diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index da6ae794..9c8c9713 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -14,10 +14,8 @@ import Yesod.Response import Yesod.Request import Yesod.Definitions import Yesod.Handler -import Yesod.Template (TemplateGroup) import Data.Maybe (fromMaybe) -import Text.StringTemplate import Web.Mime import Web.Encodings (parseHttpAccept) @@ -46,10 +44,6 @@ class Yesod a where errorHandler :: ErrorResponse -> Handler a ChooseRep errorHandler = defaultErrorHandler - -- | The template directory. Blank means no templates. - templateDir :: a -> FilePath - templateDir _ = "" - -- | Applies some form of layout to <title> and <body> contents of a page. applyLayout :: a -> String -- ^ title @@ -109,7 +103,7 @@ defaultErrorHandler (InternalError e) = toHackApp :: Yesod y => y -> IO Hack.Application toHackApp a = do key <- encryptKey a - app' <- toHackApp' a + let app' = toHackApp' a let mins = clientSessionDuration a return $ gzip $ cleanPath @@ -118,22 +112,14 @@ toHackApp a = do $ clientsession encryptedCookies key mins $ app' -toHackApp' :: Yesod y => y -> IO Hack.Application -toHackApp' y = do - let td = templateDir y - tg <- if null td - then return nullGroup - else directoryGroupRecursiveLazy td - return $ toHackApp'' y tg - -toHackApp'' :: Yesod y => y -> TemplateGroup -> Hack.Env -> IO Hack.Response -toHackApp'' y tg env = do +toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response +toHackApp' y env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env verb = cs $ Hack.requestMethod env handler = handlers resource verb rr = cs env - res <- runHandler handler errorHandler rr y tg types + res <- runHandler handler errorHandler rr y types responseToHackResponse res httpAccept :: Hack.Env -> [ContentType] From d1618eb3d086e04eb4a2e7e0131d5fad04c0eba0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Jan 2010 09:40:39 +0200 Subject: [PATCH 136/624] hlint applied --- Data/Object/Html.hs | 19 +++++++++---------- Test/Errors.hs | 2 +- Yesod/Handler.hs | 2 +- Yesod/Helpers/Static.hs | 2 +- Yesod/Resource.hs | 4 ++-- Yesod/Template.hs | 4 ++-- Yesod/Yesod.hs | 2 +- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs index 7964db92..720280c0 100644 --- a/Data/Object/Html.hs +++ b/Data/Object/Html.hs @@ -109,7 +109,7 @@ instance ConvertSuccess [(TS.Text, TS.Text)] HtmlObject where convertSuccess = omTO showAttribs :: [(String, String)] -> String -> String -showAttribs pairs rest = foldr ($) rest $ map helper pairs where +showAttribs pairs rest = foldr (($) . helper) rest pairs where helper :: (String, String) -> String -> String helper (k, v) rest' = ' ' : encodeHtml k @@ -122,18 +122,17 @@ htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML 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 ('<' : 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 ">")) + cs ('<' : n ) + : cs (showAttribs as (if xml then "/>" else ">")) : rest -htmlToText xml (HtmlList l) = \rest -> - foldr ($) rest $ map (htmlToText xml) l +htmlToText xml (HtmlList l) = flip (foldr ($)) (map (htmlToText xml) l) newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text } instance ConvertSuccess Html HtmlFragment where @@ -173,7 +172,7 @@ instance ConvertSuccess HtmlObject Html where convertSuccess (Scalar h) = h convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs where - addLi h = Tag "li" [] $ cs h + addLi = Tag "li" [] . cs convertSuccess (Mapping pairs) = Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where addDtDd (k, v) = diff --git a/Test/Errors.hs b/Test/Errors.hs index 9f694b51..ba258cb2 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -30,7 +30,7 @@ denied = permissionDenied needsIdent :: Handler Errors (Html, HtmlObject) needsIdent = do i <- authIdentifier - return $ (cs "", cs i) + return (cs "", cs i) hasArgs :: Handler Errors (Html, HtmlObject) hasArgs = do diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 46ad998f..ead51ba9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -128,7 +128,7 @@ runHandler handler eh rr y cts = do safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ chooseRep $ + return $ chooseRep ( Tag "title" [] $ cs "Internal Server Error" , toHtmlObject "Internal server error" ) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 647ae240..02ccb14d 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -51,7 +51,7 @@ serveStatic _ _ _ = notFound getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] getStatic fl fp' = do - when (any isUnsafe fp') $ notFound + when (any isUnsafe fp') notFound let fp = intercalate "/" fp' content <- liftIO $ fl fp case content of diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 8fa4b9e2..9af5834d 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -47,7 +47,7 @@ import Data.Typeable import Control.Exception (Exception) import Data.Attempt -- for failure stuff import Data.Object.Text -import Control.Monad ((<=<), unless) +import Control.Monad ((<=<), unless, zipWithM) import Data.Object.Yaml import Yesod.Handler import Data.Maybe (fromJust) @@ -152,7 +152,7 @@ doPatternPiecesMatch rp r let Slurp slurpKey = last rp return $ (slurpKey, SlurpParam r2) : smap | length rp /= length r = failure NoMatch - | otherwise = concat `fmap` sequence (zipWith doesPatternPieceMatch rp r) + | otherwise = concat `fmap` zipWithM doesPatternPieceMatch rp r data NoMatch = NoMatch doesPatternPieceMatch :: MonadFailure NoMatch m diff --git a/Yesod/Template.hs b/Yesod/Template.hs index e52c8dfb..d4352fc3 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -55,5 +55,5 @@ tempToContent :: Template tempToContent t ho f = ioTextToContent $ fmap render $ f ho t ioTextToContent :: IO Text -> Content -ioTextToContent iotext = Content $ \f a -> iotext >>= \t -> - foldM f a $ toChunks $ cs t +ioTextToContent iotext = + Content $ \f a -> iotext >>= foldM f a . toChunks . cs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9c8c9713..657751fe 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -110,7 +110,7 @@ toHackApp a = do $ jsonp $ methodOverride $ clientsession encryptedCookies key mins - $ app' + app' toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response toHackApp' y env = do From 43c847ff933125a37d4ff0152bea5b0e6159c00c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Jan 2010 10:05:29 +0200 Subject: [PATCH 137/624] handlers -> resources, resources -> mkResources, fix examples --- Test/Errors.hs | 2 +- Test/QuasiResource.hs | 2 +- Yesod/Resource.hs | 12 ++++++------ Yesod/Template.hs | 14 ++++++++++++++ Yesod/Yesod.hs | 4 ++-- compile-examples.sh | 6 ++++++ examples/fact.lhs | 11 +++++++---- examples/hellotemplate.lhs | 14 ++++++++------ examples/helloworld.lhs | 6 +++--- examples/i18n.hs | 2 +- 10 files changed, 49 insertions(+), 24 deletions(-) create mode 100755 compile-examples.sh diff --git a/Test/Errors.hs b/Test/Errors.hs index ba258cb2..7f153d17 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -12,7 +12,7 @@ import Test.HUnit hiding (Test) data Errors = Errors instance Yesod Errors where - handlers = [$resources| + resources = [$mkResources| /denied: Get: denied /needs-ident: diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 8e7908b1..97dbc3fd 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -43,7 +43,7 @@ instance Show (Verb -> Handler MyYesod ChooseRep) where instance Show (Resource -> Verb -> Handler MyYesod ChooseRep) where show _ = "resource -> verb -> handler" handler :: Resource -> Verb -> Handler MyYesod ChooseRep -handler = [$resources| +handler = [$mkResources| /static/*filepath/: getStatic /page/: Get: pageIndex diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 9af5834d..7d79e192 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -23,8 +23,8 @@ -- --------------------------------------------------------- module Yesod.Resource - ( resources - , resourcesNoCheck + ( mkResources + , mkResourcesNoCheck #if TEST -- * Testing , testSuite @@ -64,11 +64,11 @@ import Test.QuickCheck import Control.Monad (when) #endif -resources :: QuasiQuoter -resources = QuasiQuoter (strToExp True) undefined +mkResources :: QuasiQuoter +mkResources = QuasiQuoter (strToExp True) undefined -resourcesNoCheck :: QuasiQuoter -resourcesNoCheck = QuasiQuoter (strToExp False) undefined +mkResourcesNoCheck :: QuasiQuoter +mkResourcesNoCheck = QuasiQuoter (strToExp False) undefined -- | Resource Pattern Piece data RPP = diff --git a/Yesod/Template.hs b/Yesod/Template.hs index d4352fc3..41b0aaa0 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -6,6 +6,9 @@ module Yesod.Template , NoSuchTemplate , Template , TemplateGroup + , TemplateFile (..) + , setAttribute + , loadTemplateGroup ) where import Data.Object.Html @@ -57,3 +60,14 @@ tempToContent t ho f = ioTextToContent $ fmap render $ f ho t ioTextToContent :: IO Text -> Content ioTextToContent iotext = Content $ \f a -> iotext >>= foldM f a . toChunks . cs + +data TemplateFile = TemplateFile FilePath HtmlObject +instance HasReps TemplateFile where + chooseRep (TemplateFile fp (Mapping m)) _ = do + t <- fmap newSTMP $ readFile fp + let t' = setManyAttrib m t :: Template + return (TypeHtml, cs $ render t') + chooseRep _ _ = error "Please fix type of TemplateFile" + +loadTemplateGroup :: FilePath -> IO TemplateGroup +loadTemplateGroup = directoryGroupRecursiveLazy diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 657751fe..33cd2aa0 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -29,7 +29,7 @@ import Hack.Middleware.MethodOverride class Yesod a where -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, -- see the examples/fact.lhs sample. - handlers :: Resource -> Verb -> Handler a ChooseRep + resources :: Resource -> Verb -> Handler a ChooseRep -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -117,7 +117,7 @@ toHackApp' y env = do let (Right resource) = splitPath $ Hack.pathInfo env types = httpAccept env verb = cs $ Hack.requestMethod env - handler = handlers resource verb + handler = resources resource verb rr = cs env res <- runHandler handler errorHandler rr y types responseToHackResponse res diff --git a/compile-examples.sh b/compile-examples.sh new file mode 100755 index 00000000..f037f0c4 --- /dev/null +++ b/compile-examples.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +for f in examples/*.*hs +do + ghc --make -Wall -Werror $f || exit +done diff --git a/examples/fact.lhs b/examples/fact.lhs index 87460d3a..7debce47 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -54,7 +54,7 @@ specify a single function which handles all verbs. (Note: a verb is just a request method.) \begin{code} - handlers = [$resources| + resources = [$mkResources| /: Get: index /#num: @@ -78,7 +78,7 @@ 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). -> fact i = return $ toHtmlObject +> fact i = applyLayoutJson "Factorial result" $ cs > [ ("input", show i) > , ("result", show $ product [1..fromIntegral i :: Integer]) > ] @@ -89,8 +89,11 @@ one piece of data. > factRedirect :: Handler y () > factRedirect = do -> i <- runRequest $ getParam "num" -> redirect RedirectPermanent $ "../" ++ i ++ "/" +> rr <- getRawRequest +> let i = case getParams rr "num" of -- FIXME +> [] -> "1" +> (x:_) -> x +> _ <- redirect RedirectPermanent $ "../" ++ i ++ "/" The following line would be unnecesary if we had a type signature on factRedirect. diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index b5ee0924..f03bcf4a 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -4,15 +4,16 @@ import Yesod import Hack.Handler.SimpleServer -data HelloWorld = HelloWorld +data HelloWorld = HelloWorld TemplateGroup +instance YesodTemplate HelloWorld where + getTemplateGroup (HelloWorld tg) = tg instance Yesod HelloWorld where - handlers = [$resources| + resources = [$mkResources| /: Get: helloWorld /groups: Get: helloGroup |] - templateDir _ = "examples" helloWorld :: Handler HelloWorld TemplateFile helloWorld = return $ TemplateFile "examples/template.html" $ cs @@ -20,11 +21,12 @@ helloWorld = return $ TemplateFile "examples/template.html" $ cs , ("content", "Hey look!! I'm <auto escaped>!") ] -helloGroup :: Handler y Template -helloGroup = template "real-template" "foo" (cs "bar") $ return [] +helloGroup :: YesodTemplate y => Handler y ChooseRep +helloGroup = template "real-template" (cs "bar") $ \ho -> + return . setAttribute "foo" ho main :: IO () main = do putStrLn "Running..." - toHackApp HelloWorld >>= run 3000 + loadTemplateGroup "examples" >>= toHackApp . HelloWorld >>= run 3000 \end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index 371e8a04..1fbd6f73 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -6,13 +6,13 @@ import Hack.Handler.SimpleServer data HelloWorld = HelloWorld instance Yesod HelloWorld where - handlers = [$resources| + resources = [$mkResources| /: Get: helloWorld |] -helloWorld :: Handler HelloWorld HtmlObject -helloWorld = return $ cs "Hello world!" +helloWorld :: Handler HelloWorld ChooseRep +helloWorld = applyLayout' "Hello World" $ cs "Hello world!" main :: IO () main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000 diff --git a/examples/i18n.hs b/examples/i18n.hs index e393ba2a..b98cd724 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -5,7 +5,7 @@ import Hack.Handler.SimpleServer data I18N = I18N instance Yesod I18N where - handlers = [$resources| + resources = [$mkResources| /: Get: homepage /set/$lang: From f1184a1f66079dec1bd4a7d9819eb00f1004211a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Jan 2010 13:19:27 +0200 Subject: [PATCH 138/624] Added ioTextToContent, fixed json/html order --- Yesod/Response.hs | 7 +++++++ Yesod/Template.hs | 10 ++-------- Yesod/Yesod.hs | 4 ++-- 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Yesod/Response.hs b/Yesod/Response.hs index a1106eee..d5e9abb9 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -24,6 +24,7 @@ module Yesod.Response , ChooseRep , HasReps (..) , defChooseRep + , ioTextToContent -- ** Convenience wrappers , staticRep -- * Response type @@ -90,6 +91,12 @@ instance ConvertSuccess XmlDoc Content where 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 iotext = + Content $ \f a -> iotext >>= foldM f a . toChunks . cs + -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep diff --git a/Yesod/Template.hs b/Yesod/Template.hs index 41b0aaa0..ee5f910e 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -21,8 +21,6 @@ import Web.Mime import Yesod.Response import Yesod.Yesod import Yesod.Handler -import Control.Monad (foldM) -import Data.ByteString.Lazy (toChunks) type Template = StringTemplate Text type TemplateGroup = STGroup Text @@ -44,8 +42,8 @@ template tn ho f = do Nothing -> failure $ NoSuchTemplate tn Just x -> return x return $ chooseRep - [ (TypeJson, cs $ unJsonDoc $ cs ho) - , (TypeHtml, tempToContent t ho f) + [ (TypeHtml, tempToContent t ho f) + , (TypeJson, cs $ unJsonDoc $ cs ho) ] newtype NoSuchTemplate = NoSuchTemplate String deriving (Show, Typeable) @@ -57,10 +55,6 @@ tempToContent :: Template -> Content tempToContent t ho f = ioTextToContent $ fmap render $ f ho t -ioTextToContent :: IO Text -> Content -ioTextToContent iotext = - Content $ \f a -> iotext >>= foldM f a . toChunks . cs - data TemplateFile = TemplateFile FilePath HtmlObject instance HasReps TemplateFile where chooseRep (TemplateFile fp (Mapping m)) _ = do diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 33cd2aa0..729af6a9 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -75,8 +75,8 @@ applyLayoutJson :: Yesod y applyLayoutJson t b = do y <- getYesod return $ chooseRep - [ (TypeJson, cs $ unJsonDoc $ cs b) - , (TypeHtml, applyLayout y t $ cs b) + [ (TypeHtml, applyLayout y t $ cs b) + , (TypeJson, cs $ unJsonDoc $ cs b) ] getApproot :: YesodApproot y => Handler y Approot From 7505d9a05416c0c3fe6f2660e60cb08de46bc5f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Jan 2010 22:00:40 +0200 Subject: [PATCH 139/624] onRpxnowLogin and better defaultLoginPath --- Yesod/Helpers/Auth.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f7d42eb0..3da13da2 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -44,12 +44,16 @@ class YesodApproot a => YesodAuth a where authRoot :: a -> String authRoot _ = "auth/" + -- | Absolute path to the default login path. defaultLoginPath :: a -> String - defaultLoginPath a = authRoot a ++ "openid/" + 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 @@ -176,6 +180,7 @@ rpxnowLogin = do (s:_) -> s (d:_) -> d ident <- Rpxnow.authenticate apiKey token + onRpxnowLogin ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirect RedirectTemporary dest @@ -241,7 +246,7 @@ authIdentifier = do let dest = ar ++ rp lp <- defaultLoginPath `fmap` getYesod addCookie 120 "DEST" dest - redirect RedirectTemporary $ ar ++ lp + redirect RedirectTemporary lp Just x -> return x -- | Determinge the path requested by the user (ie, the path info). This From 15712773a021e187d8246361654c32b7b9ee8882 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 31 Jan 2010 01:30:32 +0200 Subject: [PATCH 140/624] Initial port to wai and wai-extra --- Hack/Middleware/CleanPath.hs | 60 ---------------- Hack/Middleware/ClientSession.hs | 113 ------------------------------ Hack/Middleware/Gzip.hs | 44 ------------ Hack/Middleware/Jsonp.hs | 66 ----------------- Hack/Middleware/MethodOverride.hs | 38 ---------- Test/Errors.hs | 13 ++-- Web/Mime.hs | 8 +++ Yesod.hs | 2 +- Yesod/Definitions.hs | 16 +++-- Yesod/Handler.hs | 6 +- Yesod/Helpers/Auth.hs | 19 +++-- Yesod/Request.hs | 51 +++++++------- Yesod/Response.hs | 83 +++++++++++----------- Yesod/Yesod.hs | 59 +++++++++------- yesod.cabal | 10 +-- 15 files changed, 139 insertions(+), 449 deletions(-) delete mode 100644 Hack/Middleware/CleanPath.hs delete mode 100644 Hack/Middleware/ClientSession.hs delete mode 100644 Hack/Middleware/Gzip.hs delete mode 100644 Hack/Middleware/Jsonp.hs delete mode 100644 Hack/Middleware/MethodOverride.hs diff --git a/Hack/Middleware/CleanPath.hs b/Hack/Middleware/CleanPath.hs deleted file mode 100644 index 5afd2558..00000000 --- a/Hack/Middleware/CleanPath.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Hack.Middleware.CleanPath (cleanPath, splitPath) where - -import Hack -import qualified Data.ByteString.Lazy as BS -import Web.Encodings -import Data.List.Split - --- | Performs redirects as per 'splitPath'. -cleanPath :: Middleware -cleanPath app env = - case splitPath $ pathInfo env of - Left p -> do - -- include the query string if there - let suffix = - case queryString env of - "" -> "" - q@('?':_) -> q - q -> '?' : q - return $! Response 303 [("Location", p ++ suffix)] BS.empty - Right _ -> app env - --- | Given a certain requested path, return either a corrected path --- to redirect to or the tokenized path. --- --- This code corrects for the following issues: --- --- * It is missing a trailing slash, and there is no period after the --- last slash. --- --- * There are any doubled slashes. -splitPath :: String -> Either String [String] -splitPath s = - let corrected = ats $ rds s - in if corrected == s - then Right $ map decodeUrl $ filter (not . null) - $ splitOneOf "/" s - else Left corrected - --- | Remove double slashes -rds :: String -> String -rds [] = [] -rds [x] = [x] -rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - --- | Add a trailing slash if it is missing. Empty string is left alone. -ats :: String -> String -ats [] = [] -ats s = - if last s == '/' || dbs (reverse s) - then s - else s ++ "/" - --- | Is there a period before a slash here? -dbs :: String -> Bool -dbs ('/':_) = False -dbs ('.':_) = True -dbs (_:x) = dbs x -dbs [] = False diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs deleted file mode 100644 index 7f069c93..00000000 --- a/Hack/Middleware/ClientSession.hs +++ /dev/null @@ -1,113 +0,0 @@ -module Hack.Middleware.ClientSession - ( clientsession - -- * Generating keys - , Word256 - , defaultKeyFile - , getKey - , getDefaultKey - ) where - -import Prelude hiding (exp) -import Hack -import Web.Encodings -import Data.List (partition, intercalate) -import Data.Function.Predicate (is, isn't, equals) -import Data.Maybe (fromMaybe, mapMaybe) -import Web.ClientSession -import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime) -import Data.Time.LocalTime () -- Show instance of UTCTime -import Data.Time.Format (formatTime) -- Read instance of UTCTime -import System.Locale (defaultTimeLocale) -import Control.Monad (guard) - --- | Automatic encrypting and decrypting of client session data. --- --- Using the clientsession package, this middleware handles automatic --- encryption, decryption, checking, expiration and renewal of whichever --- cookies you ask it to. For example, if you tell it to deal with the --- cookie \"IDENTIFIER\", it will do the following: --- --- * When you specify an \"IDENTIFIER\" value in your 'Response', it will --- encrypt the value, along with the session expiration date and the --- REMOTE_HOST of the user. It will then be set as a cookie on the client. --- --- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will --- decrypt it and check both the expiration date and the REMOTE_HOST. If --- everything matches up, it will set the \"IDENTIFIER\" value in --- 'hackHeaders'. --- --- * If the client sent an \"IDENTIFIER\" and the application does not set --- a new value, this will reset the cookie to a new expiration date. This --- way, you do not have sessions timing out every 20 minutes. --- --- As far as security: clientsesion itself handles hashing and encrypting --- the data to make sure that the user can neither see not tamper with it. -clientsession :: [String] -- ^ list of cookies to intercept - -> Word256 -- ^ encryption key - -> Int -- ^ minutes to live - -> Middleware -clientsession cnames key minutesToLive app env = do - let initCookiesRaw :: String - initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env - nonCookies :: [(String, String)] - nonCookies = filter (fst `isn't` (== "Cookie")) $ http env - initCookies :: [(String, String)] - initCookies = decodeCookies initCookiesRaw - cookies, interceptCookies :: [(String, String)] - (interceptCookies, cookies) = partition (fst `is` (`elem` cnames)) - initCookies - cookiesRaw :: String - cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v) - cookies - remoteHost' :: String - remoteHost' = remoteHost env - now <- getCurrentTime - let convertedCookies = - mapMaybe (decodeCookie key now remoteHost') interceptCookies - let env' = env { http = ("Cookie", cookiesRaw) - : filter (fst `equals` "Cookie") (http env) - ++ nonCookies - , hackHeaders = hackHeaders env ++ convertedCookies - } - res <- app env' - let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames)) - $ headers res - let timeToLive :: Int - timeToLive = minutesToLive * 60 - let exp = fromIntegral timeToLive `addUTCTime` now - let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp - let oldCookies = filter (\(k, _) -> k `notElem` map fst interceptHeaders) convertedCookies - let newCookies = map (setCookie key exp formattedExp remoteHost') $ - oldCookies ++ interceptHeaders - let res' = res { headers = newCookies ++ headers' } - return res' - -setCookie :: Word256 - -> UTCTime -- ^ expiration time - -> String -- ^ formatted expiration time - -> String -- ^ remote host - -> (String, String) -> (String, String) -setCookie key exp fexp rhost (cname, cval) = - ("Set-Cookie", cname ++ "=" ++ val ++ "; path=/; expires=" ++ fexp) - where - val = encrypt key $ show $ Cookie exp rhost cval - -data Cookie = Cookie UTCTime String String deriving (Show, Read) -decodeCookie :: Word256 -- ^ key - -> UTCTime -- ^ current time - -> String -- ^ remote host field - -> (String, String) -- ^ cookie pair - -> Maybe (String, String) -decodeCookie key now rhost (cname, encrypted) = do - decrypted <- decrypt key encrypted - (Cookie exp rhost' val) <- mread decrypted - guard $ exp > now - guard $ rhost' == rhost - guard $ val /= "" - return (cname, val) - -mread :: (Monad m, Read a) => String -> m a -mread s = - case reads s of - [] -> fail $ "Reading of " ++ s ++ " failed" - ((x, _):_) -> return x diff --git a/Hack/Middleware/Gzip.hs b/Hack/Middleware/Gzip.hs deleted file mode 100644 index 3da4d1a8..00000000 --- a/Hack/Middleware/Gzip.hs +++ /dev/null @@ -1,44 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Hack.Middleware.Gzip --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Unstable --- Portability : portable --- --- Automatic gzip compression of responses. --- ---------------------------------------------------------- -module Hack.Middleware.Gzip (gzip) where - -import Hack -import Codec.Compression.GZip (compress) -import Data.Maybe (fromMaybe) -import Data.List.Split (splitOneOf) - --- | Use gzip to compress the body of the response. --- --- Analyzes the \"Accept-Encoding\" header from the client to determine --- if gzip is supported. --- --- Possible future enhancements: --- --- * Only compress if the response is above a certain size. --- --- * Add Content-Length. --- --- * I read somewhere that \"the beast\" (MSIE) can\'t support compression --- for Javascript files.. -gzip :: Middleware -gzip app env = do - res <- app env - let enc = fromMaybe [] $ splitOneOf "," `fmap` lookup "Accept-Encoding" - (http env) - if "gzip" `elem` enc - then return res - { body = compress $ body res - , headers = ("Content-Encoding", "gzip") : headers res - } - else return res diff --git a/Hack/Middleware/Jsonp.hs b/Hack/Middleware/Jsonp.hs deleted file mode 100644 index bf8d8803..00000000 --- a/Hack/Middleware/Jsonp.hs +++ /dev/null @@ -1,66 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Hack.Middleware.Jsonp --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Unstable --- Portability : portable --- --- Automatic wrapping of JSON responses to convert into JSONP. --- ---------------------------------------------------------- -module Hack.Middleware.Jsonp (jsonp) where - -import Hack -import Web.Encodings (decodeUrlPairs) -import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.Maybe (fromMaybe) -import Data.List (isInfixOf) - --- | Wrap json responses in a jsonp callback. --- --- Basically, if the user requested a \"text\/javascript\" and supplied a --- \"callback\" GET parameter, ask the application for an --- \"application/json\" response, then convern that into a JSONP response, --- having a content type of \"text\/javascript\" and calling the specified --- callback function. -jsonp :: Middleware -jsonp app env = do - let accept = fromMaybe "" $ lookup "Accept" $ http env - let gets = decodeUrlPairs $ queryString env - let callback :: Maybe String - callback = - if "text/javascript" `isInfixOf` accept - then lookup "callback" gets - else Nothing - let env' = - case callback of - Nothing -> env - Just _ -> env - { http = changeVal "Accept" - "application/json" - $ http env - } - res <- app env' - let ctype = fromMaybe "" $ lookup "Content-Type" $ headers res - case callback of - Nothing -> return res - Just c -> - case ctype of - "application/json" -> return $ res - { headers = changeVal "Content-Type" - "text/javascript" - $ headers res - , body = B8.concat - [ B8.pack c -- NOTE uses Latin-1 encoding. - , B8.singleton '(' - , body res - , B8.singleton ')' - ] - } - _ -> return res - -changeVal :: String -> String -> [(String, String)] -> [(String, String)] -changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old diff --git a/Hack/Middleware/MethodOverride.hs b/Hack/Middleware/MethodOverride.hs deleted file mode 100644 index a26de677..00000000 --- a/Hack/Middleware/MethodOverride.hs +++ /dev/null @@ -1,38 +0,0 @@ ---------------------------------------------------------- --- | --- Module : Hack.Middleware.MethodOverride --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Unstable --- Portability : portable --- --- Override the HTTP method based on either: --- The X-HTTP-Method-Override header. --- The _method_override GET parameter. --- ---------------------------------------------------------- -module Hack.Middleware.MethodOverride (methodOverride) where - -import Hack -import Web.Encodings (decodeUrlPairs) -import Data.Monoid (mappend) -import Data.Char - -methodOverride :: Middleware -methodOverride app env = do - let mo1 = lookup "X-HTTP-Method-Override" $ http env - gets = decodeUrlPairs $ queryString env - mo2 = lookup "_method_override" gets - cm = requestMethod env - app $ - case mo1 `mappend` mo2 of - Nothing -> env - Just nm -> env { requestMethod = safeRead cm $ map toUpper nm } - -safeRead :: Read a => a -> String -> a -safeRead d s = - case reads s of - ((x, _):_) -> x - [] -> d diff --git a/Test/Errors.hs b/Test/Errors.hs index 7f153d17..f673d839 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -3,12 +3,13 @@ module Test.Errors (testSuite) where import Yesod import Yesod.Helpers.Auth -import Hack +import Network.Wai import Data.Default import Data.List import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) +import qualified Data.ByteString.Char8 as B8 data Errors = Errors instance Yesod Errors where @@ -42,12 +43,14 @@ hasArgs = do return (cs "", cs [a :: String, b]) caseErrorMessages :: Assertion -caseErrorMessages = do - app <- toHackApp Errors - res <- app $ def { pathInfo = "/denied/" } +caseErrorMessages = do return () +{- FIXME + app <- toWaiApp Errors + res <- app $ def { pathInfo = B8.pack "/denied/" } assertBool "/denied/" $ "Permission denied" `isInfixOf` show res - res' <- app $ def { pathInfo = "/needs-ident/" } + res' <- app $ def { pathInfo = B8.pack "/needs-ident/" } assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' + -} {- FIXME this test is not yet ready res3 <- app $ def { pathInfo = "/has-args/" } assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 diff --git a/Web/Mime.hs b/Web/Mime.hs index 900daf7c..350b127d 100644 --- a/Web/Mime.hs +++ b/Web/Mime.hs @@ -3,12 +3,14 @@ -- | Generic MIME type module. Could be spun off into its own package. module Web.Mime ( ContentType (..) + , contentTypeFromBS , typeByExt , ext ) where import Data.Function (on) import Data.Convertible.Text +import Data.ByteString.Char8 (pack, ByteString, unpack) data ContentType = TypeHtml @@ -27,6 +29,9 @@ data ContentType = | 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" @@ -46,6 +51,9 @@ instance ConvertSuccess ContentType [Char] where 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 diff --git a/Yesod.hs b/Yesod.hs index 08425265..85335165 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -41,6 +41,6 @@ import Yesod.Request import Yesod.Yesod import Yesod.Definitions import Yesod.Handler -import Hack (Application) +import Network.Wai (Application) import Yesod.Template import Web.Mime diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index df82af52..1bcb1dea 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -28,12 +28,14 @@ module Yesod.Definitions , langKey ) where -import qualified Hack +import qualified Network.Wai as W import Data.Convertible.Text import Control.Exception (Exception) import Data.Typeable (Typeable) import Language.Haskell.TH.Syntax +import Data.ByteString.Char8 (pack, ByteString) +-- FIXME replace with Method? data Verb = Get | Put | Delete | Post deriving (Eq, Show, Enum, Bounded) instance Lift Verb where @@ -48,10 +50,10 @@ newtype InvalidVerb = InvalidVerb String deriving (Show, Typeable) instance Exception InvalidVerb -instance ConvertSuccess Hack.RequestMethod Verb where - convertSuccess Hack.PUT = Put - convertSuccess Hack.DELETE = Delete - convertSuccess Hack.POST = Post +instance ConvertSuccess W.Method Verb where + convertSuccess W.PUT = Put + convertSuccess W.DELETE = Delete + convertSuccess W.POST = Post convertSuccess _ = Get type Resource = [String] @@ -78,8 +80,8 @@ authCookieName = "IDENTIFIER" authDisplayName :: String authDisplayName = "DISPLAY_NAME" -encryptedCookies :: [String] -encryptedCookies = [authDisplayName, authCookieName] +encryptedCookies :: [ByteString] +encryptedCookies = [pack authDisplayName, pack authCookieName] langKey :: String langKey = "_LANG" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ead51ba9..9e6f5e14 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,7 @@ 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 RawRequest yesod @@ -110,9 +111,8 @@ runHandler handler eh rr y cts = do let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c let sendFile' ct fp = do - -- avoid lazy I/O by switching to WAI c <- BL.readFile fp - return $ Response 200 headers ct $ cs c + return $ Response W.Status200 headers ct $ cs c case contents of HCError e -> handleError e HCSpecial (Redirect rt loc) -> do @@ -123,7 +123,7 @@ runHandler handler eh rr y cts = do (handleError . toErrorHandler) HCContent a -> do (ct, c) <- a cts - return $ Response 200 headers ct c + return $ Response W.Status200 headers ct c safeEh :: ErrorResponse -> Handler yesod ChooseRep safeEh er = do diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 3da13da2..75f79602 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -29,9 +29,10 @@ 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 Hack +import qualified Network.Wai import Data.Typeable (Typeable) import Control.Exception (Exception, SomeException (..)) @@ -221,18 +222,14 @@ authLogout = do -- | Gets the identifier for a user if available. maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) maybeIdentifier = do - env <- parseEnv - case lookup authCookieName $ Hack.hackHeaders env of - Nothing -> return Nothing - Just x -> return (Just x) + rr <- getRawRequest + return $ fmap cs $ lookup (B8.pack authCookieName) $ rawSession rr -- | Gets the display name for a user if available. displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) displayName = do - env <- parseEnv - case lookup authDisplayName $ Hack.hackHeaders env of - Nothing -> return Nothing - Just x -> return (Just x) + rr <- getRawRequest + return $ fmap cs $ lookup (B8.pack authDisplayName) $ rawSession rr -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. @@ -254,11 +251,11 @@ authIdentifier = do requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath = do env <- parseEnv - let q = case Hack.queryString env of + let q = case B8.unpack $ Network.Wai.queryString env of "" -> "" q'@('?':_) -> q' q' -> '?' : q' - return $! dropSlash (Hack.pathInfo env) ++ q + return $! dropSlash (B8.unpack $ Network.Wai.pathInfo env) ++ q where dropSlash ('/':x) = x dropSlash x = x diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 6b730a55..1ef86487 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -26,8 +26,7 @@ module Yesod.Request , getParams , postParams , languages - -- * Building actual request - , Hack.RequestMethod (..) + , parseWaiRequest -- * Parameter , ParamType (..) , ParamName @@ -38,10 +37,12 @@ module Yesod.Request #endif ) where -import qualified Hack +import qualified Network.Wai as W +import qualified Network.Wai.Enumerator as WE 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 ((***)) @@ -50,8 +51,8 @@ import Data.Maybe (fromMaybe) #if TEST import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) +--import Test.Framework.Providers.HUnit +--import Test.HUnit hiding (Test) #endif data ParamType = GetParam | PostParam @@ -66,22 +67,22 @@ class RequestReader m where languages :: (Functor m, RequestReader m) => m [Language] languages = rawLangs `fmap` getRawRequest --- | Get the raw 'Hack.Env' value. -parseEnv :: (Functor m, RequestReader m) => m Hack.Env -parseEnv = rawEnv `fmap` getRawRequest +-- | Get the raw 'W.Env' value. +parseEnv :: (Functor m, RequestReader m) => m W.Request +parseEnv = rawRequest `fmap` getRawRequest --- | The raw information passed through Hack, cleaned up a bit. +-- | The raw information passed through W, cleaned up a bit. data RawRequest = RawRequest { rawGetParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] + , rawSession :: [(B.ByteString, B.ByteString)] -- when we switch to WAI, the following two should be combined and -- wrapped in the IO monad , rawPostParams :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] - , rawEnv :: Hack.Env + , rawRequest :: W.Request , rawLangs :: [Language] } - deriving Show -- | All GET paramater values with the given name. getParams :: RawRequest -> ParamName -> [ParamValue] @@ -101,27 +102,29 @@ postParams rr name = map snd cookies :: RawRequest -> ParamName -> [ParamValue] cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr -instance ConvertSuccess Hack.Env RawRequest where - convertSuccess env = - let gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env - ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env - convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c - (posts, files) = map (convertSuccess *** convertSuccess) *** +parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -> IO RawRequest +parseWaiRequest env session = do + let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env + let clength = maybe "0" cs $ lookup W.ReqContentLength + $ W.httpHeaders env + let ctype = maybe "" cs $ lookup W.ReqContentType $ W.httpHeaders env + let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c + inputLBS <- WE.toLBS $ W.requestBody env -- FIXME + let (posts, files) = map (convertSuccess *** convertSuccess) *** map (convertSuccess *** convertFileInfo) $ parsePost ctype clength - $ Hack.hackInput env - rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - acceptLang = lookup "Accept-Language" $ Hack.http env - langs = maybe [] parseHttpAccept acceptLang + inputLBS + rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env + cookies' = map (cs *** cs) $ decodeCookies rawCookie + acceptLang = lookup W.AcceptLanguage $ W.httpHeaders 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' - in RawRequest gets' cookies' posts files env langs'' + return $ RawRequest gets' cookies' session posts files env langs'' #if TEST testSuite :: Test diff --git a/Yesod/Response.hs b/Yesod/Response.hs index d5e9abb9..f3353651 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -39,8 +39,8 @@ module Yesod.Response -- * Header , Header (..) , headerToPair - -- * Converting to Hack values - , responseToHackResponse + -- * Converting to WAI values + , responseToWaiResponse #if TEST -- * Tests , testSuite @@ -50,15 +50,16 @@ module Yesod.Response import Data.Time.Clock import Data.Maybe (mapMaybe) -import Data.ByteString.Lazy (ByteString, toChunks, fromChunks) 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 Control.Monad (foldM) +import qualified Data.Text.Lazy.Encoding as DTLE import Web.Encodings (formatW3) -import qualified Hack +import qualified Network.Wai as W +import qualified Network.Wai.Enumerator as WE #if TEST import Data.Object.Html hiding (testSuite) @@ -72,16 +73,17 @@ import Test.Framework (testGroup, Test) import Web.Mime -data Content = Content (forall a. ((a -> B.ByteString -> IO a) -> a -> IO a)) +data Content = ContentFile FilePath + | ContentEnum (forall a. W.Enumerator a) instance ConvertSuccess B.ByteString Content where - convertSuccess bs = Content $ \f a -> f a bs -instance ConvertSuccess ByteString Content where - convertSuccess lbs = Content $ \f a -> foldM f a $ toChunks lbs + convertSuccess bs = ContentEnum $ \f a -> f a bs +instance ConvertSuccess L.ByteString Content where + convertSuccess = ContentEnum . 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 :: ByteString) + convertSuccess lt = cs (cs lt :: L.ByteString) instance ConvertSuccess String Content where convertSuccess s = cs (cs s :: Text) instance ConvertSuccess HtmlDoc Content where @@ -94,8 +96,7 @@ 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 iotext = - Content $ \f a -> iotext >>= foldM f a . toChunks . cs +ioTextToContent t = ContentEnum $ WE.fromLBS' $ fmap DTLE.encodeUtf8 t -- | Any type which can be converted to representations. class HasReps a where @@ -138,13 +139,13 @@ instance HasReps (Html, HtmlObject) where ] -- | Data with a single representation. -staticRep :: ConvertSuccess x ByteString +staticRep :: ConvertSuccess x Content => ContentType -> x -> [(ContentType, Content)] -staticRep ct x = [(ct, cs (cs x :: ByteString))] +staticRep ct x = [(ct, cs x)] -data Response = Response Int [Header] ContentType Content +data Response = Response W.Status [Header] ContentType Content -- | Different types of redirects. data RedirectType = RedirectPermanent @@ -152,10 +153,10 @@ data RedirectType = RedirectPermanent | RedirectSeeOther deriving (Show, Eq) -getRedirectStatus :: RedirectType -> Int -getRedirectStatus RedirectPermanent = 301 -getRedirectStatus RedirectTemporary = 302 -getRedirectStatus RedirectSeeOther = 303 +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. @@ -173,11 +174,11 @@ data ErrorResponse = | PermissionDenied deriving (Show, Eq) -getStatus :: ErrorResponse -> Int -getStatus NotFound = 404 -getStatus (InternalError _) = 500 -getStatus (InvalidArgs _) = 400 -getStatus PermissionDenied = 403 +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'. @@ -188,35 +189,31 @@ data Header = deriving (Eq, Show) -- | Convert Header to a key/value pair. -headerToPair :: Header -> IO (String, String) +headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString) headerToPair (AddCookie minutes key value) = do now <- getCurrentTime let expires = addUTCTime (fromIntegral $ minutes * 60) now - return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires=" + return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair (DeleteCookie key) = return - ("Set-Cookie", + (W.SetCookie, cs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair (Header key value) = return (key, value) +headerToPair (Header key value) = + return (W.responseHeaderFromBS $ cs key, cs value) -responseToHackResponse :: Response -> IO Hack.Response -responseToHackResponse (Response sc hs ct c) = do +responseToWaiResponse :: Response -> IO W.Response +responseToWaiResponse (Response sc hs ct c) = do hs' <- mapM headerToPair hs - let hs'' = ("Content-Type", cs ct) : hs' - asLBS <- runContent c - return $ Hack.Response sc hs'' asLBS - -runContent :: Content -> IO ByteString -runContent (Content c) = do - front <- c helper id - return $ fromChunks $ front [] - where - helper :: ([B.ByteString] -> [B.ByteString]) - -> B.ByteString - -> IO ([B.ByteString] -> [B.ByteString]) - helper front bs = return $ front . (:) bs + let hs'' = (W.ContentType, cs ct) : hs' + return $ W.Response sc hs'' $ case c of + ContentFile fp -> Left fp + ContentEnum e -> Right e #if TEST +runContent :: Content -> IO L.ByteString +runContent (ContentFile fp) = L.readFile fp +runContent (ContentEnum c) = WE.toLBS c + ----- Testing testSuite :: Test testSuite = testGroup "Yesod.Response" diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 729af6a9..77b0852e 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -5,7 +5,7 @@ module Yesod.Yesod , applyLayout' , applyLayoutJson , getApproot - , toHackApp + , toWaiApp ) where import Data.Object.Html @@ -14,17 +14,18 @@ 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 Hack -import Hack.Middleware.CleanPath -import Hack.Middleware.ClientSession -import Hack.Middleware.Gzip -import Hack.Middleware.Jsonp -import Hack.Middleware.MethodOverride +import qualified Network.Wai as W +import Network.Wai.Middleware.CleanPath +import Network.Wai.Middleware.ClientSession +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.Jsonp +import Network.Wai.Middleware.MethodOverride class Yesod a where -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, @@ -86,8 +87,8 @@ defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do - rr <- getRawRequest - applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", show rr)] + --rr <- getRawRequest + applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", "FIXME")] defaultErrorHandler PermissionDenied = applyLayout' "Permission Denied" $ cs "Permission denied" defaultErrorHandler (InvalidArgs ia) = @@ -100,28 +101,34 @@ defaultErrorHandler (InternalError e) = [ ("Internal server error", e) ] -toHackApp :: Yesod y => y -> IO Hack.Application -toHackApp a = do +toWaiApp :: Yesod y => y -> IO W.Application +toWaiApp a = do key <- encryptKey a - let app' = toHackApp' a let mins = clientSessionDuration a return $ gzip - $ cleanPath $ jsonp $ methodOverride - $ clientsession encryptedCookies key mins - app' + $ cleanPath + $ \thePath -> clientsession encryptedCookies key mins + $ toWaiApp' a thePath -toHackApp' :: Yesod y => y -> Hack.Env -> IO Hack.Response -toHackApp' y env = do - let (Right resource) = splitPath $ Hack.pathInfo env - types = httpAccept env - verb = cs $ Hack.requestMethod env - handler = resources resource verb - rr = cs env +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 + verb = cs $ W.requestMethod env :: Verb + handler = resources (map cs resource) verb + rr <- parseWaiRequest env session res <- runHandler handler errorHandler rr y types - responseToHackResponse res + responseToWaiResponse res -httpAccept :: Hack.Env -> [ContentType] -httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" - . lookup "Accept" . Hack.http +httpAccept :: W.Request -> [ContentType] +httpAccept = map contentTypeFromBS + . parseHttpAccept + . fromMaybe B.empty + . lookup W.Accept + . W.httpHeaders diff --git a/yesod.cabal b/yesod.cabal index 65d2bc84..b6a91bdf 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,8 @@ library build-depends: base >= 4 && < 5, old-locale >= 1.0.0.1 && < 1.1, time >= 1.1.3 && < 1.2, - hack == 2009.10.30, + 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, @@ -46,8 +47,6 @@ library syb, text >= 0.5 && < 0.6, convertible-text >= 0.2.0 && < 0.3, - clientsession >= 0.0.1 && < 0.1, - zlib >= 0.5.2.0 && < 0.6, HStringTemplate >= 0.6.2 && < 0.7, data-object-json >= 0.0.0 && < 0.1, attempt >= 0.2.1 && < 0.3, @@ -63,11 +62,6 @@ library Yesod.Yesod Yesod.Template Data.Object.Html - Hack.Middleware.MethodOverride - Hack.Middleware.ClientSession - Hack.Middleware.Jsonp - Hack.Middleware.CleanPath - Hack.Middleware.Gzip Yesod.Helpers.Auth Yesod.Helpers.Static Yesod.Helpers.AtomFeed From ec1d17dcd4f9e3990f872074daac43518e07a2dd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 31 Jan 2010 10:20:26 +0200 Subject: [PATCH 141/624] Fixed content type matching --- Web/Mime.hs | 4 ++++ Yesod/Request.hs | 2 +- Yesod/Response.hs | 3 ++- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Web/Mime.hs b/Web/Mime.hs index 350b127d..2e915d4e 100644 --- a/Web/Mime.hs +++ b/Web/Mime.hs @@ -6,6 +6,7 @@ module Web.Mime , contentTypeFromBS , typeByExt , ext + , simpleContentType ) where import Data.Function (on) @@ -48,6 +49,9 @@ instance ConvertSuccess ContentType [Char] where convertSuccess TypeOctet = "application/octet-stream" convertSuccess (TypeOther s) = s +simpleContentType :: ContentType -> String +simpleContentType = fst . span (/= ';') . cs + instance Eq ContentType where (==) = (==) `on` (cs :: ContentType -> String) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 1ef86487..99728b84 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -115,7 +115,7 @@ parseWaiRequest env session = do $ parsePost ctype clength inputLBS rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env - cookies' = map (cs *** cs) $ decodeCookies rawCookie + cookies' = map (cs *** cs) $ parseCookies rawCookie acceptLang = lookup W.AcceptLanguage $ W.httpHeaders env langs = map cs $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey cookies' of diff --git a/Yesod/Response.hs b/Yesod/Response.hs index f3353651..a6b86c51 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -126,7 +126,8 @@ instance HasReps () where instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ - case filter (\(ct, _) -> ct `elem` cts) a of + case filter (\(ct, _) -> simpleContentType ct `elem` + map simpleContentType cts) a of ((ct, c):_) -> (ct, c) _ -> case a of (x:_) -> x From 7ead9d4e5ae0d41d09538371857994131f7eee5d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 31 Jan 2010 10:20:48 +0200 Subject: [PATCH 142/624] decodeCookies -> parseCookies --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index b6a91bdf..83765d6e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -38,7 +38,7 @@ library authenticate >= 0.4.0 && < 0.5, predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.1 && < 0.3, + web-encodings >= 0.2.2 && < 0.3, data-object >= 0.2.0 && < 0.3, data-object-yaml >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, From 89f40e48d03d12da034dbef123db6e7e01ef432e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 1 Feb 2010 15:07:05 +0200 Subject: [PATCH 143/624] Rudimentary form support --- TODO | 1 - Yesod.hs | 2 ++ Yesod/Form.hs | 97 +++++++++++++++++++++++++++++++++++++++++++++++++++ yesod.cabal | 1 + 4 files changed, 100 insertions(+), 1 deletion(-) delete mode 100644 TODO create mode 100644 Yesod/Form.hs diff --git a/TODO b/TODO deleted file mode 100644 index 6a6c07d0..00000000 --- a/TODO +++ /dev/null @@ -1 +0,0 @@ -Cleanup Parameter stuff. Own module? Interface with formlets? diff --git a/Yesod.hs b/Yesod.hs index 85335165..c95392d5 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -20,6 +20,7 @@ module Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource + , module Yesod.Form , module Data.Object.Html , module Yesod.Template , module Web.Mime @@ -38,6 +39,7 @@ import Data.Object.Html import Yesod.Request #endif +import Yesod.Form import Yesod.Yesod import Yesod.Definitions import Yesod.Handler diff --git a/Yesod/Form.hs b/Yesod/Form.hs new file mode 100644 index 00000000..1b842d59 --- /dev/null +++ b/Yesod/Form.hs @@ -0,0 +1,97 @@ +-- | Parse forms (and query strings). +module Yesod.Form + ( Form (..) + , runFormGeneric + , runFormPost + , runFormGet + , input + , applyForm + -- * Specific checks + , required + , notEmpty + , checkDay + , checkBool + ) where + +import Yesod.Request +import Yesod.Handler +import Control.Applicative +import Data.Time (Day) +import Data.Convertible.Text +import Data.Attempt +import Data.Maybe (fromMaybe) + +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 :: (ParamName -> [ParamValue]) -> Form x -> Handler y x +runFormGeneric params (Form f) = + case f params of + Left es -> invalidArgs es + Right (_, x) -> return x + +-- | Run a form against POST parameters. +runFormPost :: Form x -> Handler y x +runFormPost f = do + rr <- getRawRequest + runFormGeneric (postParams rr) f + +-- | Run a form against GET parameters. +runFormGet :: Form x -> Handler y x +runFormGet f = do + rr <- getRawRequest + 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" + +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 diff --git a/yesod.cabal b/yesod.cabal index 83765d6e..7a67088a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -57,6 +57,7 @@ library Yesod.Request Yesod.Response Yesod.Definitions + Yesod.Form Yesod.Handler Yesod.Resource Yesod.Yesod From a95704d1644048647dd32c5891a077394535019e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 1 Feb 2010 15:46:32 +0200 Subject: [PATCH 144/624] Only read request body when needed --- Yesod/Form.hs | 3 ++- Yesod/Helpers/Auth.hs | 5 ++-- Yesod/Request.hs | 61 ++++++++++++++++++++++++++----------------- 3 files changed, 42 insertions(+), 27 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1b842d59..ee9aa7ef 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -53,7 +53,8 @@ runFormGeneric params (Form f) = runFormPost :: Form x -> Handler y x runFormPost f = do rr <- getRawRequest - runFormGeneric (postParams rr) f + pp <- postParams rr + runFormGeneric pp f -- | Run a form against GET parameters. runFormGet :: Form x -> Handler y x diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 75f79602..f1293288 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -170,10 +170,11 @@ rpxnowLogin = do Just x -> return x Nothing -> notFound rr <- getRawRequest - let token = case getParams rr "token" ++ postParams rr "token" of + pp <- postParams rr + let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken (x:_) -> x - let dest = case postParams rr "dest" of + let dest = case pp "dest" of [] -> case getParams rr "dest" of [] -> ar ("":_) -> ar diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 99728b84..b8331553 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -48,6 +48,8 @@ import Data.Convertible.Text import Control.Arrow ((***)) import Control.Exception (SomeException (..)) import Data.Maybe (fromMaybe) +import Control.Monad.Trans +import Control.Concurrent.MVar #if TEST import Test.Framework (testGroup, Test) @@ -71,32 +73,36 @@ languages = rawLangs `fmap` getRawRequest parseEnv :: (Functor m, RequestReader m) => m W.Request parseEnv = rawRequest `fmap` getRawRequest +type RequestBodyContents = + ( [(ParamName, ParamValue)] + , [(ParamName, FileInfo String BL.ByteString)] + ) + -- | The raw information passed through W, cleaned up a bit. data RawRequest = RawRequest { rawGetParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] , rawSession :: [(B.ByteString, B.ByteString)] - -- when we switch to WAI, the following two should be combined and - -- wrapped in the IO monad - , rawPostParams :: [(ParamName, ParamValue)] - , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] + , rawRequestBody :: IO RequestBodyContents , rawRequest :: W.Request , rawLangs :: [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 :: RawRequest -> ParamName -> [ParamValue] -getParams rr name = map snd - . filter (\x -> name == fst x) - . rawGetParams - $ rr +getParams rr = multiLookup $ rawGetParams rr -- | All POST paramater values with the given name. -postParams :: RawRequest -> ParamName -> [ParamValue] -postParams rr name = map snd - . filter (\x -> name == fst x) - . rawPostParams - $ rr +postParams :: MonadIO m => RawRequest -> m (ParamName -> [ParamValue]) +postParams rr = do + (pp, _) <- liftIO $ rawRequestBody rr + return $ multiLookup pp -- | All cookies with the given name. cookies :: RawRequest -> ParamName -> [ParamValue] @@ -105,16 +111,7 @@ cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -> IO RawRequest parseWaiRequest env session = do let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env - let clength = maybe "0" cs $ lookup W.ReqContentLength - $ W.httpHeaders env - let ctype = maybe "" cs $ lookup W.ReqContentType $ W.httpHeaders env - let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c - inputLBS <- WE.toLBS $ W.requestBody env -- FIXME - let (posts, files) = map (convertSuccess *** convertSuccess) *** - map (convertSuccess *** convertFileInfo) - $ parsePost ctype clength - inputLBS - rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env + let rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env cookies' = map (cs *** cs) $ parseCookies rawCookie acceptLang = lookup W.AcceptLanguage $ W.httpHeaders env langs = map cs $ maybe [] parseHttpAccept acceptLang @@ -124,7 +121,23 @@ parseWaiRequest env session = do langs'' = case lookup langKey gets' of Nothing -> langs' Just x -> x : langs' - return $ RawRequest gets' cookies' session posts files env langs'' + mrb <- newMVar $ Left env + return $ RawRequest gets' cookies' session (rbHelper mrb) env langs'' + +rbHelper :: MVar (Either W.Request RequestBodyContents) + -> IO RequestBodyContents +rbHelper mvar = modifyMVar mvar helper where + helper (Right bc) = return (Right bc, bc) + helper (Left env) = do + inputLBS <- WE.toLBS $ W.requestBody env -- FIXME + let clength = maybe "0" cs $ lookup W.ReqContentLength + $ W.httpHeaders env + let ctype = maybe "" cs $ lookup W.ReqContentType $ W.httpHeaders env + let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c + let ret = map (cs *** cs) *** + map (cs *** convertFileInfo) + $ parsePost ctype clength inputLBS + return (Right ret, ret) #if TEST testSuite :: Test From 0e96af34be098028eb79ef18dd81727ebe35fe00 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 3 Feb 2010 07:04:55 +0200 Subject: [PATCH 145/624] Resource Int to Integer --- Test/Errors.hs | 7 ++----- Test/QuasiResource.hs | 6 +++--- Yesod/Resource.hs | 4 ++-- 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/Test/Errors.hs b/Test/Errors.hs index f673d839..7dfbac61 100644 --- a/Test/Errors.hs +++ b/Test/Errors.hs @@ -1,17 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE EmptyDataDecls #-} module Test.Errors (testSuite) where import Yesod import Yesod.Helpers.Auth -import Network.Wai -import Data.Default -import Data.List import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) -import qualified Data.ByteString.Char8 as B8 -data Errors = Errors +data Errors instance Yesod Errors where resources = [$mkResources| /denied: diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 97dbc3fd..56d9af56 100644 --- a/Test/QuasiResource.hs +++ b/Test/QuasiResource.hs @@ -31,11 +31,11 @@ pageDelete :: String -> Handler MyYesod (Html, HtmlObject) pageDelete s = addHead $ toHtmlObject ["pageDelete", s] pageUpdate :: String -> Handler MyYesod ChooseRep pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s] -userInfo :: Int -> Handler MyYesod (Html, HtmlObject) +userInfo :: Integer -> Handler MyYesod (Html, HtmlObject) userInfo i = addHead $ toHtmlObject ["userInfo", show i] -userVariable :: Int -> String -> Handler MyYesod (Html, HtmlObject) +userVariable :: Integer -> String -> Handler MyYesod (Html, HtmlObject) userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s] -userPage :: Int -> [String] -> Handler MyYesod (Html, HtmlObject) +userPage :: Integer -> [String] -> Handler MyYesod (Html, HtmlObject) userPage i p = addHead $ toHtmlObject ["userPage", show i, show p] instance Show (Verb -> Handler MyYesod ChooseRep) where diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 7d79e192..4e8ae0e6 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -291,7 +291,7 @@ rpnodesTH ns = do data UrlParam = SlurpParam { slurpParam :: [String] } | StringParam { stringParam :: String } - | IntParam { intParam :: Int } + | IntParam { intParam :: Integer } getUrlParam :: RP -> Resource -> Int -> UrlParam getUrlParam rp = (!!) . paramsFromMatchingPattern rp @@ -302,7 +302,7 @@ getUrlParamSlurp rp r = slurpParam . getUrlParam rp r getUrlParamString :: RP -> Resource -> Int -> String getUrlParamString rp r = stringParam . getUrlParam rp r -getUrlParamInt :: RP -> Resource -> Int -> Int +getUrlParamInt :: RP -> Resource -> Int -> Integer getUrlParamInt rp r = intParam . getUrlParam rp r applyUrlParams :: RP -> Exp -> Exp -> Q Exp From 38a15e4692075b22a78ad0922b685a9e95f44e5d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 3 Feb 2010 16:23:32 +0200 Subject: [PATCH 146/624] templateHtml and templateHtmlJson --- Yesod/Response.hs | 21 +++++++ Yesod/Template.hs | 77 ++++++++++++++----------- examples/fact.lhs | 10 ++-- examples/hellotemplate.lhs | 19 +++--- examples/helloworld.lhs | 4 +- examples/{template.html => template.st} | 4 +- yesod.cabal | 13 +---- 7 files changed, 85 insertions(+), 63 deletions(-) rename examples/{template.html => template.st} (89%) diff --git a/Yesod/Response.hs b/Yesod/Response.hs index a6b86c51..90530cfa 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -25,8 +25,13 @@ module Yesod.Response , HasReps (..) , defChooseRep , ioTextToContent + , hoToJsonContent -- ** Convenience wrappers , staticRep + -- ** Specific content types + , RepHtml (..) + , RepJson (..) + , RepHtmlJson (..) -- * Response type , Response (..) -- * Special responses @@ -98,6 +103,9 @@ type ChooseRep = [ContentType] -> IO (ContentType, Content) ioTextToContent :: IO Text -> Content ioTextToContent t = ContentEnum $ WE.fromLBS' $ fmap DTLE.encodeUtf8 t +hoToJsonContent :: HtmlObject -> Content +hoToJsonContent = cs . unJsonDoc . cs + -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep @@ -146,6 +154,19 @@ staticRep :: ConvertSuccess x Content -> [(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. diff --git a/Yesod/Template.hs b/Yesod/Template.hs index ee5f910e..afb9fd48 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -2,13 +2,15 @@ {-# LANGUAGE FlexibleContexts #-} module Yesod.Template ( YesodTemplate (..) - , template , NoSuchTemplate , Template , TemplateGroup - , TemplateFile (..) - , setAttribute , loadTemplateGroup + -- * HTML templates + , HtmlTemplate (..) + , templateHtml + , templateHtmlJson + , setHtmlAttrib ) where import Data.Object.Html @@ -16,8 +18,6 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Object.Text (Text) import Text.StringTemplate -import Data.Object.Json -import Web.Mime import Yesod.Response import Yesod.Yesod import Yesod.Handler @@ -27,41 +27,52 @@ type TemplateGroup = STGroup Text class Yesod y => YesodTemplate y where getTemplateGroup :: y -> TemplateGroup + -- FIXME defaultTemplateAttribs :: y -> HtmlTemplate -> Handler y HtmlTemplate getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup getTemplateGroup' = getTemplateGroup `fmap` getYesod -template :: YesodTemplate y - => String -- ^ template name - -> HtmlObject -- ^ object - -> (HtmlObject -> Template -> IO Template) - -> Handler y ChooseRep -template tn ho f = do - tg <- getTemplateGroup' - t <- case getStringTemplate tn tg of - Nothing -> failure $ NoSuchTemplate tn - Just x -> return x - return $ chooseRep - [ (TypeHtml, tempToContent t ho f) - , (TypeJson, cs $ unJsonDoc $ cs ho) - ] newtype NoSuchTemplate = NoSuchTemplate String deriving (Show, Typeable) instance Exception NoSuchTemplate -tempToContent :: Template - -> HtmlObject - -> (HtmlObject -> Template -> IO Template) - -> Content -tempToContent t ho f = ioTextToContent $ fmap render $ f ho t - -data TemplateFile = TemplateFile FilePath HtmlObject -instance HasReps TemplateFile where - chooseRep (TemplateFile fp (Mapping m)) _ = do - t <- fmap newSTMP $ readFile fp - let t' = setManyAttrib m t :: Template - return (TypeHtml, cs $ render t') - chooseRep _ _ = error "Please fix type of TemplateFile" - loadTemplateGroup :: FilePath -> IO TemplateGroup loadTemplateGroup = directoryGroupRecursiveLazy + +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' + t <- case getStringTemplate tn tg of + Nothing -> failure $ NoSuchTemplate tn + Just x -> return x + return $ RepHtml $ ioTextToContent $ fmap (render . unHtmlTemplate) + $ f $ 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' + t <- case getStringTemplate tn tg of + Nothing -> failure $ NoSuchTemplate tn + Just x -> return x + return $ RepHtmlJson + (ioTextToContent $ fmap (render . unHtmlTemplate) + $ f ho $ HtmlTemplate t) + (hoToJsonContent ho) diff --git a/examples/fact.lhs b/examples/fact.lhs index 7debce47..05a7b089 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -7,13 +7,13 @@ 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 Hack.Handler.SimpleServer allows us to test our -application easily. A Yesod app can in general run on any Hack handler, so this +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 Hack.Handler.SimpleServer +> 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 @@ -100,9 +100,9 @@ factRedirect. > return () -You could replace this main to use any Hack handler you want. For production, +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..." >> toHackApp Fact >>= run 3000 +> main = putStrLn "Running..." >> toWaiApp Fact >>= run 3000 diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index f03bcf4a..7e0d7f45 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -2,7 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Hack.Handler.SimpleServer +import Network.Wai.Handler.SimpleServer data HelloWorld = HelloWorld TemplateGroup instance YesodTemplate HelloWorld where @@ -15,18 +15,17 @@ instance Yesod HelloWorld where Get: helloGroup |] -helloWorld :: Handler HelloWorld TemplateFile -helloWorld = return $ TemplateFile "examples/template.html" $ cs - [ ("title", "Hello world!") - , ("content", "Hey look!! I'm <auto escaped>!") - ] +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 ChooseRep -helloGroup = template "real-template" (cs "bar") $ \ho -> - return . setAttribute "foo" ho +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" >>= toHackApp . HelloWorld >>= run 3000 + loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000 \end{code} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index 1fbd6f73..a676612a 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -2,7 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Hack.Handler.SimpleServer +import Network.Wai.Handler.SimpleServer data HelloWorld = HelloWorld instance Yesod HelloWorld where @@ -15,5 +15,5 @@ helloWorld :: Handler HelloWorld ChooseRep helloWorld = applyLayout' "Hello World" $ cs "Hello world!" main :: IO () -main = putStrLn "Running..." >> toHackApp HelloWorld >>= run 3000 +main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000 \end{code} diff --git a/examples/template.html b/examples/template.st similarity index 89% rename from examples/template.html rename to examples/template.st index 8d1b393d..f71953cf 100644 --- a/examples/template.html +++ b/examples/template.st @@ -2,7 +2,7 @@ <html> <head> <meta charset="utf-8"> - <title>$o.title$ + $title$ + + +$content$ + + diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs new file mode 100755 index 00000000..268f03c5 --- /dev/null +++ b/examples/tweedle.lhs @@ -0,0 +1,400 @@ +#!/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 ((<$>), (<*>)) + +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 issueHelper (Issue name _ iid) = Mapping +> [ ("name", Scalar $ Text $ pack name) +> , ("id", Scalar $ Text $ pack $ show iid) +> ] +> 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 From 9e2b39e90fa44dac3fda0e8cb7fb0554bc700811 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 5 Mar 2010 13:42:31 -0800 Subject: [PATCH 170/624] Show most recent status and priority for tweedle --- examples/tweedle-templates/category-details.st | 7 ++++--- examples/tweedle.lhs | 9 ++++++++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/examples/tweedle-templates/category-details.st b/examples/tweedle-templates/category-details.st index e1c8f3e1..0c3bdecb 100644 --- a/examples/tweedle-templates/category-details.st +++ b/examples/tweedle-templates/category-details.st @@ -18,9 +18,10 @@ $cat.cats:{cat|
                New issue:

                Issues

                -
                  + + $cat.issues:{issue| -
                • $issue.name$
                  • + }$ - +
                  TitleStatusPriority
                  $issue.name$$issue.status$$issue.priority$
                  })$ diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs index 268f03c5..05a73f28 100755 --- a/examples/tweedle.lhs +++ b/examples/tweedle.lhs @@ -22,6 +22,7 @@ Anyway, here's the import list. > 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. @@ -254,9 +255,15 @@ Now we want to convert the category into an HtmlObject. By doing so, we will get > [ ("name", Scalar $ Text $ pack name) > , ("id", Scalar $ Text $ pack $ show cid) > ] -> let issueHelper (Issue name _ iid) = Mapping +> 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) From 9e77f4fab582acbb420e60f3f0b2f3d700c733b9 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 5 Mar 2010 13:46:16 -0800 Subject: [PATCH 171/624] Tweedle added to cabal file --- yesod.cabal | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/yesod.cabal b/yesod.cabal index ce26b0ab..34edd6b8 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -123,3 +123,11 @@ executable pretty-yaml 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 From ef2e84668a2e2de06695093b286d12b726f31d82 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Sun, 7 Mar 2010 16:51:58 -0800 Subject: [PATCH 172/624] Added yesod executable (with init) --- CLI/skel/App.hs | 70 +++++++++++++++++++++++++++++++ CLI/skel/LICENSE | 25 +++++++++++ CLI/skel/settings.yaml | 5 +++ CLI/skel/static/style.css | 10 +++++ CLI/skel/templates/homepage.st | 7 ++++ CLI/skel/templates/layout.st | 11 +++++ CLI/skel/webapp.cabal | 21 ++++++++++ CLI/yesod.hs | 76 ++++++++++++++++++++++++++++++++++ Yesod.hs | 3 +- Yesod/Helpers/Static.hs | 1 - Yesod/Template.hs | 18 ++++++++ Yesod/Yesod.hs | 17 ++++++++ yesod.cabal | 5 +++ 13 files changed, 267 insertions(+), 2 deletions(-) create mode 100644 CLI/skel/App.hs create mode 100644 CLI/skel/LICENSE create mode 100644 CLI/skel/settings.yaml create mode 100644 CLI/skel/static/style.css create mode 100644 CLI/skel/templates/homepage.st create mode 100644 CLI/skel/templates/layout.st create mode 100644 CLI/skel/webapp.cabal create mode 100644 CLI/yesod.hs diff --git a/CLI/skel/App.hs b/CLI/skel/App.hs new file mode 100644 index 00000000..9b1a37d9 --- /dev/null +++ b/CLI/skel/App.hs @@ -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 diff --git a/CLI/skel/LICENSE b/CLI/skel/LICENSE new file mode 100644 index 00000000..29ed9276 --- /dev/null +++ b/CLI/skel/LICENSE @@ -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. diff --git a/CLI/skel/settings.yaml b/CLI/skel/settings.yaml new file mode 100644 index 00000000..e98384d4 --- /dev/null +++ b/CLI/skel/settings.yaml @@ -0,0 +1,5 @@ +approot: http://localhost:3000/ +static-root: http://localhost:3000/static/ +static-dir: static +template-dir: templates +port: 3000 diff --git a/CLI/skel/static/style.css b/CLI/skel/static/style.css new file mode 100644 index 00000000..d5de60d6 --- /dev/null +++ b/CLI/skel/static/style.css @@ -0,0 +1,10 @@ +html { + background: #ccc; +} +body { + width: 760px; + margin: 10px auto; + padding: 10px; + border: 1px solid #333; + background: #fff; +} diff --git a/CLI/skel/templates/homepage.st b/CLI/skel/templates/homepage.st new file mode 100644 index 00000000..fffa55d9 --- /dev/null +++ b/CLI/skel/templates/homepage.st @@ -0,0 +1,7 @@ +\$layout( + title={Homepage}; + content={ +

                  Homepage

                  +

                  You probably want to put your own content here.

                  + } +)\$ diff --git a/CLI/skel/templates/layout.st b/CLI/skel/templates/layout.st new file mode 100644 index 00000000..fadca393 --- /dev/null +++ b/CLI/skel/templates/layout.st @@ -0,0 +1,11 @@ + + + + \$title\$ + + \$extrahead\$ + + + \$content\$ + + diff --git a/CLI/skel/webapp.cabal b/CLI/skel/webapp.cabal new file mode 100644 index 00000000..0fe22111 --- /dev/null +++ b/CLI/skel/webapp.cabal @@ -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 diff --git a/CLI/yesod.hs b/CLI/yesod.hs new file mode 100644 index 00000000..3f6606f9 --- /dev/null +++ b/CLI/yesod.hs @@ -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." diff --git a/Yesod.hs b/Yesod.hs index af6f8dbe..59fec055 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -25,6 +25,7 @@ module Yesod , module Yesod.Template , module Web.Mime , Application + , Method (..) ) where #if TEST @@ -45,5 +46,5 @@ import Yesod.Form import Yesod.Yesod import Yesod.Definitions import Yesod.Handler -import Network.Wai (Application) +import Network.Wai (Application, Method (..)) import Yesod.Template diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index c48d9514..ecb7d457 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,7 +27,6 @@ import Control.Monad import Yesod import Data.List (intercalate) -import Network.Wai (Method (GET)) type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) diff --git a/Yesod/Template.hs b/Yesod/Template.hs index 03c073a3..b5b7a4f5 100644 --- a/Yesod/Template.hs +++ b/Yesod/Template.hs @@ -6,6 +6,7 @@ module Yesod.Template , Template , TemplateGroup , loadTemplateGroup + , defaultApplyLayout -- * HTML templates , HtmlTemplate (..) , templateHtml @@ -43,6 +44,23 @@ 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 } diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a50556ef..44112e58 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -6,6 +6,7 @@ module Yesod.Yesod , applyLayoutJson , getApproot , toWaiApp + , basicHandler ) where import Data.Object.Html @@ -26,6 +27,10 @@ import Network.Wai.Middleware.ClientSession import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.MethodOverride +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. @@ -139,3 +144,15 @@ httpAccept = map contentTypeFromBS . 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 diff --git a/yesod.cabal b/yesod.cabal index 34edd6b8..388ace3d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -70,6 +70,11 @@ library Web.Mime ghc-options: -Wall -Werror +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 From f97719a757ad6976dd31ab31d69bc834109c9026 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Sun, 7 Mar 2010 18:56:55 -0800 Subject: [PATCH 173/624] New README; enabled Gzip. --- README | 3 ++ README.md | 119 ------------------------------------------------- Yesod/Yesod.hs | 4 +- 3 files changed, 6 insertions(+), 120 deletions(-) create mode 100644 README delete mode 100644 README.md diff --git a/README b/README new file mode 100644 index 00000000..5994b259 --- /dev/null +++ b/README @@ -0,0 +1,3 @@ +After installing, type "yesod init" to start a new project. + +More information available at: http://www.yesodweb.com/code.html diff --git a/README.md b/README.md deleted file mode 100644 index 96cce18a..00000000 --- a/README.md +++ /dev/null @@ -1,119 +0,0 @@ -A Restful front controller built on Hack. - -Below is an overview of how the refactored code will hopefully turn out. - -# Terminology - -## Verb - -HTTP request methods. Possible values: GET, POST, PUT, DELETE. Please see -http://rest.blueoxen.net/cgi-bin/wiki.pl?MinimumMethods. In sum: - -GET: Read only. -PUT: Replace data on server. -DELETE: Remove data from server. -POST: Some form of update. - -Note: not all clients support PUT and DELETE. Therefore, we need a -workaround. There are two fixes: - -1. X-HTTP-Method-Override header. -2. Get parameter _method_override (ie, in the query string). This will be more -useful for web forms. - -See MethodOverride middleware. - -## Resource - -A Resource is a single URL. Each Resource can be addressed with the four verbs, -though does not necesarily support all of them. There are a few different ways -of passing parameters: - -1. URL parameter. For example, you can set up your application so that -/articles/my_title/ will hand off to the article resource with a parameter of -my_title. The idea here is to avoid the regexs present in most other -frameworks and provide a uniform interface for all parameters. - -2. Get parameter, ie query string. - -3. Post parameter, ie content body. This is *not* available for GET requests. -However, it *is* available for PUT and DELETE. - -4. Headers, including cookies. - -### ResourceName - -As a side point to the URL parameter mentioned above: let us say you have -multiple resources like /articles/my_title/ and /articles/other_title/. You -clearly do not want to write code twice to process these requests. Instead, -convert the article name into a URL parameter and then articles will have its -own ResourceName. - -NOTE: This has taken on a very central role in the restful library, in addition -to the RestfulApp class. Hopefully I will have a chance to document this soon. -As a result, some of the following documentation is outdated. - -### ResourceParser - -A ResourceParser converts a Resource (ie, a URL) to a ResourceName and URL -parameters. - -## RawRequest - -The parsed data sent from the client. Has, for example, GET and POST -parameters, not QUERY_STRING and CONTENT_BODY. - -## Request - -Request is actually a **type class** for parsing a RawRequest. This allows -putting all form handling code and the like into a single place. Your handler -code (see below) need only deal with your data type. - -## Representation - -Some method of showing data to the client. These are identified by MIME types. -For the most part, you should be using hierarchichal data (see Data.Object). -There are some exceptions, such as: - -* HTML for non-Ajax clients (search engines, old browsers). -* Atom/RSS feeds. -* Sitemaps. - -Whenever possible, use Data.Object, as this will automatically handle some -basic representations (JSON, JSONP, Yaml, XML, undecorated HTML). - -## Response - -Contains basic HTTP response information and something which can be represented -in different ways. - -## Handler - -There is a single Handler for each combination of ResourceName and Verb. A -Handler takes some instance of Request and returns a Response. - -### HandlerMap - -Maps a ResourceName/Verb pair to a Handler. - -## Application - -An application is essentially a ResourceParser and HandlerMap. It also has some -settings involved. - -# Static files - -All static files should go under the /static/ path. A typical application will -probably have a Javascript file in there which deals directly with the entire -Restful API. - -# Non-Ajax clients - -Search engines nad older clients should not be ignored. However, it is quite -tedious to write view code twice. Hopefully, in the future there will be a view -component to this framework which can automate some of that process. - -# Passing global data - -You should use function currying to pass around global information (the list of -entries in a blog, a database connection, etc). diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 44112e58..a8e09714 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -26,6 +26,7 @@ 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 @@ -118,7 +119,8 @@ toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do key <- encryptKey a let mins = clientSessionDuration a - return $ jsonp + return $ gzip + $ jsonp $ methodOverride $ cleanPath $ \thePath -> clientsession encryptedCookies key mins From ed2947f10575ef5a42d6560b5b4c0a4fcac663a4 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Sun, 7 Mar 2010 18:57:20 -0800 Subject: [PATCH 174/624] New homepage and Git repo --- yesod.cabal | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 388ace3d..c13ebb75 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -8,9 +8,9 @@ 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.2 +cabal-version: >= 1.6 build-type: Simple -homepage: http://github.com/snoyberg/yesod +homepage: http://www.yesodweb.com/code.html flag buildtests description: Build the executable to run unit tests @@ -68,7 +68,7 @@ library Yesod.Helpers.AtomFeed Yesod.Helpers.Sitemap Web.Mime - ghc-options: -Wall -Werror + ghc-options: -Wall executable yesod ghc-options: -Wall @@ -136,3 +136,7 @@ executable tweedle Buildable: False ghc-options: -Wall main-is: examples/tweedle.lhs + +source-repository head + type: git + location: git://github.com/snoyberg/yesod.git From 9acce7b4d6baff4ea1d3d869c60a6958e073677f Mon Sep 17 00:00:00 2001 From: Snoyman Date: Sun, 7 Mar 2010 19:18:16 -0800 Subject: [PATCH 175/624] Included skeleton files in cabal file --- yesod.cabal | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index c13ebb75..db40435d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -11,6 +11,13 @@ 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 @@ -70,10 +77,10 @@ library 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 yesod + ghc-options: -Wall + build-depends: file-embed >= 0.0.3 && < 0.1 + main-is: CLI/yesod.hs executable runtests if flag(buildtests) From 45871126865cf04e471803e3f908fa23e2f00e14 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Wed, 10 Mar 2010 09:27:16 -0800 Subject: [PATCH 176/624] Removed usage of liftString (compat with 6.10) --- Yesod/Resource.hs | 5 ++--- yesod.cabal | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 8de66af1..f5d04d31 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -389,9 +389,8 @@ 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' + let s = LitE $ StringL $ cs $ methodToBS m + return $ methodFromBS' `AppE` AppE cs' s strToExp :: Bool -> String -> Q Exp strToExp toCheck s = do diff --git a/yesod.cabal b/yesod.cabal index db40435d..95c213fe 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.0.0 +version: 0.0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 6f88e0ff765f5c161d022eff7cba49157fa30d76 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Wed, 10 Mar 2010 10:17:10 -0800 Subject: [PATCH 177/624] Removed call to buggy encodeUtf8 --- Yesod/Response.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Yesod/Response.hs b/Yesod/Response.hs index b3a90802..f702bffd 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -60,7 +60,6 @@ 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 @@ -106,7 +105,7 @@ 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 +ioTextToContent = swapEnum . WE.fromLBS' . fmap cs swapEnum :: W.Enumerator -> Content swapEnum (W.Enumerator e) = ContentEnum e From 3854af50f6bb25a31a88f3bc593aa7d6afec155c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 11:40:17 -0700 Subject: [PATCH 178/624] Updated transformers to 0.2.0 --- Yesod/Form.hs | 2 +- Yesod/Handler.hs | 2 +- Yesod/Request.hs | 2 +- Yesod/Resource.hs | 517 +--------------------------------------------- yesod.cabal | 9 +- 5 files changed, 8 insertions(+), 524 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 65417850..0b7a80cf 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -27,7 +27,7 @@ import Data.Time (Day) import Data.Convertible.Text import Data.Attempt import Data.Maybe (fromMaybe) -import "transformers" Control.Monad.Trans (MonadIO) +import "transformers" Control.Monad.IO.Class (MonadIO) import qualified Safe.Failure noParamNameError :: String diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 42de2fe5..3a95145c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -42,7 +42,7 @@ import Web.Mime import Control.Exception hiding (Handler) import Control.Applicative -import "transformers" Control.Monad.Trans +import "transformers" Control.Monad.IO.Class import Control.Monad.Attempt import Control.Monad (liftM, ap) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 13c74953..1d4035fb 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -47,7 +47,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Convertible.Text import Control.Arrow ((***)) import Data.Maybe (fromMaybe) -import "transformers" Control.Monad.Trans +import "transformers" Control.Monad.IO.Class import Control.Concurrent.MVar #if TEST diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index f5d04d31..7c9c4a03 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -1,14 +1,3 @@ -{-# 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 @@ -23,509 +12,5 @@ -- --------------------------------------------------------- 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 = LitE $ StringL $ cs $ methodToBS m - 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 diff --git a/yesod.cabal b/yesod.cabal index 95c213fe..b1d08cd1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.0.0.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -42,15 +42,14 @@ library 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, + authenticate >= 0.6 && < 0.7, 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, + transformers >= 0.2.0 && < 0.3, + control-monad-attempt >= 0.2.0 && < 0.3, syb, text >= 0.5 && < 0.8, convertible-text >= 0.2.0 && < 0.3, From a19751622a9f5ceefc762842ace20f7ba325eae9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 12:47:52 -0700 Subject: [PATCH 179/624] Initial migration to web-routes-quasi --- Yesod/Handler.hs | 35 ++++++++++++++++++++++------------- Yesod/Resource.hs | 41 +++++++++++++++++++++++++++-------------- Yesod/Yesod.hs | 38 ++++++++++++++++++++++++++++---------- yesod.cabal | 4 +++- 4 files changed, 80 insertions(+), 38 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3a95145c..b5a8853a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -21,8 +22,11 @@ module Yesod.Handler ( -- * Handler monad Handler , getYesod + , getUrlRender , runHandler , liftIO + , YesodApp + , Routes -- * Special handlers , redirect , sendFile @@ -51,7 +55,14 @@ import Data.Object.Html import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W -data HandlerData yesod = HandlerData Request yesod +type family Routes y + +data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String) + +type YesodApp yesod = (ErrorResponse -> Handler yesod ChooseRep) + -> Request + -> [ContentType] + -> IO Response ------ Handler monad newtype Handler yesod a = Handler { @@ -84,27 +95,25 @@ instance MonadIO (Handler yesod) where instance Failure ErrorResponse (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance RequestReader (Handler yesod) where - getRequest = Handler $ \(HandlerData rr _) + getRequest = Handler $ \(HandlerData rr _ _) -> return ([], HCContent rr) getYesod :: Handler yesod yesod -getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent 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 +getUrlRender :: Handler yesod (Routes yesod -> String) +getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r) + +runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp yesod +runHandler handler y render eh rr cts = do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData rr y) + (unHandler handler $ HandlerData rr y render) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- runHandler (eh e) safeEh rr y cts + Response _ hs ct c <- runHandler (eh e) y render safeEh rr cts let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c let sendFile' ct fp = do @@ -119,7 +128,7 @@ runHandler handler eh rr y cts = do (sendFile' ct fp) (handleError . toErrorHandler) HCContent a -> do - (ct, c) <- a cts + (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c safeEh :: ErrorResponse -> Handler yesod ChooseRep diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 7c9c4a03..fd8c5dd9 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -1,16 +1,29 @@ ---------------------------------------------------------- --- --- Module : Yesod.Resource --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Defines the ResourceName class. --- ---------------------------------------------------------- +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} module Yesod.Resource - ( + ( parseRoutes + , mkYesod ) where + +import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) +import Yesod.Handler +import Language.Haskell.TH.Syntax +import Yesod.Yesod + +mkYesod :: String -> [Resource] -> Q [Dec] +mkYesod name res = do + let name' = mkName name + let yaname = mkName $ name ++ "YesodApp" + let ya = TySynD yaname [] $ ConT ''YesodApp `AppT` ConT name' + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let hand = TySynD (mkName $ name ++ "Handler") [PlainTV $ mkName "a"] + $ ConT ''Handler `AppT` ConT name' `AppT` VarT (mkName "a") + let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" + let yes' = FunD (mkName "getSite") [Clause [] gsbod []] + let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] + decs <- createRoutes (name ++ "Routes") + yaname + name' + "runHandler" + res + return $ ya : tySyn : hand : yes : decs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8e09714..30ff6e41 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,6 +1,7 @@ -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) + , YesodSite (..) , YesodApproot (..) , applyLayout' , applyLayoutJson @@ -20,6 +21,7 @@ import qualified Data.ByteString as B import Data.Maybe (fromMaybe) import Web.Mime import Web.Encodings (parseHttpAccept) +import Web.Routes (Site (..)) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -32,11 +34,13 @@ 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 +class YesodSite y where + getSite :: ((String -> YesodApp y) -> YesodApp y) -- ^ get the method + -> YesodApp y -- ^ bad method + -> y + -> Site (Routes y) (YesodApp y) +class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile @@ -62,6 +66,8 @@ class Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () + badMethod :: a -> YesodApp a + class Yesod a => YesodApproot a where -- | An absolute URL to the root of the application. approot :: a -> Approot @@ -133,12 +139,24 @@ toWaiApp' :: Yesod y -> 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 + let site = getSite getMethod (badMethod y) y + types = httpAccept env + pathSegments = map cleanupSegment resource + eurl = parsePathSegments site pathSegments + case eurl of + Left _ -> error "FIXME: send 404 message" + Right url -> do + rr <- parseWaiRequest env session + onRequest y rr + let render = error "FIXME: render" -- use formatPathSegments + res <- handleSite site render url errorHandler rr types + responseToWaiResponse res + +getMethod :: (String -> YesodApp y) -> YesodApp y +getMethod = error "FIXME: getMethod" + +cleanupSegment :: B.ByteString -> String +cleanupSegment = error "FIXME: cleanupSegment" httpAccept :: W.Request -> [ContentType] httpAccept = map contentTypeFromBS diff --git a/yesod.cabal b/yesod.cabal index b1d08cd1..8a4843b0 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -58,7 +58,9 @@ library attempt >= 0.2.1 && < 0.3, template-haskell, failure >= 0.0.0 && < 0.1, - safe-failure >= 0.4.0 && < 0.5 + safe-failure >= 0.4.0 && < 0.5, + web-routes >= 0.20 && < 0.21, + web-routes-quasi >= 0.0 && < 0.1 exposed-modules: Yesod Yesod.Request Yesod.Response From 5d14ac5e1e3f485cb17e741575dba5db9f6e1c63 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 12:54:19 -0700 Subject: [PATCH 180/624] Proper render function; removed YesodApproot --- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Auth.hs | 6 +++--- Yesod/Helpers/Sitemap.hs | 4 ++-- Yesod/Yesod.hs | 14 +++++++------- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 1e6854e5..44164438 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -27,7 +27,7 @@ import Web.Encodings (formatW3) data AtomFeedResponse = AtomFeedResponse AtomFeed Approot -atomFeed :: YesodApproot y => AtomFeed -> Handler y AtomFeedResponse +atomFeed :: Yesod y => AtomFeed -> Handler y AtomFeedResponse atomFeed f = do y <- getYesod return $ AtomFeedResponse f $ approot y diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 68c1a8eb..105ab62f 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -40,7 +40,7 @@ import Control.Applicative ((<$>)) -- FIXME check referer header to determine destination -class YesodApproot a => YesodAuth a where +class Yesod a => YesodAuth a where -- | The following breaks DRY, but I cannot think of a better solution -- right now. -- @@ -134,7 +134,7 @@ authOpenidForward = do (redirect RedirectTemporary) res -authOpenidComplete :: YesodApproot y => Handler y () +authOpenidComplete :: Yesod y => Handler y () authOpenidComplete = do rr <- getRequest let gets' = reqGetParams rr @@ -239,7 +239,7 @@ requestPath = do -- | 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 :: Yesod y => RedirectType -> String -> Handler y a redirectSetDest rt dest = do ar <- getApproot rp <- requestPath diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index a22f26f4..2a29e104 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -73,12 +73,12 @@ instance HasReps SitemapResponse where [ (TypeXml, return . cs) ] -sitemap :: YesodApproot y => [SitemapUrl] -> Handler y SitemapResponse +sitemap :: Yesod y => [SitemapUrl] -> Handler y SitemapResponse sitemap urls = do yesod <- getYesod return $ SitemapResponse urls $ approot yesod -robots :: YesodApproot yesod => Handler yesod [(ContentType, Content)] +robots :: Yesod yesod => Handler yesod [(ContentType, Content)] robots = do yesod <- getYesod return $ staticRep TypePlain $ "Sitemap: " ++ showLocation diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 30ff6e41..25f5e0f3 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -2,7 +2,6 @@ module Yesod.Yesod ( Yesod (..) , YesodSite (..) - , YesodApproot (..) , applyLayout' , applyLayoutJson , getApproot @@ -21,7 +20,7 @@ import qualified Data.ByteString as B import Data.Maybe (fromMaybe) import Web.Mime import Web.Encodings (parseHttpAccept) -import Web.Routes (Site (..)) +import Web.Routes (Site (..), encodePathInfo) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -66,10 +65,10 @@ class YesodSite a => Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () - badMethod :: a -> YesodApp a + badMethod :: a -> YesodApp a -- FIXME include in errorHandler -class Yesod a => YesodApproot a where - -- | An absolute URL to the root of the application. + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. approot :: a -> Approot -- | A convenience wrapper around 'applyLayout'. @@ -98,7 +97,7 @@ applyLayoutJson t b = do , (TypeJson, cs $ unJsonDoc $ cs b) ] -getApproot :: YesodApproot y => Handler y Approot +getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y @@ -148,7 +147,8 @@ toWaiApp' y resource session env = do Right url -> do rr <- parseWaiRequest env session onRequest y rr - let render = error "FIXME: render" -- use formatPathSegments + let render u = approot y ++ '/' + : encodePathInfo (formatPathSegments site u) res <- handleSite site render url errorHandler rr types responseToWaiResponse res From 45b43437477929531d1c54f7ff2ab993bf613924 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 12:56:54 -0700 Subject: [PATCH 181/624] Implemented getMethod --- Yesod/Yesod.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 25f5e0f3..47cac882 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -16,6 +16,7 @@ import Yesod.Request import Yesod.Definitions import Yesod.Handler import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe) import Web.Mime @@ -153,7 +154,9 @@ toWaiApp' y resource session env = do responseToWaiResponse res getMethod :: (String -> YesodApp y) -> YesodApp y -getMethod = error "FIXME: getMethod" +getMethod f eh req cts = + let m = B8.unpack $ W.methodToBS $ W.requestMethod $ reqWaiRequest req + in f m eh req cts cleanupSegment :: B.ByteString -> String cleanupSegment = error "FIXME: cleanupSegment" From c181fd624e254b52fbd094d1999bd98ee96bab10 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 12:58:48 -0700 Subject: [PATCH 182/624] Wrote cleanupSegments --- Yesod/Yesod.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 47cac882..2480b44e 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -21,7 +21,8 @@ import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe) import Web.Mime import Web.Encodings (parseHttpAccept) -import Web.Routes (Site (..), encodePathInfo) +import Web.Routes (Site (..), encodePathInfo, decodePathInfo) +import Data.List (intercalate) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -141,7 +142,7 @@ toWaiApp' :: Yesod y toWaiApp' y resource session env = do let site = getSite getMethod (badMethod y) y types = httpAccept env - pathSegments = map cleanupSegment resource + pathSegments = cleanupSegments resource eurl = parsePathSegments site pathSegments case eurl of Left _ -> error "FIXME: send 404 message" @@ -158,8 +159,8 @@ getMethod f eh req cts = let m = B8.unpack $ W.methodToBS $ W.requestMethod $ reqWaiRequest req in f m eh req cts -cleanupSegment :: B.ByteString -> String -cleanupSegment = error "FIXME: cleanupSegment" +cleanupSegments :: [B.ByteString] -> [String] +cleanupSegments = decodePathInfo . intercalate "/" . map B8.unpack httpAccept :: W.Request -> [ContentType] httpAccept = map contentTypeFromBS From 3f99bf132c68fbd03a56ead3ee1a77d97fc64dc7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 13:05:40 -0700 Subject: [PATCH 183/624] Send 404 response properly --- Yesod/Yesod.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 2480b44e..86a65762 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -144,15 +144,14 @@ toWaiApp' y resource session env = do types = httpAccept env pathSegments = cleanupSegments resource eurl = parsePathSegments site pathSegments - case eurl of - Left _ -> error "FIXME: send 404 message" - Right url -> do - rr <- parseWaiRequest env session - onRequest y rr - let render u = approot y ++ '/' - : encodePathInfo (formatPathSegments site u) - res <- handleSite site render url errorHandler rr types - responseToWaiResponse res + render u = approot y ++ '/' + : encodePathInfo (formatPathSegments site u) + rr <- parseWaiRequest env session + onRequest y rr + let ya = case eurl of + Left _ -> runHandler (errorHandler NotFound) y render + Right url -> handleSite site render url + ya errorHandler rr types >>= responseToWaiResponse getMethod :: (String -> YesodApp y) -> YesodApp y getMethod f eh req cts = From b0e5cf56e524343391388c50441498a19fc95f55 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 13:41:32 -0700 Subject: [PATCH 184/624] Fixed helloworld --- Yesod/Definitions.hs | 5 +---- Yesod/Yesod.hs | 11 +++++++---- examples/helloworld.lhs | 17 +++++++++++------ 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 6c7238f1..c1e1d196 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -15,8 +15,7 @@ -- --------------------------------------------------------- module Yesod.Definitions - ( Resource - , Approot + ( Approot , Language , Location (..) , showLocation @@ -31,8 +30,6 @@ module Yesod.Definitions 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. diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 86a65762..b506b184 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -67,8 +67,6 @@ class YesodSite a => Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () - badMethod :: a -> YesodApp a -- FIXME include in errorHandler - -- | An absolute URL to the root of the application. Do not include -- trailing slash. approot :: a -> Approot @@ -140,14 +138,15 @@ toWaiApp' :: Yesod y -> W.Request -> IO W.Response toWaiApp' y resource session env = do - let site = getSite getMethod (badMethod y) y + let site = getSite getMethod badMethod y types = httpAccept env - pathSegments = cleanupSegments resource + pathSegments = filter (not . null) $ cleanupSegments resource eurl = parsePathSegments site pathSegments render u = approot y ++ '/' : encodePathInfo (formatPathSegments site u) rr <- parseWaiRequest env session onRequest y rr + print pathSegments let ya = case eurl of Left _ -> runHandler (errorHandler NotFound) y render Right url -> handleSite site render url @@ -179,3 +178,7 @@ basicHandler port app = do putStrLn $ "http://localhost:" ++ show port ++ "/" SS.run port app Just _ -> CGI.run app + +badMethod :: YesodApp y +badMethod _ _ _ = return $ Response W.Status405 [] TypePlain + $ cs "Method not supported" diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index a676612a..beb022ca 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -1,18 +1,23 @@ \begin{code} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} import Yesod import Network.Wai.Handler.SimpleServer +import qualified Web.Routes.Quasi data HelloWorld = HelloWorld -instance Yesod HelloWorld where - resources = [$mkResources| -/: - Get: helloWorld + +mkYesod "HelloWorld" [$parseRoutes| +/ Home GET |] -helloWorld :: Handler HelloWorld ChooseRep -helloWorld = applyLayout' "Hello World" $ cs "Hello world!" +instance Yesod HelloWorld where + approot _ = "http://localhost:3000" + +getHome :: Handler HelloWorld ChooseRep +getHome = applyLayout' "Hello World" $ cs "Hello world!" main :: IO () main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000 From ef3e7cc5383ec0b76a8ad69a51773ff99da9be16 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 23:14:35 -0700 Subject: [PATCH 185/624] Integrated Hamlet --- Yesod/Yesod.hs | 52 ++++++++++++++++++++++++++++++++++++++++++++------ yesod.cabal | 3 ++- 2 files changed, 48 insertions(+), 7 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b506b184..e186d019 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuasiQuotes #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) @@ -23,6 +24,8 @@ import Web.Mime import Web.Encodings (parseHttpAccept) import Web.Routes (Site (..), encodePathInfo, decodePathInfo) import Data.List (intercalate) +import Text.Hamlet hiding (Content, Html) -- FIXME do not export +import qualified Text.Hamlet as Hamlet import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -41,6 +44,19 @@ class YesodSite y where -> y -> Site (Routes y) (YesodApp y) +data PageContent url = PageContent + { pageTitle :: Hamlet url IO Hamlet.Html + , pageHead :: Hamlet url IO () + , pageBody :: Hamlet url IO () + } + +simpleContent :: String -> Hamlet.Html -> PageContent url +simpleContent title body = PageContent + { pageTitle = return $ Unencoded $ cs title + , pageHead = return () + , pageBody = outputHtml body + } + class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -57,11 +73,18 @@ class YesodSite a => Yesod a where -- | Applies some form of layout to and <body> contents of a page. applyLayout :: a + -> PageContent (Routes a) -> Request - -> String -- ^ title - -> Html -- ^ body - -> Content - applyLayout _ _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc) + -> Hamlet (Routes a) IO () + applyLayout _ p _ = [$hamlet| +<!DOCTYPE html> +%html + %head + %title $pageTitle$ + ^pageHead^ + %body + ^pageBody^ +|] p -- | Gets called at the beginning of each request. Useful for logging. onRequest :: a -> Request -> IO () @@ -77,10 +100,12 @@ applyLayout' :: Yesod y -> Html -> Handler y ChooseRep applyLayout' t b = do + let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment $ cs b y <- getYesod rr <- getRequest + content <- hamletToContent $ applyLayout y pc rr return $ chooseRep - [ (TypeHtml, applyLayout y rr t b) + [ (TypeHtml, content) ] -- | A convenience wrapper around 'applyLayout' which provides a JSON @@ -90,13 +115,28 @@ applyLayoutJson :: Yesod y -> 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, applyLayout y rr t $ cs b) + [ (TypeHtml, htmlcontent) , (TypeJson, cs $ unJsonDoc $ cs b) ] +hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content +hamletToContent h = do + render <- getUrlRender + return $ ContentEnum $ go render + where + go render iter seed = do + res <- runHamlet h render seed $ iter' iter + case res of + Left x -> return $ Left x + Right ((), x) -> return $ Right x + iter' iter seed text = iter seed $ cs text + getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod diff --git a/yesod.cabal b/yesod.cabal index 8a4843b0..3f8ab007 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -60,7 +60,8 @@ library failure >= 0.0.0 && < 0.1, safe-failure >= 0.4.0 && < 0.5, web-routes >= 0.20 && < 0.21, - web-routes-quasi >= 0.0 && < 0.1 + web-routes-quasi >= 0.0 && < 0.1, + hamlet >= 0.0 && < 0.1 exposed-modules: Yesod Yesod.Request Yesod.Response From c5841f762d2f254bc38ff50b5241a9d6fd6bfb28 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 11 Apr 2010 23:23:29 -0700 Subject: [PATCH 186/624] Fixed hellotemplate example --- examples/hellotemplate.lhs | 25 ++++++++++++++----------- examples/helloworld.lhs | 1 - 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index 3e8d9c7c..ead588f3 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -1,29 +1,32 @@ \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>" -instance Yesod HelloWorld where - resources = [$mkResources| -/: - Get: helloWorld -/groups: - Get: helloGroup -|] -helloWorld :: Handler HelloWorld RepHtml -helloWorld = templateHtml "template" $ return +getHome :: Handler HelloWorld RepHtml +getHome = 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 -> +getGroup :: YesodTemplate y => Handler y RepHtmlJson +getGroup = templateHtmlJson "real-template" (cs "bar") $ \ho -> return . setHtmlAttrib "foo" ho main :: IO () diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index beb022ca..f7111808 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -5,7 +5,6 @@ import Yesod import Network.Wai.Handler.SimpleServer -import qualified Web.Routes.Quasi data HelloWorld = HelloWorld From bf165609f24c6a81f2be35f0bbb69f460a4afb78 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 11 Apr 2010 23:43:50 -0700 Subject: [PATCH 187/624] Remaining examples compile --- Yesod/Resource.hs | 4 +-- examples/fact.lhs | 31 +++++++++++----------- examples/i18n.hs | 23 +++++++++-------- examples/pretty-yaml.hs | 22 +++++++++------- examples/tweedle.lhs | 57 ++++++++++++++++++++++------------------- 5 files changed, 73 insertions(+), 64 deletions(-) diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index fd8c5dd9..5476d16f 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -16,8 +16,6 @@ mkYesod name res = do let yaname = mkName $ name ++ "YesodApp" let ya = TySynD yaname [] $ ConT ''YesodApp `AppT` ConT name' let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let hand = TySynD (mkName $ name ++ "Handler") [PlainTV $ mkName "a"] - $ ConT ''Handler `AppT` ConT name' `AppT` VarT (mkName "a") let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] @@ -26,4 +24,4 @@ mkYesod name res = do name' "runHandler" res - return $ ya : tySyn : hand : yes : decs + return $ ya : tySyn : yes : decs diff --git a/examples/fact.lhs b/examples/fact.lhs index aa2012e4..36f7a870 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -1,4 +1,8 @@ +FIXME documentation is out of date in a few places. + > {-# LANGUAGE QuasiQuotes #-} +> {-# LANGUAGE TemplateHaskell #-} +> {-# LANGUAGE TypeFamilies #-} I in general recommend type signatures for everything. However, I wanted to show in this example how it is possible to get away without the @@ -35,7 +39,6 @@ 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: @@ -53,20 +56,18 @@ 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} +> $(mkYesod "Fact" [$parseRoutes| +> / Index GET +> /#num FactR GET +> /fact FactRedirect GET +> |]) + +> instance Yesod Fact where +> approot _ = "http://localhost:3000" This does what it looks like: serves a static HTML file. -> index = sendFile TypeHtml "examples/fact.html" >> return () +> getIndex = sendFile TypeHtml "examples/fact.html" >> return () HtmlObject is a funny beast. Basically, it allows multiple representations of data, all with HTML entities escaped properly. These representations include: @@ -78,7 +79,7 @@ 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). -> fact i = applyLayoutJson "Factorial result" $ cs +> getFactR i = applyLayoutJson "Factorial result" $ cs > [ ("input", show i) > , ("result", show $ product [1..fromIntegral i :: Integer]) > ] @@ -87,8 +88,8 @@ 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 +> getFactRedirect :: Handler y () +> getFactRedirect = do > res <- runFormPost $ catchFormError > $ checkInteger > $ required diff --git a/examples/i18n.hs b/examples/i18n.hs index 27568b90..ae0651d4 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -1,19 +1,22 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + import Yesod import Network.Wai.Handler.SimpleServer data I18N = I18N -instance Yesod I18N where - resources = [$mkResources| -/: - Get: homepage -/set/$lang: - Get: setLang +mkYesod "I18N" [$parseRoutes| +/ Homepage GET +/set/$lang SetLang GET |] -homepage :: Handler y [(ContentType, Content)] -homepage = do +instance Yesod I18N where + approot _ = "http://localhost:3000" + +getHomepage :: Handler y [(ContentType, Content)] +getHomepage = do ls <- languages let hello = chooseHello ls return [(TypePlain, cs hello :: Content)] @@ -24,8 +27,8 @@ chooseHello ("he":_) = "שלום" chooseHello ("es":_) = "Hola" chooseHello (_:rest) = chooseHello rest -setLang :: String -> Handler y () -setLang lang = do +getSetLang :: String -> Handler y () +getSetLang lang = do addCookie 1 langKey lang redirect RedirectTemporary "/" diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index 155b9506..892a2883 100644 --- a/examples/pretty-yaml.hs +++ b/examples/pretty-yaml.hs @@ -1,4 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + import Yesod import Data.Object.Yaml import Network.Wai.Handler.SimpleServer @@ -7,21 +10,22 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L data PY = PY TemplateGroup + +mkYesod "PY" [$parseRoutes| +/ Homepage GET POST +|] + instance YesodTemplate PY where getTemplateGroup (PY tg) = tg defaultTemplateAttribs _ _ = return instance Yesod PY where - resources = [$mkResources| -/: - GET: homepageH - POST: showYamlH -|] + approot _ = "http://localhost:3000" -homepageH :: Handler PY RepHtml -homepageH = templateHtml "pretty-yaml" return +getHomepage :: Handler PY RepHtml +getHomepage = templateHtml "pretty-yaml" return -showYamlH :: Handler PY RepHtmlJson -showYamlH = do +postHomepage :: Handler PY RepHtmlJson +postHomepage = do rr <- getRequest (_, files) <- liftIO $ reqRequestBody rr fi <- case lookup "yaml" files of diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs index 05a73f28..7e1cf058 100755 --- a/examples/tweedle.lhs +++ b/examples/tweedle.lhs @@ -1,5 +1,10 @@ #!/usr/bin/env runhaskell + +FIXME documentation out of date. + > {-# LANGUAGE QuasiQuotes #-} +> {-# LANGUAGE TemplateHaskell #-} +> {-# LANGUAGE TypeFamilies #-} While coming up on the first release of Yesod, I realized I needed a nice, comprehensive tutorial. I didn't want to do the typical blog example, since it's so trite. I considered doing a Reddit or Twitter clone (the former became a bit of a meme a few weeks ago), but then I needed to set up a bug tracker for some commercial projects I was working on, and I decided that it would be a great example program. @@ -23,6 +28,7 @@ Anyway, here's the import list. > import Data.Text (pack) > import Control.Applicative ((<$>), (<*>)) > import Data.Maybe (fromMaybe) +> import qualified Network.Wai as W One of the goals of Yesod is to make it work with the compiler to help you program. Instead of configuration files, it uses typeclasses to both change default behavior and enable extra features. An example of the former is error pages, while an example of the latter is authentication. @@ -159,8 +165,6 @@ Well, that was a *lot* of boilerplate code that had nothing to do with web progr 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. @@ -174,27 +178,21 @@ Instead of using regular expressions to handle the URL mapping, Yesod uses resou 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| +> mkYesod "Tweedle" [$parseRoutes| Now we need to figure out all of the resources available in our application. We'll need a homepage: -> /: -> GET: homepageH +> / Homepage GET We will also need to allow authentication. We use the slurp pattern here and accept all request methods. The authHandler method (in the Yesod.Helpers.Auth module) will handle everything itself. -> /auth/*: authHandler +> /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 +> /category/#id CategoryH GET PUT +> /category/#id/issues Issues PUT +> /issue/#id IssueH GET PUT > |] So if you make a PUT request to "/category/5", you will be creating a subcategory of category 5. "GET /issue/27/" will display details on issue 27. This is all we need. @@ -216,15 +214,15 @@ Now the compiler is telling us that there's no instance of YesodAuth for Tweedle Running that tells us that we're missing a YesodApproot instance as well. That's easy enough to fix: -> instance YesodApproot Tweedle where +> instance Yesod Tweedle where > approot (Tweedle settings _ _) = sApproot settings Congratulations, you have a working web application! Gratned, it doesn't actually do much yet, but you *can* use it to log in via openid. Just go to http://localhost:3000/auth/openid/. Now it's time to implement the real code here. We'll start with the homepage. For this program, I just want the homepage to redirect to the main category (which will be category 0). So let's create that redirect: -> homepageH :: Handler Tweedle () -> homepageH = do +> getHomepage :: Handler Tweedle () +> getHomepage = do > ar <- getApproot > redirect RedirectPermanent $ ar ++ "category/0/" @@ -234,11 +232,11 @@ Now the category details function. We're just going to have two lists: subcatego 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 +> getCategoryH :: Integer -> Handler Tweedle RepHtmlJson That function signature tells us a lot: the parameter is the category ID, and we'll be returning something that has both an HTML and JSON representation. -> categoryDetailsH catId = do +> getCategoryH catId = do getYesod returns our Tweedle data type. Remember, we wrapped it in an MVar; since this is a read-only operation, will unwrap the MVar immediately. @@ -291,8 +289,8 @@ Now we actually get some output! I'm not going to cover the syntax of string tem 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 +> putCategoryH :: Integer -> Handler Tweedle () +> putCategoryH parentid = do Yesod uses a formlets-style interface for parsing submissions. This following line says we want a parameter named catname, which precisely one value (required) and that value must have a non-zero length (notEmpty). @@ -324,8 +322,8 @@ And here's the database modification code we need. Once again, this is not web-s Next is creating an issue. This is almost identical to creating a category. -> createIssueH :: Integer -> Handler Tweedle () -> createIssueH catid = do +> putIssues :: Integer -> Handler Tweedle () +> putIssues catid = do > issuename <- runFormPost $ notEmpty $ required $ input "issuename" > newid <- modifyDB $ createIssue catid issuename > ar <- getApproot @@ -345,8 +343,8 @@ Next is creating an issue. This is almost identical to creating a category. 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 +> getIssueH :: Integer -> Handler Tweedle RepHtmlJson +> getIssueH iid = do > Tweedle _ mvarTopCat _ <- getYesod > topcat <- liftIO $ readMVar mvarTopCat > (cat, issue) <- maybe notFound return $ findIssue iid topcat @@ -384,8 +382,8 @@ And now the supporting model code. This function returns the requested Issue alo 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 +> putIssueH :: Integer -> Handler Tweedle () +> putIssueH issueid = do > ident <- authIdentifier > (status, priority, text) <- runFormPost $ > (,,) @@ -405,3 +403,8 @@ Cool, just one function left! This should probably all make sense by now. Notice > go (Issue name messages iid) > | iid == issueid = Issue name (messages ++ [message]) iid > | otherwise = Issue name messages iid + +> handleAuthHandler :: [String] -> Handler Tweedle ChooseRep +> handleAuthHandler pieces = do +> m <- W.requestMethod `fmap` waiRequest +> authHandler m pieces From 343b5a8b80d7eb7c593d54b7316d7a35ea365249 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 12 Apr 2010 00:02:39 -0700 Subject: [PATCH 188/624] Added hamlet example --- .gitignore | 2 ++ Yesod/Helpers/Auth.hs | 2 ++ Yesod/Yesod.hs | 16 +++++++++++++++- examples/hamlet.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 61 insertions(+), 1 deletion(-) create mode 100644 examples/hamlet.hs diff --git a/.gitignore b/.gitignore index c17db52f..00255d26 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ dist *.swp client_session_key.aes +*.hi +*.o diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 105ab62f..2e4b643e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -23,6 +23,8 @@ module Yesod.Helpers.Auth , redirectLogin ) where +-- FIXME write as subsite + import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index e186d019..3daf4687 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,6 +8,8 @@ module Yesod.Yesod , getApproot , toWaiApp , basicHandler + , hamletToContent -- FIXME put elsewhere + , hamletToRepHtml ) where import Data.Object.Html @@ -183,7 +185,7 @@ toWaiApp' y resource session env = do pathSegments = filter (not . null) $ cleanupSegments resource eurl = parsePathSegments site pathSegments render u = approot y ++ '/' - : encodePathInfo (formatPathSegments site u) + : encodePathInfo (fixSegs $ formatPathSegments site u) rr <- parseWaiRequest env session onRequest y rr print pathSegments @@ -222,3 +224,15 @@ basicHandler port app = do badMethod :: YesodApp y badMethod _ _ _ = return $ Response W.Status405 [] TypePlain $ cs "Method not supported" + +hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml +hamletToRepHtml h = do + c <- hamletToContent h + return $ RepHtml c + +fixSegs :: [String] -> [String] +fixSegs [] = [] +fixSegs [x] + | any (== '.') x = [x] + | otherwise = [x, ""] -- append trailing slash +fixSegs (x:xs) = x : fixSegs xs diff --git a/examples/hamlet.hs b/examples/hamlet.hs new file mode 100644 index 00000000..8c8a6c0e --- /dev/null +++ b/examples/hamlet.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +import Yesod +import Network.Wai.Handler.SimpleServer +import Text.Hamlet + +data Ham = Ham + +mkYesod "Ham" [$parseRoutes| +/ Homepage GET +/#another Another GET +|] + +instance Yesod Ham where + approot _ = "http://localhost:3000" + +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 = [$hamlet| +%a!href=@nextLink@ Next page +|] + +getHomepage :: Handler Ham RepHtml +getHomepage = hamletToRepHtml $ template $ nl $ Another 1 + +getAnother :: Integer -> Handler Ham RepHtml +getAnother i = hamletToRepHtml $ template $ nl next + where + next = case i of + 5 -> Homepage + _ -> Another $ i + 1 + +main :: IO () +main = do + putStrLn "Running..." + toWaiApp Ham >>= run 3000 From 4a8f674ba110bb8a525b88f1e980e1f31f02144e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 12 Apr 2010 21:56:32 -0700 Subject: [PATCH 189/624] Minor Hamlet changes --- Yesod/Yesod.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3daf4687..c5b891e4 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -26,8 +26,8 @@ import Web.Mime import Web.Encodings (parseHttpAccept) import Web.Routes (Site (..), encodePathInfo, decodePathInfo) import Data.List (intercalate) -import Text.Hamlet hiding (Content, Html) -- FIXME do not export -import qualified Text.Hamlet as Hamlet +import Text.Hamlet +import Text.Hamlet.Monad (outputHtml) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -47,12 +47,12 @@ class YesodSite y where -> Site (Routes y) (YesodApp y) data PageContent url = PageContent - { pageTitle :: Hamlet url IO Hamlet.Html + { pageTitle :: Hamlet url IO HtmlContent , pageHead :: Hamlet url IO () , pageBody :: Hamlet url IO () } -simpleContent :: String -> Hamlet.Html -> PageContent url +simpleContent :: String -> HtmlContent -> PageContent url simpleContent title body = PageContent { pageTitle = return $ Unencoded $ cs title , pageHead = return () @@ -79,7 +79,7 @@ class YesodSite a => Yesod a where -> Request -> Hamlet (Routes a) IO () applyLayout _ p _ = [$hamlet| -<!DOCTYPE html> +!!! %html %head %title $pageTitle$ From 4163c55e0d9022751b448678b669babc409a7616 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Apr 2010 20:54:58 -0700 Subject: [PATCH 190/624] Match changes in web-routes-quasi --- Yesod/Handler.hs | 32 +++++++++++++++------------- Yesod/Helpers/Static.hs | 46 +++++++++++++++++++++++++++-------------- Yesod/Resource.hs | 6 ++---- Yesod/Response.hs | 1 + Yesod/Yesod.hs | 37 ++++++++++++++------------------- yesod.cabal | 2 +- 6 files changed, 68 insertions(+), 56 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b5a8853a..3eaba5db 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -25,12 +25,13 @@ module Yesod.Handler , getUrlRender , runHandler , liftIO - , YesodApp + , YesodApp (..) , Routes -- * Special handlers , redirect , sendFile , notFound + , badMethod , permissionDenied , invalidArgs -- * Setting headers @@ -59,10 +60,13 @@ type family Routes y data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String) -type YesodApp yesod = (ErrorResponse -> Handler yesod ChooseRep) - -> Request - -> [ContentType] - -> IO Response +newtype YesodApp = YesodApp + { unYesodApp + :: (ErrorResponse -> YesodApp) + -> Request + -> [ContentType] + -> IO Response + } ------ Handler monad newtype Handler yesod a = Handler { @@ -104,8 +108,8 @@ getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod) getUrlRender :: Handler yesod (Routes yesod -> String) getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r) -runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp yesod -runHandler handler y render eh rr cts = do +runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp +runHandler handler y render = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) @@ -113,7 +117,7 @@ runHandler handler y render eh rr cts = do (unHandler handler $ HandlerData rr y render) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- runHandler (eh e) y render safeEh rr cts + Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c let sendFile' ct fp = do @@ -131,13 +135,10 @@ runHandler handler y render eh rr cts = do (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c -safeEh :: ErrorResponse -> Handler yesod ChooseRep -safeEh er = do +safeEh :: ErrorResponse -> YesodApp +safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ chooseRep - ( Tag "title" [] $ cs "Internal Server Error" - , toHtmlObject "Internal server error" - ) + return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error" ------ Special handlers specialResponse :: SpecialResponse -> Handler yesod a @@ -154,6 +155,9 @@ sendFile ct = specialResponse . SendFile ct notFound :: Failure ErrorResponse m => m a notFound = failure NotFound +badMethod :: Failure ErrorResponse m => m a +badMethod = failure BadMethod + permissionDenied :: Failure ErrorResponse m => m a permissionDenied = failure PermissionDenied diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index ecb7d457..010f0647 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static @@ -17,9 +18,12 @@ -- --------------------------------------------------------- module Yesod.Helpers.Static - ( serveStatic - , FileLookup + ( FileLookup , fileLookupDir + , siteStaticRoutes + , StaticRoutes + , staticArgs + , Static ) where import System.Directory (doesFileExist) @@ -27,38 +31,50 @@ import Control.Monad import Yesod import Data.List (intercalate) +import Network.Wai type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) +data Static = Static FileLookup + +staticArgs :: FileLookup -> Static +staticArgs = Static + +$(mkYesod "Static" [$parseRoutes| +/* StaticRoute GET +|]) + -- | 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 +fileLookupDir :: FilePath -> Static +fileLookupDir dir = Static $ \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 + wai <- waiRequest + when (requestMethod wai /= GET) badMethod 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 + where + isUnsafe [] = True + isUnsafe ('.':_) = True + isUnsafe _ = False + +getStaticRoute :: [String] -> Handler Static [(ContentType, Content)] +getStaticRoute fp = do + Static fl <- getYesod + getStatic fl fp diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 5476d16f..0fd78c43 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -13,15 +13,13 @@ import Yesod.Yesod mkYesod :: String -> [Resource] -> Q [Dec] mkYesod name res = do let name' = mkName name - let yaname = mkName $ name ++ "YesodApp" - let ya = TySynD yaname [] $ ConT ''YesodApp `AppT` ConT name' let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] decs <- createRoutes (name ++ "Routes") - yaname + ''YesodApp name' "runHandler" res - return $ ya : tySyn : yes : decs + return $ tySyn : yes : decs diff --git a/Yesod/Response.hs b/Yesod/Response.hs index f702bffd..ad4311ad 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -201,6 +201,7 @@ data ErrorResponse = | InternalError String | InvalidArgs [(ParamName, ParamError)] | PermissionDenied + | BadMethod deriving (Show, Eq) getStatus :: ErrorResponse -> W.Status diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c5b891e4..f63c89b0 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,7 +17,7 @@ import Data.Object.Json (unJsonDoc) import Yesod.Response import Yesod.Request import Yesod.Definitions -import Yesod.Handler +import Yesod.Handler hiding (badMethod) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 @@ -41,10 +41,7 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) class YesodSite y where - getSite :: ((String -> YesodApp y) -> YesodApp y) -- ^ get the method - -> YesodApp y -- ^ bad method - -> y - -> Site (Routes y) (YesodApp y) + getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp) data PageContent url = PageContent { pageTitle :: Hamlet url IO HtmlContent @@ -70,8 +67,8 @@ class YesodSite a => Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: ErrorResponse -> Handler a ChooseRep - errorHandler = defaultErrorHandler + errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep + errorHandler _ = defaultErrorHandler -- | Applies some form of layout to <title> and <body> contents of a page. applyLayout :: a @@ -142,9 +139,7 @@ hamletToContent h = do getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod -defaultErrorHandler :: Yesod y - => ErrorResponse - -> Handler y ChooseRep +defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ cs $ toHtmlObject @@ -161,6 +156,8 @@ defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ cs $ toHtmlObject [ ("Internal server error", e) ] +defaultErrorHandler BadMethod = + applyLayout' "Bad Method" $ cs "Method Not Supported" toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do @@ -180,7 +177,8 @@ toWaiApp' :: Yesod y -> W.Request -> IO W.Response toWaiApp' y resource session env = do - let site = getSite getMethod badMethod y + let site = getSite + method = B8.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource eurl = parsePathSegments site pathSegments @@ -190,14 +188,10 @@ toWaiApp' y resource session env = do onRequest y rr print pathSegments let ya = case eurl of - Left _ -> runHandler (errorHandler NotFound) y render - Right url -> handleSite site render url - ya errorHandler rr types >>= responseToWaiResponse - -getMethod :: (String -> YesodApp y) -> YesodApp y -getMethod f eh req cts = - let m = B8.unpack $ W.methodToBS $ W.requestMethod $ reqWaiRequest req - in f m eh req cts + Left _ -> runHandler (errorHandler y NotFound) y render + Right url -> handleSite site render url method badMethod y + let eh er = runHandler (errorHandler y er) y render + unYesodApp ya eh rr types >>= responseToWaiResponse cleanupSegments :: [B.ByteString] -> [String] cleanupSegments = decodePathInfo . intercalate "/" . map B8.unpack @@ -221,9 +215,8 @@ basicHandler port app = do SS.run port app Just _ -> CGI.run app -badMethod :: YesodApp y -badMethod _ _ _ = return $ Response W.Status405 [] TypePlain - $ cs "Method not supported" +badMethod :: YesodApp +badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml hamletToRepHtml h = do diff --git a/yesod.cabal b/yesod.cabal index 3f8ab007..99d53f04 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -59,7 +59,7 @@ library template-haskell, failure >= 0.0.0 && < 0.1, safe-failure >= 0.4.0 && < 0.5, - web-routes >= 0.20 && < 0.21, + web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.0 && < 0.1, hamlet >= 0.0 && < 0.1 exposed-modules: Yesod From aa2cc2f0eb6e37e1b03dacd404f83ead7ebeeb1b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Apr 2010 21:19:17 -0700 Subject: [PATCH 191/624] Added static example --- examples/static.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 examples/static.hs diff --git a/examples/static.hs b/examples/static.hs new file mode 100644 index 00000000..7f8abb5a --- /dev/null +++ b/examples/static.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +import Yesod +import Yesod.Helpers.Static +import Network.Wai.Handler.SimpleServer + +data StaticExample = StaticExample + +mkYesod "StaticExample" [$parseRoutes| +/ Root StaticRoutes siteStaticRoutes getStaticSite +|] + +instance Yesod StaticExample where + approot _ = "http://localhost:3000" + +getStaticSite :: StaticExample -> Static +getStaticSite _ = fileLookupDir "dist/doc/html/yesod" + +main :: IO () +main = do + putStrLn "Running..." + toWaiApp StaticExample >>= run 3000 From 572718bbd699c42918b2f70a6070cf0c2420dc3e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 14 Apr 2010 08:49:15 -0700 Subject: [PATCH 192/624] Split hamlet code into separate module --- Yesod/Hamlet.hs | 47 +++++++++++++++++++++++++++++++++++++++++ Yesod/Helpers/Static.hs | 1 + Yesod/Yesod.hs | 35 +----------------------------- yesod.cabal | 1 + 4 files changed, 50 insertions(+), 34 deletions(-) create mode 100644 Yesod/Hamlet.hs diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs new file mode 100644 index 00000000..3a66c7cf --- /dev/null +++ b/Yesod/Hamlet.hs @@ -0,0 +1,47 @@ +module Yesod.Hamlet + ( hamletToContent + , hamletToRepHtml + , PageContent (..) + , Hamlet + , hamlet + , simpleContent + , HtmlContent (..) + ) + where + +import Text.Hamlet +import Text.Hamlet.Monad (outputHtml) +import Yesod.Response +import Yesod.Handler +import Data.Text (pack) +import Data.Convertible.Text (cs) + +data PageContent url = PageContent + { pageTitle :: IO HtmlContent + , pageHead :: Hamlet url IO () + , 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 + return $ ContentEnum $ go render + where + go render iter seed = do + res <- runHamlet h render seed $ iter' iter + case res of + Left x -> return $ Left x + Right ((), x) -> return $ Right x + iter' iter seed text = iter seed $ cs text + +hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml +hamletToRepHtml h = do + c <- hamletToContent h + return $ RepHtml c diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 010f0647..9f1b6174 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -40,6 +40,7 @@ data Static = Static FileLookup staticArgs :: FileLookup -> Static staticArgs = Static +-- FIXME bug in web-routes-quasi generates warning here $(mkYesod "Static" [$parseRoutes| /* StaticRoute GET |]) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f63c89b0..34753fdb 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,8 +8,6 @@ module Yesod.Yesod , getApproot , toWaiApp , basicHandler - , hamletToContent -- FIXME put elsewhere - , hamletToRepHtml ) where import Data.Object.Html @@ -17,6 +15,7 @@ import Data.Object.Json (unJsonDoc) import Yesod.Response import Yesod.Request import Yesod.Definitions +import Yesod.Hamlet import Yesod.Handler hiding (badMethod) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 @@ -26,8 +25,6 @@ import Web.Mime import Web.Encodings (parseHttpAccept) import Web.Routes (Site (..), encodePathInfo, decodePathInfo) import Data.List (intercalate) -import Text.Hamlet -import Text.Hamlet.Monad (outputHtml) import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath @@ -43,19 +40,6 @@ import System.Environment (getEnvironment) class YesodSite y where getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp) -data PageContent url = PageContent - { pageTitle :: Hamlet url IO HtmlContent - , pageHead :: Hamlet url IO () - , pageBody :: Hamlet url IO () - } - -simpleContent :: String -> HtmlContent -> PageContent url -simpleContent title body = PageContent - { pageTitle = return $ Unencoded $ cs title - , pageHead = return () - , pageBody = outputHtml body - } - class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -124,18 +108,6 @@ applyLayoutJson t b = do , (TypeJson, cs $ unJsonDoc $ cs b) ] -hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content -hamletToContent h = do - render <- getUrlRender - return $ ContentEnum $ go render - where - go render iter seed = do - res <- runHamlet h render seed $ iter' iter - case res of - Left x -> return $ Left x - Right ((), x) -> return $ Right x - iter' iter seed text = iter seed $ cs text - getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod @@ -218,11 +190,6 @@ basicHandler port app = do badMethod :: YesodApp badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts -hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml -hamletToRepHtml h = do - c <- hamletToContent h - return $ RepHtml c - fixSegs :: [String] -> [String] fixSegs [] = [] fixSegs [x] diff --git a/yesod.cabal b/yesod.cabal index 99d53f04..f9f9abee 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -67,6 +67,7 @@ library Yesod.Response Yesod.Definitions Yesod.Form + Yesod.Hamlet Yesod.Handler Yesod.Resource Yesod.Yesod From 5f7668334a6b9f47e7031ee89d688dd52faf02e8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 14 Apr 2010 12:38:58 -0700 Subject: [PATCH 193/624] Removed Data.Object.Html and Yesod.Template --- Data/Object/Html.hs | 252 ------------------------------------- Yesod.hs | 9 +- Yesod/Hamlet.hs | 48 +++++-- Yesod/Handler.hs | 9 +- Yesod/Helpers/AtomFeed.hs | 9 +- Yesod/Helpers/Auth.hs | 43 ++++--- Yesod/Helpers/Sitemap.hs | 9 +- Yesod/Helpers/Static.hs | 1 + Yesod/Request.hs | 7 +- Yesod/Response.hs | 21 +--- Yesod/Template.hs | 113 ----------------- Yesod/Yesod.hs | 104 ++++++++------- examples/fact.lhs | 5 +- examples/hamlet.hs | 3 +- examples/hellotemplate.lhs | 36 ------ examples/helloworld.lhs | 2 +- examples/pretty-yaml.hs | 43 +++++-- examples/static.hs | 1 + examples/tweedle.lhs | 4 +- yesod.cabal | 10 +- 20 files changed, 197 insertions(+), 532 deletions(-) delete mode 100644 Data/Object/Html.hs delete mode 100644 Yesod/Template.hs delete mode 100644 examples/hellotemplate.lhs diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs deleted file mode 100644 index ca3fcbd7..00000000 --- a/Data/Object/Html.hs +++ /dev/null @@ -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 diff --git a/Yesod.hs b/Yesod.hs index 59fec055..29b2e1dc 100644 --- a/Yesod.hs +++ b/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) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 3a66c7cf..7b6b034b 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3eaba5db..7c55033c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -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 diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 44164438..8ab1a5f7 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -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 ] +-} diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 2e4b643e..b80907f7 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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 diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 2a29e104..95e32c22 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -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 diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 9f1b6174..7651ca62 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 1d4035fb..0b5e59cc 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -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)] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index ad4311ad..2c48a9bb 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -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'. diff --git a/Yesod/Template.hs b/Yesod/Template.hs deleted file mode 100644 index b5b7a4f5..00000000 --- a/Yesod/Template.hs +++ /dev/null @@ -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) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 34753fdb..612e3fb6 100644 --- a/Yesod/Yesod.hs +++ b/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 [] = [] diff --git a/examples/fact.lhs b/examples/fact.lhs index 36f7a870..85af7b54 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -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 diff --git a/examples/hamlet.hs b/examples/hamlet.hs index 8c8a6c0e..268b3909 100644 --- a/examples/hamlet.hs +++ b/examples/hamlet.hs @@ -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 |] diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs deleted file mode 100644 index ead588f3..00000000 --- a/examples/hellotemplate.lhs +++ /dev/null @@ -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} diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index f7111808..052d891d 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -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 diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index 892a2883..c6080b84 100644 --- a/examples/pretty-yaml.hs +++ b/examples/pretty-yaml.hs @@ -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 diff --git a/examples/static.hs b/examples/static.hs index 7f8abb5a..bdc0557b 100644 --- a/examples/static.hs +++ b/examples/static.hs @@ -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 diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs index 7e1cf058..00bfe98c 100755 --- a/examples/tweedle.lhs +++ b/examples/tweedle.lhs @@ -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. diff --git a/yesod.cabal b/yesod.cabal index f9f9abee..2f4b8da8 100644 --- a/yesod.cabal +++ b/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) From e9a8b435956686b96158290b249a566d2bdc7f10 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 16 Apr 2010 11:58:33 -0700 Subject: [PATCH 194/624] Recent hamlet changes --- Yesod/Hamlet.hs | 14 ++++++-------- Yesod/Helpers/Auth.hs | 6 +++--- Yesod/Yesod.hs | 27 +++++++++------------------ examples/hamlet.hs | 11 ++++------- examples/pretty-yaml.hs | 8 ++++---- 5 files changed, 26 insertions(+), 40 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 7b6b034b..1e606cbc 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -20,9 +20,10 @@ import Yesod.Response import Yesod.Handler import Data.Convertible.Text import Data.Object +import Control.Arrow ((***)) data PageContent url = PageContent - { pageTitle :: IO HtmlContent + { pageTitle :: HtmlContent , pageHead :: Hamlet url IO () , pageBody :: Hamlet url IO () } @@ -54,21 +55,18 @@ instance Monad m %ul $forall s' s %li ^s^|] - s' _ = return $ fromList $ map cs s + s' _ = 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 + %dt $pair.fst$ + %dd ^pair.snd^|] + pairs _ = map (cs *** cs) m 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 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index b80907f7..06944666 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -113,9 +113,9 @@ authOpenidForm = do 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 + hasMessage = not . null + message [] = cs "" + message (m:_) = cs m template = [$hamlet| $if hasMessage %p.message $message$ diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 612e3fb6..87369a16 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,7 +17,7 @@ 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 Control.Arrow ((***)) import Data.Maybe (fromMaybe) import Web.Mime @@ -83,7 +83,7 @@ simpleApplyLayout :: Yesod y -> Handler y ChooseRep simpleApplyLayout t b = do let pc = PageContent - { pageTitle = return $ Unencoded $ cs t + { pageTitle = cs t , pageHead = return () , pageBody = b } @@ -105,7 +105,7 @@ defaultErrorHandler NotFound = do %p $helper$ |] r where - helper = return . Unencoded . cs . W.pathInfo + helper = Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = simpleApplyLayout "Permission Denied" $ [$hamlet| %h1 Permission denied|] () @@ -114,30 +114,21 @@ defaultErrorHandler (InvalidArgs ia) = %h1 Invalid Arguments %dl $forall ias pair - %dt $pair.key$ - %dd $pair.val$ + %dt $pair.fst$ + %dd $pair.snd$ |] () where - ias _ = return $ fromList $ map go ia - go (k, v) = Pair (return $ Unencoded $ cs k) - (return $ Unencoded $ cs v) + ias _ = map (cs *** cs) ia defaultErrorHandler (InternalError e) = simpleApplyLayout "Internal Server Error" $ [$hamlet| %h1 Internal Server Error -%p $message$ +%p $cs$ |] 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 } +%p Method "$cs$" not supported +|] m toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do diff --git a/examples/hamlet.hs b/examples/hamlet.hs index 268b3909..447bf5dd 100644 --- a/examples/hamlet.hs +++ b/examples/hamlet.hs @@ -15,21 +15,18 @@ mkYesod "Ham" [$parseRoutes| instance Yesod Ham where approot _ = "http://localhost:3000" -data NextLink m = NextLink { nextLink :: m HamRoutes } +data NextLink = NextLink { nextLink :: HamRoutes } -nl :: Monad m => HamRoutes -> NextLink m -nl = NextLink . return - -template :: Monad m => NextLink m -> Hamlet HamRoutes m () +template :: Monad m => NextLink -> Hamlet HamRoutes m () template = [$hamlet| %a!href=@nextLink@ Next page |] getHomepage :: Handler Ham RepHtml -getHomepage = hamletToRepHtml $ template $ nl $ Another 1 +getHomepage = hamletToRepHtml $ template $ NextLink $ Another 1 getAnother :: Integer -> Handler Ham RepHtml -getAnother i = hamletToRepHtml $ template $ nl next +getAnother i = hamletToRepHtml $ template $ NextLink next where next = case i of 5 -> Homepage diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs index c6080b84..1054936b 100644 --- a/examples/pretty-yaml.hs +++ b/examples/pretty-yaml.hs @@ -36,13 +36,13 @@ template = [$hamlet| |] data TempArgs url m = TempArgs - { hasYaml :: m Bool + { hasYaml :: Bool , yaml :: Hamlet url m () } getHomepage :: Handler PY RepHtml getHomepage = hamletToRepHtml - $ template $ TempArgs (return False) (return ()) + $ template $ TempArgs False (return ()) --FIXMEpostHomepage :: Handler PY RepHtmlJson postHomepage :: Handler PY RepHtml @@ -53,13 +53,13 @@ postHomepage = do Nothing -> invalidArgs [("yaml", "Missing input")] Just x -> return x so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi - {- + {- FIXME let ho' = fmap Text to templateHtmlJson "pretty-yaml" ho' $ \ho -> return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject) -} let ho = cs (so :: StringObject) :: HtmlObject - hamletToRepHtml $ template $ TempArgs (return True) (cs ho) + hamletToRepHtml $ template $ TempArgs True (cs ho) main :: IO () main = do From 3165b253bad932c447f696771ac5ef9219ddea65 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 16 Apr 2010 14:28:59 -0700 Subject: [PATCH 195/624] Converted auth helper to subsite --- Yesod/Hamlet.hs | 6 ++ Yesod/Handler.hs | 38 +++++++-- Yesod/Helpers/Auth.hs | 194 +++++++++++++++++++----------------------- Yesod/Resource.hs | 2 +- Yesod/Yesod.hs | 9 +- 5 files changed, 131 insertions(+), 118 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 1e606cbc..8f2a848d 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -45,6 +45,12 @@ hamletToRepHtml h = do c <- hamletToContent h return $ RepHtml c +-- FIXME some type of JSON combined output... +--hamletToRepHtmlJson :: x +-- -> (x -> Hamlet (Routes y) IO ()) +-- -> (x -> Json) +-- -> Handler y RepHtmlJson + instance Monad m => ConvertSuccess String (Hamlet url m ()) where convertSuccess = outputHtml . Unencoded . cs instance Monad m diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7c55033c..61b9d81d 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -23,7 +23,9 @@ module Yesod.Handler Handler , getYesod , getUrlRender + , getRoute , runHandler + , runHandler' , liftIO , YesodApp (..) , Routes @@ -59,7 +61,12 @@ import Data.Convertible.Text (cs) type family Routes y -data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String) +data HandlerData yesod = HandlerData + { handlerRequest :: Request + , handlerYesod :: yesod + , handlerRoute :: Maybe (Routes yesod) + , handlerRender :: (Routes yesod -> String) + } newtype YesodApp = YesodApp { unYesodApp @@ -100,22 +107,37 @@ instance MonadIO (Handler yesod) where instance Failure ErrorResponse (Handler yesod) where failure e = Handler $ \_ -> return ([], HCError e) instance RequestReader (Handler yesod) where - getRequest = Handler $ \(HandlerData rr _ _) - -> return ([], HCContent rr) + getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r) getYesod :: Handler yesod yesod -getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod) +getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r) getUrlRender :: Handler yesod (Routes yesod -> String) -getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r) +getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r) -runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp -runHandler handler y render = YesodApp $ \eh rr cts -> do +getRoute :: Handler yesod (Maybe (Routes yesod)) +getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r) + +runHandler' :: HasReps c + => Handler yesod c + -> yesod + -> Routes yesod + -> (Routes yesod -> String) + -> YesodApp +runHandler' handler y route render = runHandler handler y (Just route) render + +runHandler :: HasReps c + => Handler yesod c + -> yesod + -> Maybe (Routes yesod) + -> (Routes yesod -> String) + -> YesodApp +runHandler handler y route render = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData rr y render) + (unHandler handler $ HandlerData rr y route render) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 06944666..06258fde 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -2,6 +2,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -16,16 +19,14 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth - ( authHandler - , YesodAuth (..) - , maybeIdentifier + ( maybeIdentifier , authIdentifier , displayName , redirectLogin + , Auth (..) + , siteAuthRoutes ) where --- FIXME write as subsite - import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId @@ -35,6 +36,7 @@ import Data.Convertible.Text import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 +import Data.Maybe import qualified Network.Wai as W import Data.Typeable (Typeable) @@ -43,79 +45,49 @@ import Control.Applicative ((<$>)) -- FIXME check referer header to determine destination -class Yesod 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/" +data LoginType = OpenId | Rpxnow - -- | Absolute path to the default login path. - defaultLoginPath :: a -> String - defaultLoginPath a = approot a ++ authRoot a ++ "openid/" +data Auth = forall y. Yesod y => Auth + { defaultDest :: String + , onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth () + , rpxnowApiKey :: Maybe String + , defaultLoginType :: LoginType + , parentYesod :: y + } - 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 - --- 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 --} +$(mkYesod "Auth" [$parseRoutes| +/check Check GET +/logout Logout GET +/openid OpenIdR GET +/openid/forward OpenIdForward GET +/openid/complete OpenIdComplete GET +/login/rpxnow RpxnowR +|]) data ExpectedSingleParam = ExpectedSingleParam deriving (Show, Typeable) instance Exception ExpectedSingleParam -authOpenidForm :: Yesod y => Handler y ChooseRep -authOpenidForm = do +getOpenIdR :: Handler Auth RepHtml +getOpenIdR = do rr <- getRequest case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - let html = template (getParams rr "message") - simpleApplyLayout "Log in via OpenID" html + (Auth _ _ _ _ y) <- getYesod + let html = template (getParams rr "message", id) + let pc = PageContent + { pageTitle = cs "Log in via OpenID" + , pageHead = return () + , pageBody = html + } + content <- hamletToContent $ applyLayout y pc rr + return $ RepHtml content where - urlForward _ = error "FIXME urlForward" - hasMessage = not . null - message [] = cs "" - message (m:_) = cs m + urlForward (_, wrapper) = wrapper OpenIdForward + hasMessage = not . null . fst + message ([], _) = cs "" + message (m:_, _) = cs m template = [$hamlet| $if hasMessage %p.message $message$ @@ -125,14 +97,14 @@ $if hasMessage %input!type=submit!value=Login |] -authOpenidForward :: YesodAuth y => Handler y () -authOpenidForward = do +getOpenIdForward :: Handler Auth () +getOpenIdForward = do rr <- getRequest oid <- case getParams rr "openid" of [x] -> return x _ -> invalidArgs [("openid", show ExpectedSingleParam)] - authroot <- getFullAuthRoot - let complete = authroot ++ "/openid/complete/" + render <- getUrlRender + let complete = render OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> redirect RedirectTemporary @@ -140,8 +112,8 @@ authOpenidForward = do (redirect RedirectTemporary) res -authOpenidComplete :: Yesod y => Handler y () -authOpenidComplete = do +getOpenIdComplete :: Handler Auth () +getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' @@ -149,15 +121,14 @@ authOpenidComplete = do $ "/auth/openid/?message=" ++ encodeUrl (show err) let onSuccess (OpenId.Identifier ident) = do - ar <- getApproot + y <- getYesod header authCookieName ident - redirectToDest RedirectTemporary ar + redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -rpxnowLogin :: YesodAuth y => Handler y () -rpxnowLogin = do +handleRpxnowR :: Handler Auth () +handleRpxnowR = do ay <- getYesod - let ar = approot ay apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound @@ -168,13 +139,14 @@ rpxnowLogin = do (x:_) -> x let dest = case pp "dest" of [] -> case getParams rr "dest" of - [] -> ar - ("":_) -> ar + [] -> defaultDest ay + ("":_) -> defaultDest ay (('#':rest):_) -> rest (s:_) -> s (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token - onRpxnowLogin ident + auth <- getYesod + onRpxnowLogin auth ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest @@ -192,22 +164,25 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y -authCheck :: Yesod y => Handler y ChooseRep -authCheck = do - _ident <- maybeIdentifier - _dn <- displayName - error "FIXME applyLayoutJson" - {- - applyLayoutJson "Authentication Status" $ cs - [ ("identifier", fromMaybe "" ident) - , ("displayName", fromMaybe "" dn) - ] - -} +getCheck :: Handler Auth RepHtml +getCheck = do + ident <- maybeIdentifier + dn <- displayName + -- FIXME applyLayoutJson + hamletToRepHtml $ [$hamlet| +%h1 Authentication Status +%dl + %dt identifier + %dd $fst$ + %dt displayName + %dd $snd$ +|] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) -authLogout :: YesodAuth y => Handler y () -authLogout = do +getLogout :: Handler Auth () +getLogout = do + y <- getYesod deleteCookie authCookieName - getApproot >>= redirectToDest RedirectTemporary + redirectToDest RedirectTemporary $ defaultDest y -- | Gets the identifier for a user if available. maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) @@ -223,18 +198,22 @@ displayName = do -- | 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 :: Handler Auth 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 +redirectLogin :: Handler Auth a +redirectLogin = do + y <- getYesod + let r = case defaultLoginType y of + OpenId -> OpenIdR + Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? + redirectSetDest RedirectTemporary r -- | 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 :: (Functor m, Monad m, RequestReader m) => m String --FIXME unused requestPath = do env <- waiRequest let q = case B8.unpack $ W.queryString env of @@ -248,13 +227,18 @@ requestPath = do -- | Redirect to the given URL, and set a cookie with the current URL so the -- user will ultimately be sent back here. -redirectSetDest :: Yesod y => RedirectType -> String -> Handler y a +redirectSetDest :: RedirectType + -> Routes y -- ^ redirect page + -> Handler y a redirectSetDest rt dest = do - ar <- getApproot - rp <- requestPath - let curr = ar ++ rp - addCookie destCookieTimeout destCookieName curr - redirect rt dest + ur <- getUrlRender + curr <- getRoute + let curr' = case curr of + Just x -> ur x + Nothing -> "/" -- should never happen anyway + dest' = ur dest + 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. diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 0fd78c43..feef3780 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -20,6 +20,6 @@ mkYesod name res = do decs <- createRoutes (name ++ "Routes") ''YesodApp name' - "runHandler" + "runHandler'" res return $ tySyn : yes : decs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 87369a16..f3ec30ea 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -55,9 +55,9 @@ class YesodSite a => Yesod a where -- | 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) + -> PageContent url -- FIXME not so good, should be Routes y -> Request - -> Hamlet (Routes a) IO () + -> Hamlet url IO () applyLayout _ p _ = [$hamlet| !!! %html @@ -159,10 +159,11 @@ toWaiApp' y resource session env = do onRequest y rr print pathSegments let ya = case eurl of - Left _ -> runHandler (errorHandler y NotFound) y render + Left _ -> runHandler (errorHandler y NotFound) y Nothing render Right url -> handleSite site render url method (badMethod method) y - let eh er = runHandler (errorHandler y er) y render + let url' = either (const Nothing) Just eurl + let eh er = runHandler (errorHandler y er) y url' render unYesodApp ya eh rr types >>= responseToWaiResponse cleanupSegments :: [B.ByteString] -> [String] From 654331f406ac7ac2c1d2b0d30bebe32c60e0ae74 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 16 Apr 2010 16:58:04 -0700 Subject: [PATCH 196/624] Began converting AtomFeed to hamlet --- Yesod/Helpers/AtomFeed.hs | 77 ++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 38 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 8ab1a5f7..fd404b45 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.AtomFeed @@ -17,64 +18,64 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) - , AtomFeedResponse (..) - , atomFeed + --, atomFeed + , template -- FIXME ) where import Yesod import Data.Time.Clock (UTCTime) --- FIXME import Web.Encodings (formatW3) -import Data.Convertible.Text - -data AtomFeedResponse = AtomFeedResponse AtomFeed Approot +import Web.Encodings (formatW3) +import Text.Hamlet.Monad +{- atomFeed :: Yesod y => AtomFeed -> Handler y AtomFeedResponse atomFeed f = do y <- getYesod return $ AtomFeedResponse f $ approot y +-} -data AtomFeed = AtomFeed +data AtomFeed url = AtomFeed { atomTitle :: String - , atomLinkSelf :: Location - , atomLinkHome :: Location + , atomLinkSelf :: url + , atomLinkHome :: url , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry] + , atomEntries :: [AtomFeedEntry url] } -instance HasReps AtomFeedResponse where +{- FIXME +instance HasReps (AtomFeed url) where chooseRep = defChooseRep [ (TypeAtom, return . cs) ] +-} -data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: Location +data AtomFeedEntry url = AtomFeedEntry + { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String , atomEntryContent :: HtmlContent } -instance ConvertSuccess AtomFeedResponse Content where - 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 - [ 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 - ] +xmlns :: a -> HtmlContent +xmlns _ = cs "http://www.w3.org/2005/Atom" -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 - ] --} +template :: AtomFeed url -> Hamlet url IO () +template = [$hamlet| +%feed!xmlns=$xmlns$ + %title $atomTitle.cs$ + %link!rel=self!href=@atomLinkSelf@ + %link!href=@atomLinkHome@ + %updated $atomUpdated.formatW3.cs$ + %id @atomLinkHome@ + $forall atomEntries entry + ^entry.entryTemplate^ +|] + +entryTemplate :: AtomFeedEntry url -> Hamlet url IO () +entryTemplate = [$hamlet| +%entry + %id @atomEntryLink@ + %link!href=@atomEntryLink@ + %updated $atomEntryUpdated.formatW3.cs$ + %title $atomEntryTitle.cs$ + %content!type=html $atomEntryContent.cdata$ +|] From d6fbe1e088e2a9c366e36b92e5f5dfae83284ca2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 18 Apr 2010 00:53:35 -0700 Subject: [PATCH 197/624] More built in support for subsites --- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 96 ++++++++++++++++++++++++++++++----------- Yesod/Helpers/Auth.hs | 39 +++++++++-------- Yesod/Resource.hs | 15 ++++++- Yesod/Yesod.hs | 28 ++++++------ examples/helloworld.lhs | 2 +- 6 files changed, 123 insertions(+), 59 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 8f2a848d..343b664e 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -28,7 +28,7 @@ data PageContent url = PageContent , pageBody :: Hamlet url IO () } -hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content +hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content hamletToContent h = do render <- getUrlRender return $ ContentEnum $ go render diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 61b9d81d..1f15ea75 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -21,13 +21,19 @@ module Yesod.Handler ( -- * Handler monad Handler + , GHandler , getYesod + , getYesodMaster , getUrlRender + , getUrlRenderMaster , getRoute + , getRouteMaster , runHandler , runHandler' + , runHandlerSub , liftIO , YesodApp (..) + , YesodAppSub (..) , Routes -- * Special handlers , redirect @@ -61,11 +67,13 @@ import Data.Convertible.Text (cs) type family Routes y -data HandlerData yesod = HandlerData +data HandlerData sub master = HandlerData { handlerRequest :: Request - , handlerYesod :: yesod - , handlerRoute :: Maybe (Routes yesod) - , handlerRender :: (Routes yesod -> String) + , handlerSub :: sub + , handlerMaster :: master + , handlerRoute :: Maybe (Routes sub) + , handlerRender :: (Routes master -> String) + , handlerToMaster :: Routes sub -> Routes master } newtype YesodApp = YesodApp @@ -76,22 +84,26 @@ newtype YesodApp = YesodApp -> IO Response } +data YesodAppSub master = YesodAppSub + ------ Handler monad -newtype Handler yesod a = Handler { - unHandler :: HandlerData yesod +newtype GHandler sub master a = Handler { + unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) } +type Handler yesod = GHandler yesod yesod + data HandlerContents a = HCSpecial SpecialResponse | HCError ErrorResponse | HCContent a -instance Functor (Handler yesod) where +instance Functor (GHandler sub master) where fmap = liftM -instance Applicative (Handler yesod) where +instance Applicative (GHandler sub master) where pure = return (<*>) = ap -instance Monad (Handler yesod) where +instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway return x = Handler $ \_ -> return ([], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do @@ -102,21 +114,46 @@ instance Monad (Handler yesod) where (HCSpecial e) -> return ([], HCSpecial e) (HCContent a) -> unHandler (f a) rr return (headers ++ headers', c') -instance MonadIO (Handler yesod) where +instance MonadIO (GHandler sub master) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') -instance Failure ErrorResponse (Handler yesod) where +instance Failure ErrorResponse (GHandler sub master) where failure e = Handler $ \_ -> return ([], HCError e) -instance RequestReader (Handler yesod) where +instance RequestReader (GHandler sub master) where getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r) -getYesod :: Handler yesod yesod -getYesod = Handler $ \r -> return ([], HCContent $ handlerYesod r) +getData :: GHandler sub master (HandlerData sub master) +getData = Handler $ \r -> return ([], HCContent r) -getUrlRender :: Handler yesod (Routes yesod -> String) -getUrlRender = Handler $ \r -> return ([], HCContent $ handlerRender r) +getYesod :: GHandler sub master sub +getYesod = handlerSub <$> getData -getRoute :: Handler yesod (Maybe (Routes yesod)) -getRoute = Handler $ \r -> return ([], HCContent $ handlerRoute r) +getYesodMaster :: GHandler sub master master +getYesodMaster = handlerMaster <$> getData + +getUrlRender :: GHandler sub master (Routes sub -> String) +getUrlRender = do + d <- getData + return $ handlerRender d . handlerToMaster d + +getUrlRenderMaster :: GHandler sub master (Routes master -> String) +getUrlRenderMaster = handlerRender <$> getData + +getRoute :: GHandler sub master (Maybe (Routes sub)) +getRoute = handlerRoute <$> getData + +getRouteMaster :: GHandler sub master (Maybe (Routes master)) +getRouteMaster = do + d <- getData + return $ handlerToMaster d <$> handlerRoute d + +runHandlerSub :: HasReps c + => GHandler sub master c + -> master + -> (master -> sub) + -> Routes sub + -> (Routes sub -> String) + -> YesodAppSub master +runHandlerSub = error "runHandlerSub" runHandler' :: HasReps c => Handler yesod c @@ -137,7 +174,14 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData rr y route render) + (unHandler handler $ HandlerData + { handlerRequest = rr + , handlerSub = y + , handlerMaster = y + , handlerRoute = route + , handlerRender = render + , handlerToMaster = id + }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts @@ -164,14 +208,14 @@ safeEh er = YesodApp $ \_ _ _ -> do return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error" ------ Special handlers -specialResponse :: SpecialResponse -> Handler yesod a +specialResponse :: SpecialResponse -> GHandler sub master a specialResponse er = Handler $ \_ -> return ([], HCSpecial er) -- | Redirect to the given URL. -redirect :: RedirectType -> String -> Handler yesod a +redirect :: RedirectType -> String -> GHandler sub master a redirect rt = specialResponse . Redirect rt -sendFile :: ContentType -> FilePath -> Handler yesod a +sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct = specialResponse . SendFile ct -- | Return a 404 not found page. Also denotes no handler available. @@ -194,16 +238,16 @@ invalidArgs = failure . InvalidArgs addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value - -> Handler yesod () + -> GHandler sub master () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. -deleteCookie :: String -> Handler yesod () +deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie -- | Set an arbitrary header on the client. -header :: String -> String -> Handler yesod () +header :: String -> String -> GHandler sub master () header a = addHeader . Header a -addHeader :: Header -> Handler yesod () +addHeader :: Header -> GHandler sub master () addHeader h = Handler $ \_ -> return ([h], HCContent ()) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 06258fde..c01693aa 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -47,15 +48,14 @@ import Control.Applicative ((<$>)) data LoginType = OpenId | Rpxnow -data Auth = forall y. Yesod y => Auth +data Auth = Auth { defaultDest :: String - , onRpxnowLogin :: Rpxnow.Identifier -> Handler Auth () + --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () , rpxnowApiKey :: Maybe String , defaultLoginType :: LoginType - , parentYesod :: y } -$(mkYesod "Auth" [$parseRoutes| +$(mkYesodSub "Auth" [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -68,13 +68,13 @@ data ExpectedSingleParam = ExpectedSingleParam deriving (Show, Typeable) instance Exception ExpectedSingleParam -getOpenIdR :: Handler Auth RepHtml +getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR = do rr <- getRequest case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - (Auth _ _ _ _ y) <- getYesod + y <- getYesodMaster let html = template (getParams rr "message", id) let pc = PageContent { pageTitle = cs "Log in via OpenID" @@ -97,7 +97,7 @@ $if hasMessage %input!type=submit!value=Login |] -getOpenIdForward :: Handler Auth () +getOpenIdForward :: GHandler Auth master () getOpenIdForward = do rr <- getRequest oid <- case getParams rr "openid" of @@ -112,7 +112,7 @@ getOpenIdForward = do (redirect RedirectTemporary) res -getOpenIdComplete :: Handler Auth () +getOpenIdComplete :: GHandler Auth master () getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr @@ -126,7 +126,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: Handler Auth () +handleRpxnowR :: GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -146,7 +146,10 @@ handleRpxnowR = do (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token auth <- getYesod - onRpxnowLogin auth ident + {- FIXME onRpxnowLogin + case auth of + Auth _ f _ _ _ -> f ident + -} header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest @@ -164,12 +167,12 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y -getCheck :: Handler Auth RepHtml +getCheck :: Yesod master => GHandler Auth master RepHtml getCheck = do ident <- maybeIdentifier dn <- displayName -- FIXME applyLayoutJson - hamletToRepHtml $ [$hamlet| + simpleApplyLayout "Authentication Status" $ [$hamlet| %h1 Authentication Status %dl %dt identifier @@ -178,7 +181,7 @@ getCheck = do %dd $snd$ |] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) -getLogout :: Handler Auth () +getLogout :: GHandler Auth master () getLogout = do y <- getYesod deleteCookie authCookieName @@ -198,12 +201,12 @@ displayName = do -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. -authIdentifier :: Handler Auth String +authIdentifier :: GHandler Auth master String authIdentifier = maybeIdentifier >>= maybe redirectLogin return -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie -- appropriately. -redirectLogin :: Handler Auth a +redirectLogin :: GHandler Auth master a redirectLogin = do y <- getYesod let r = case defaultLoginType y of @@ -228,8 +231,8 @@ requestPath = do -- | Redirect to the given URL, and set a cookie with the current URL so the -- user will ultimately be sent back here. redirectSetDest :: RedirectType - -> Routes y -- ^ redirect page - -> Handler y a + -> Routes sub -- ^ redirect page + -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender curr <- getRoute @@ -242,7 +245,7 @@ redirectSetDest rt dest = do -- | 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 :: RedirectType -> String -> GHandler sub master a redirectToDest rt def = do rr <- getRequest dest <- case cookies rr destCookieName of diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index feef3780..d65a1d81 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -3,6 +3,7 @@ module Yesod.Resource ( parseRoutes , mkYesod + , mkYesodSub ) where import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) @@ -18,8 +19,20 @@ mkYesod name res = do let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] decs <- createRoutes (name ++ "Routes") - ''YesodApp + (ConT ''YesodApp) name' "runHandler'" res return $ tySyn : yes : decs + +mkYesodSub :: String -> [Resource] -> Q [Dec] +mkYesodSub name res = do + let name' = mkName name + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let yas = ConT ''YesodApp `AppT` VarT (mkName "master") + decs <- createRoutes (name ++ "Routes") + yas + name' + "runHandlerSub" + res + return $ tySyn : decs diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f3ec30ea..6762dfc5 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -77,40 +77,44 @@ class YesodSite a => Yesod a where approot :: a -> Approot -- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. -simpleApplyLayout :: Yesod y +simpleApplyLayout :: Yesod master => String -- ^ title - -> Hamlet (Routes y) IO () -- ^ body - -> Handler y ChooseRep + -> Hamlet (Routes sub) IO () -- ^ body + -> GHandler sub master RepHtml simpleApplyLayout t b = do let pc = PageContent { pageTitle = cs t , pageHead = return () , pageBody = b } - y <- getYesod + y <- getYesodMaster rr <- getRequest content <- hamletToContent $ applyLayout y pc rr - return $ chooseRep - [ (TypeHtml, content) - ] + return $ RepHtml content getApproot :: Yesod y => Handler y Approot getApproot = approot `fmap` getYesod +simpleApplyLayout' :: Yesod master + => String -- ^ title + -> Hamlet (Routes sub) IO () -- ^ body + -> GHandler sub master ChooseRep +simpleApplyLayout' t = fmap chooseRep . simpleApplyLayout t + defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - simpleApplyLayout "Not Found" $ [$hamlet| + simpleApplyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $helper$ |] r where helper = Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = - simpleApplyLayout "Permission Denied" $ [$hamlet| + simpleApplyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied|] () defaultErrorHandler (InvalidArgs ia) = - simpleApplyLayout "Invalid Arguments" $ [$hamlet| + simpleApplyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ias pair @@ -120,12 +124,12 @@ defaultErrorHandler (InvalidArgs ia) = where ias _ = map (cs *** cs) ia defaultErrorHandler (InternalError e) = - simpleApplyLayout "Internal Server Error" $ [$hamlet| + simpleApplyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error %p $cs$ |] e defaultErrorHandler (BadMethod m) = - simpleApplyLayout "Bad Method" $ [$hamlet| + simpleApplyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported %p Method "$cs$" not supported |] m diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs index 052d891d..cf889531 100644 --- a/examples/helloworld.lhs +++ b/examples/helloworld.lhs @@ -15,7 +15,7 @@ mkYesod "HelloWorld" [$parseRoutes| instance Yesod HelloWorld where approot _ = "http://localhost:3000" -getHome :: Handler HelloWorld ChooseRep +getHome :: Handler HelloWorld RepHtml getHome = simpleApplyLayout "Hello World" $ cs "Hello world!" main :: IO () From 533c2c2d15a372abe9df40cd3bb6d084b180a4d4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 19 Apr 2010 23:06:06 -0700 Subject: [PATCH 198/624] Continued work on subsites --- Yesod/Handler.hs | 65 +++++++++++++++++++++++------------------ Yesod/Helpers/Auth.hs | 2 +- Yesod/Helpers/Static.hs | 14 ++++++--- Yesod/Resource.hs | 39 +++++++++++++++---------- examples/static.hs | 2 +- 5 files changed, 71 insertions(+), 51 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1f15ea75..995e9fdc 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -31,9 +32,9 @@ module Yesod.Handler , runHandler , runHandler' , runHandlerSub + , runHandlerSub' , liftIO , YesodApp (..) - , YesodAppSub (..) , Routes -- * Special handlers , redirect @@ -84,8 +85,6 @@ newtype YesodApp = YesodApp -> IO Response } -data YesodAppSub master = YesodAppSub - ------ Handler monad newtype GHandler sub master a = Handler { unHandler :: HandlerData sub master @@ -146,41 +145,32 @@ getRouteMaster = do d <- getData return $ handlerToMaster d <$> handlerRoute d +runHandlerSub' :: HasReps c + => GHandler sub master c + -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) + -> Routes sub + -> (Routes sub -> String) + -> YesodApp +runHandlerSub' handler arg route render = runHandlerSub handler arg (Just route) render + runHandlerSub :: HasReps c => GHandler sub master c - -> master - -> (master -> sub) - -> Routes sub + -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) + -> Maybe (Routes sub) -> (Routes sub -> String) - -> YesodAppSub master -runHandlerSub = error "runHandlerSub" - -runHandler' :: HasReps c - => Handler yesod c - -> yesod - -> Routes yesod - -> (Routes yesod -> String) - -> YesodApp -runHandler' handler y route render = runHandler handler y (Just route) render - -runHandler :: HasReps c - => Handler yesod c - -> yesod - -> Maybe (Routes yesod) - -> (Routes yesod -> String) - -> YesodApp -runHandler handler y route render = YesodApp $ \eh rr cts -> do + -> YesodApp +runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch (unHandler handler $ HandlerData { handlerRequest = rr - , handlerSub = y - , handlerMaster = y - , handlerRoute = route - , handlerRender = render - , handlerToMaster = id + , handlerSub = tosa ma + , handlerMaster = ma + , handlerRoute = sroute + , handlerRender = mrender + , handlerToMaster = tomr }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do @@ -202,6 +192,23 @@ runHandler handler y route render = YesodApp $ \eh rr cts -> do (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c +runHandler' :: HasReps c + => Handler yesod c + -> yesod + -> Routes yesod + -> (Routes yesod -> String) + -> YesodApp +runHandler' handler y route render = runHandler handler y (Just route) render + +runHandler :: HasReps c + => Handler yesod c + -> yesod + -> Maybe (Routes yesod) + -> (Routes yesod -> String) + -> YesodApp +runHandler handler y route render = + runHandlerSub handler (y, id, id, render) route render + safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c01693aa..bb6f6428 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -25,7 +25,7 @@ module Yesod.Helpers.Auth , displayName , redirectLogin , Auth (..) - , siteAuthRoutes + , siteAuth ) where import Web.Encodings diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 7651ca62..184ca175 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -21,7 +21,7 @@ module Yesod.Helpers.Static ( FileLookup , fileLookupDir - , siteStaticRoutes + , siteStatic , StaticRoutes , staticArgs , Static @@ -33,6 +33,7 @@ import Control.Monad import Yesod import Data.List (intercalate) import Network.Wai +import Web.Routes type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) @@ -42,10 +43,15 @@ staticArgs :: FileLookup -> Static staticArgs = Static -- FIXME bug in web-routes-quasi generates warning here -$(mkYesod "Static" [$parseRoutes| +$(mkYesodSub "Static" [$parseRoutes| /* StaticRoute GET |]) +siteStatic' :: Site StaticRoutes (String -> YesodApp + -> (master, master -> Static, StaticRoutes -> Routes master, Routes master -> String) + -> YesodApp) +siteStatic' = siteStatic + -- | 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. @@ -60,7 +66,7 @@ fileLookupDir dir = Static $ \fp -> do then return $ Just $ Left fp' else return Nothing -getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] +getStatic :: FileLookup -> [String] -> GHandler sub master [(ContentType, Content)] getStatic fl fp' = do when (any isUnsafe fp') notFound wai <- waiRequest @@ -76,7 +82,7 @@ getStatic fl fp' = do isUnsafe ('.':_) = True isUnsafe _ = False -getStaticRoute :: [String] -> Handler Static [(ContentType, Content)] +getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] getStaticRoute fp = do Static fl <- getYesod getStatic fl fp diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index d65a1d81..bc520b56 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -6,7 +6,7 @@ module Yesod.Resource , mkYesodSub ) where -import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..)) +import Web.Routes.Quasi import Yesod.Handler import Language.Haskell.TH.Syntax import Yesod.Yesod @@ -15,24 +15,31 @@ mkYesod :: String -> [Resource] -> Q [Dec] mkYesod name res = do let name' = mkName name let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes" + let site = mkName $ "site" ++ name + let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - decs <- createRoutes (name ++ "Routes") - (ConT ''YesodApp) - name' - "runHandler'" - res - return $ tySyn : yes : decs + CreateRoutesResult x y z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = VarE $ mkName "runHandler'" + , crResources = res + , crSite = site + } + return [tySyn, yes, x, y, z] mkYesodSub :: String -> [Resource] -> Q [Dec] mkYesodSub name res = do let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let yas = ConT ''YesodApp `AppT` VarT (mkName "master") - decs <- createRoutes (name ++ "Routes") - yas - name' - "runHandlerSub" - res - return $ tySyn : decs + let site = mkName $ "site" ++ name + let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") + CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = VarE $ mkName "runHandlerSub'" + , crResources = res + , crSite = site + } + return [tySyn, x, z] diff --git a/examples/static.hs b/examples/static.hs index bdc0557b..670d0a94 100644 --- a/examples/static.hs +++ b/examples/static.hs @@ -10,7 +10,7 @@ import Network.Wai.Handler.SimpleServer data StaticExample = StaticExample mkYesod "StaticExample" [$parseRoutes| -/ Root StaticRoutes siteStaticRoutes getStaticSite +/ Root StaticRoutes siteStatic getStaticSite |] instance Yesod StaticExample where From 99c0eb060bfe2a64f69b68d2502b34f0ddb10503 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 19 Apr 2010 23:25:27 -0700 Subject: [PATCH 199/624] Added type signatures for mkYesodSub --- Yesod/Helpers/Auth.hs | 17 +++++++++-------- Yesod/Helpers/Static.hs | 8 +------- Yesod/Resource.hs | 23 ++++++++++++++++++----- 3 files changed, 28 insertions(+), 20 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index bb6f6428..1530ec3e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -39,7 +39,7 @@ import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 import Data.Maybe -import qualified Network.Wai as W +--FIXME import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) import Control.Applicative ((<$>)) @@ -48,6 +48,9 @@ import Control.Applicative ((<$>)) data LoginType = OpenId | Rpxnow +class Yesod y => YesodAuth y where + onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth y () + data Auth = Auth { defaultDest :: String --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () @@ -55,7 +58,7 @@ data Auth = Auth , defaultLoginType :: LoginType } -$(mkYesodSub "Auth" [$parseRoutes| +$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -126,7 +129,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: GHandler Auth master () +handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -145,11 +148,7 @@ handleRpxnowR = do (s:_) -> s (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token - auth <- getYesod - {- FIXME onRpxnowLogin - case auth of - Auth _ f _ _ _ -> f ident - -} + onRpxnowLogin ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest @@ -214,6 +213,7 @@ redirectLogin = do Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? redirectSetDest RedirectTemporary r +{- FIXME -- | 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 --FIXME unused @@ -227,6 +227,7 @@ requestPath = do 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. diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 184ca175..23dbd047 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -33,7 +33,6 @@ import Control.Monad import Yesod import Data.List (intercalate) import Network.Wai -import Web.Routes type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) @@ -43,15 +42,10 @@ staticArgs :: FileLookup -> Static staticArgs = Static -- FIXME bug in web-routes-quasi generates warning here -$(mkYesodSub "Static" [$parseRoutes| +$(mkYesodSub "Static" [] [$parseRoutes| /* StaticRoute GET |]) -siteStatic' :: Site StaticRoutes (String -> YesodApp - -> (master, master -> Static, StaticRoutes -> Routes master, Routes master -> String) - -> YesodApp) -siteStatic' = siteStatic - -- | 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. diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index bc520b56..046107d3 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -29,17 +29,30 @@ mkYesod name res = do } return [tySyn, yes, x, y, z] -mkYesodSub :: String -> [Resource] -> Q [Dec] -mkYesodSub name res = do +mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] +mkYesodSub name ctxs res = do let name' = mkName name let site = mkName $ "site" ++ name let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") - CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + let sa = ConT (mkName name) + let man = mkName "master" + let ma = VarT man -- FIXME + let sr = ConT $ mkName $ name ++ "Routes" + let mr = ConT ''Routes `AppT` VarT man + let arg = TupleT 4 + `AppT` ma + `AppT` (ArrowT `AppT` ma `AppT` sa) + `AppT` (ArrowT `AppT` sr `AppT` mr) + `AppT` (ArrowT `AppT` mr `AppT` ConT ''String) + CreateRoutesResult x (SigD yname y) z <- createRoutes $ CreateRoutesSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp - , crArgument = ConT $ mkName name + , crArgument = arg , crExplode = VarE $ mkName "runHandlerSub'" , crResources = res , crSite = site } - return [tySyn, x, z] + let helper claz = ClassP claz [VarT man] + let ctxs' = map helper ctxs + let y' = ForallT [PlainTV man] ctxs' y + return [tySyn, x, SigD yname y', z] From c875c949fe3e4ae9b5a41570bcf56ab07914a068 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Apr 2010 08:52:19 -0700 Subject: [PATCH 200/624] Initial port to QuasiSite, rather rough --- Yesod/Handler.hs | 10 +++++++--- Yesod/Resource.hs | 4 ++-- Yesod/Yesod.hs | 24 +++++++++++++++--------- 3 files changed, 24 insertions(+), 14 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 995e9fdc..a6a14f76 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -147,11 +147,15 @@ getRouteMaster = do runHandlerSub' :: HasReps c => GHandler sub master c - -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) + -> (Routes master -> String) -> Routes sub - -> (Routes sub -> String) + -> (Routes sub -> Routes master) + -> master + -> (master -> sub) + -> String -> YesodApp -runHandlerSub' handler arg route render = runHandlerSub handler arg (Just route) render +runHandlerSub' handler mrender surl tomurl marg tosarg _method = + runHandlerSub handler (marg, tosarg, tomurl, mrender) (Just surl) (mrender . tomurl) runHandlerSub :: HasReps c => GHandler sub master c diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 046107d3..67453d5c 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -27,7 +27,7 @@ mkYesod name res = do , crResources = res , crSite = site } - return [tySyn, yes, x, y, z] + return [tySyn, yes, x, {-y, -}z] mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] mkYesodSub name ctxs res = do @@ -55,4 +55,4 @@ mkYesodSub name ctxs res = do let helper claz = ClassP claz [VarT man] let ctxs' = map helper ctxs let y' = ForallT [PlainTV man] ctxs' y - return [tySyn, x, SigD yname y', z] + return [tySyn, x, {-SigD yname y',-} z] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6762dfc5..30df8353 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -23,6 +23,7 @@ import Data.Maybe (fromMaybe) import Web.Mime import Web.Encodings (parseHttpAccept) import Web.Routes (Site (..), encodePathInfo, decodePathInfo) +import Web.Routes.Quasi (QuasiSite (..)) import Data.List (intercalate) import qualified Network.Wai as W @@ -37,7 +38,7 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) class YesodSite y where - getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp) + getSite :: QuasiSite YesodApp (Routes y) y (Routes master) master class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. @@ -156,18 +157,23 @@ toWaiApp' y resource session env = do method = B8.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource - eurl = parsePathSegments site pathSegments + eurl = quasiParse site pathSegments render u = approot y ++ '/' - : encodePathInfo (fixSegs $ formatPathSegments site u) + : encodePathInfo (fixSegs $ quasiRender site u) rr <- parseWaiRequest env session onRequest y rr - print pathSegments + print pathSegments -- FIXME remove let ya = case eurl of - Left _ -> runHandler (errorHandler y NotFound) y Nothing render - Right url -> handleSite site render url method - (badMethod method) y - let url' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler y er) y url' render + Nothing -> runHandler (errorHandler y NotFound) y Nothing render + Just url -> quasiDispatch site + render + url + id + y + id + (badMethod method) + method + let eh er = runHandler (errorHandler y er) y eurl render unYesodApp ya eh rr types >>= responseToWaiResponse cleanupSegments :: [B.ByteString] -> [String] From e280e284f80afa0ada354c9dc4eec89df4db8482 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Apr 2010 15:35:41 -0700 Subject: [PATCH 201/624] Began refactoring --- .gitignore | 2 +- Yesod.hs | 5 +- Yesod/Definitions.hs | 13 +-- Yesod/Dispatch.hs | 171 ++++++++++++++++++++++++++++++++++++++ Yesod/Handler.hs | 48 ++--------- Yesod/Helpers/AtomFeed.hs | 26 ++---- Yesod/Helpers/Auth.hs | 17 ++-- Yesod/Helpers/Sitemap.hs | 80 +++++++----------- Yesod/Helpers/Static.hs | 2 +- Yesod/Resource.hs | 58 ------------- Yesod/Response.hs | 8 ++ Yesod/Yesod.hs | 102 ++--------------------- yesod.cabal | 2 +- 13 files changed, 248 insertions(+), 286 deletions(-) create mode 100644 Yesod/Dispatch.hs delete mode 100644 Yesod/Resource.hs diff --git a/.gitignore b/.gitignore index 00255d26..31291836 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ -dist +/dist/ *.swp client_session_key.aes *.hi diff --git a/Yesod.hs b/Yesod.hs index 29b2e1dc..baaf4880 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,7 +19,7 @@ module Yesod , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler - , module Yesod.Resource + , module Yesod.Dispatch , module Yesod.Form , module Web.Mime , module Yesod.Hamlet @@ -29,17 +29,16 @@ module Yesod ) where #if TEST -import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) #else -import Yesod.Resource import Yesod.Response import Yesod.Request import Web.Mime #endif +import Yesod.Dispatch import Yesod.Form import Yesod.Yesod import Yesod.Definitions diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index c1e1d196..fb51a1ed 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -17,8 +17,6 @@ module Yesod.Definitions ( Approot , Language - , Location (..) - , showLocation -- * Constant values , authCookieName , authDisplayName @@ -37,22 +35,13 @@ 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 :: [ByteString] -- FIXME make this extensible encryptedCookies = [pack authDisplayName, pack authCookieName] langKey :: String diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs new file mode 100644 index 00000000..74eaee8d --- /dev/null +++ b/Yesod/Dispatch.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Dispatch + ( -- * Quasi-quoted routing + parseRoutes + , mkYesod + , mkYesodSub + -- * Convert to WAI + , toWaiApp + , basicHandler + ) where + +import Yesod.Handler +import Yesod.Response +import Yesod.Definitions +import Yesod.Yesod +import Yesod.Request + +import Web.Routes.Quasi +import Language.Haskell.TH.Syntax + +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) + +import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe) +import Web.Encodings (parseHttpAccept) +import Web.Mime +import Data.List (intercalate) +import Web.Routes (encodePathInfo, decodePathInfo) + +mkYesod :: String -> [Resource] -> Q [Dec] +mkYesod name = mkYesodGeneral name [] False + +mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] +mkYesodSub name clazzes = mkYesodGeneral name clazzes True + +explodeHandler :: HasReps c + => GHandler sub master c + -> (Routes master -> String) + -> Routes sub + -> (Routes sub -> Routes master) + -> master + -> (master -> sub) + -> YesodApp + -> String + -> YesodApp +explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f + +mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q [Dec] +mkYesodGeneral name clazzes isSub res = do + let name' = mkName name + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let site = mkName $ "site" ++ name + let gsbod = NormalB $ VarE site + let yes' = FunD (mkName "getSite") [Clause [] gsbod []] + let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] + explode <- [|explodeHandler|] + CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = explode + , crResources = res + , crSite = site + } + let master = if isSub + then VarT (mkName "master") + else ConT (mkName name) + murl = ConT ''Routes `AppT` master + sub = ConT $ mkName name + surl = ConT ''Routes `AppT` sub + let yType = ConT ''QuasiSite + `AppT` ConT ''YesodApp + `AppT` surl + `AppT` sub + `AppT` murl + `AppT` master + let ctx = if isSub + then map (\c -> ClassP c [master]) clazzes + else [] + tvs = if isSub then [PlainTV $ mkName "master"] else [] + let y' = SigD site $ ForallT tvs ctx yType + return $ (if isSub then id else (:) yes) $ [y', z, tySyn, x] + +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 site = getSite + method = B.unpack $ W.methodToBS $ W.requestMethod env + types = httpAccept env + pathSegments = filter (not . null) $ cleanupSegments resource + eurl = quasiParse site pathSegments + render u = approot y ++ '/' + : encodePathInfo (fixSegs $ quasiRender site u) + rr <- parseWaiRequest env session + onRequest y rr + print pathSegments -- FIXME remove + let ya = case eurl of + Nothing -> runHandler (errorHandler y NotFound) + render + Nothing + id + y + id + Just url -> quasiDispatch site + render + url + id + y + id + (badMethodApp method) + method + let eh er = runHandler (errorHandler y er) render eurl id y id + unYesodApp ya eh rr types >>= responseToWaiResponse + +cleanupSegments :: [B.ByteString] -> [String] +cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack + +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 + +badMethodApp :: String -> YesodApp +badMethodApp m = YesodApp $ \eh req cts + -> unYesodApp (eh $ BadMethod m) eh req cts + +fixSegs :: [String] -> [String] +fixSegs [] = [] +fixSegs [x] + | any (== '.') x = [x] + | otherwise = [x, ""] -- append trailing slash +fixSegs (x:xs) = x : fixSegs xs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a6a14f76..ead83da9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -30,9 +30,6 @@ module Yesod.Handler , getRoute , getRouteMaster , runHandler - , runHandler' - , runHandlerSub - , runHandlerSub' , liftIO , YesodApp (..) , Routes @@ -145,25 +142,15 @@ getRouteMaster = do d <- getData return $ handlerToMaster d <$> handlerRoute d -runHandlerSub' :: HasReps c - => GHandler sub master c - -> (Routes master -> String) - -> Routes sub - -> (Routes sub -> Routes master) - -> master - -> (master -> sub) - -> String - -> YesodApp -runHandlerSub' handler mrender surl tomurl marg tosarg _method = - runHandlerSub handler (marg, tosarg, tomurl, mrender) (Just surl) (mrender . tomurl) - -runHandlerSub :: HasReps c - => GHandler sub master c - -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) - -> Maybe (Routes sub) - -> (Routes sub -> String) - -> YesodApp -runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts -> do +runHandler :: HasReps c + => GHandler sub master c + -> (Routes master -> String) + -> Maybe (Routes sub) + -> (Routes sub -> Routes master) + -> master + -> (master -> sub) + -> YesodApp +runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) @@ -196,23 +183,6 @@ runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c -runHandler' :: HasReps c - => Handler yesod c - -> yesod - -> Routes yesod - -> (Routes yesod -> String) - -> YesodApp -runHandler' handler y route render = runHandler handler y (Just route) render - -runHandler :: HasReps c - => Handler yesod c - -> yesod - -> Maybe (Routes yesod) - -> (Routes yesod -> String) - -> YesodApp -runHandler handler y route render = - runHandlerSub handler (y, id, id, render) route render - safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index fd404b45..373bef34 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- @@ -18,8 +16,8 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) - --, atomFeed - , template -- FIXME + , atomFeed + , RepAtom (..) ) where import Yesod @@ -27,12 +25,12 @@ import Data.Time.Clock (UTCTime) import Web.Encodings (formatW3) import Text.Hamlet.Monad -{- -atomFeed :: Yesod y => AtomFeed -> Handler y AtomFeedResponse -atomFeed f = do - y <- getYesod - return $ AtomFeedResponse f $ approot y --} +newtype RepAtom = RepAtom Content +instance HasReps RepAtom where + chooseRep (RepAtom c) _ = return (TypeAtom, c) + +atomFeed :: AtomFeed (Routes sub) -> GHandler sub master RepAtom +atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed { atomTitle :: String @@ -41,12 +39,6 @@ data AtomFeed url = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry url] } -{- FIXME -instance HasReps (AtomFeed url) where - chooseRep = defChooseRep - [ (TypeAtom, return . cs) - ] --} data AtomFeedEntry url = AtomFeedEntry { atomEntryLink :: url @@ -55,7 +47,7 @@ data AtomFeedEntry url = AtomFeedEntry , atomEntryContent :: HtmlContent } -xmlns :: a -> HtmlContent +xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url IO () diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1530ec3e..04147fc3 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -5,7 +5,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -39,7 +40,6 @@ import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 import Data.Maybe ---FIXME import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) import Control.Applicative ((<$>)) @@ -48,17 +48,15 @@ import Control.Applicative ((<$>)) data LoginType = OpenId | Rpxnow -class Yesod y => YesodAuth y where - onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth y () - data Auth = Auth { defaultDest :: String - --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () + , onRpxnowLogin :: forall master. Yesod master + => Rpxnow.Identifier -> GHandler Auth master () , rpxnowApiKey :: Maybe String , defaultLoginType :: LoginType } -$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| +$(mkYesodSub "Auth" [''Yesod] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -129,7 +127,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: YesodAuth master => GHandler Auth master () +handleRpxnowR :: Yesod master => GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -148,7 +146,8 @@ handleRpxnowR = do (s:_) -> s (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token - onRpxnowLogin ident + auth <- getYesod + onRpxnowLogin auth ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 95e32c22..542224a2 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap @@ -20,13 +18,11 @@ module Yesod.Helpers.Sitemap , robots , SitemapUrl (..) , SitemapChangeFreq (..) - , SitemapResponse (..) ) where import Yesod ---FIXME import Web.Encodings (formatW3) +import Web.Encodings (formatW3) import Data.Time (UTCTime) -import Data.Convertible.Text data SitemapChangeFreq = Always | Hourly @@ -35,57 +31,45 @@ data SitemapChangeFreq = Always | 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" +showFreq :: SitemapChangeFreq -> String +showFreq Always = "always" +showFreq Hourly = "hourly" +showFreq Daily = "daily" +showFreq Weekly = "weekly" +showFreq Monthly = "monthly" +showFreq Yearly = "yearly" +showFreq Never = "never" {- FIXME instance ConvertSuccess SitemapChangeFreq Html where convertSuccess = (cs :: String -> Html) . cs -} -data SitemapUrl = SitemapUrl - { sitemapLoc :: Location +data SitemapUrl url = SitemapUrl + { sitemapLoc :: url , sitemapLastMod :: UTCTime , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double } -data SitemapResponse = SitemapResponse [SitemapUrl] Approot -instance ConvertSuccess SitemapResponse Content where - 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 - 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) - ] +sitemapNS :: [SitemapUrl url] -> HtmlContent +sitemapNS _ = cs "http://www.sitemaps.org/schemas/sitemap/0.9" -sitemap :: Yesod y => [SitemapUrl] -> Handler y SitemapResponse -sitemap urls = do - yesod <- getYesod - return $ SitemapResponse urls $ approot yesod +template :: [SitemapUrl url] -> Hamlet url IO () +template = [$hamlet| +%urlset!xmlns=$sitemapNS$ + $forall id url + %url + %loc @url.sitemapLoc@ + %lastmod $url.sitemapLastMod.formatW3.cs$ + %changefreq $url.sitemapChangeFreq.showFreq.cs$ + %priority $url.priority.show.cs$ +|] -robots :: Yesod yesod => Handler yesod [(ContentType, Content)] -robots = do - yesod <- getYesod - return $ staticRep TypePlain $ "Sitemap: " ++ showLocation - (approot yesod) - (RelLoc "sitemap.xml") +sitemap :: [SitemapUrl (Routes sub)] -> GHandler sub master RepXml +sitemap = fmap RepXml . hamletToContent . template + +robots :: Routes sub -- ^ sitemap url + -> GHandler sub master RepPlain +robots smurl = do + r <- getUrlRender + return $ RepPlain $ cs $ "Sitemap: " ++ r smurl diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 23dbd047..e7ce3f76 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in web-routes-quasi --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs deleted file mode 100644 index 67453d5c..00000000 --- a/Yesod/Resource.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Resource - ( parseRoutes - , mkYesod - , mkYesodSub - ) where - -import Web.Routes.Quasi -import Yesod.Handler -import Language.Haskell.TH.Syntax -import Yesod.Yesod - -mkYesod :: String -> [Resource] -> Q [Dec] -mkYesod name res = do - let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let site = mkName $ "site" ++ name - let gsbod = NormalB $ VarE site - let yes' = FunD (mkName "getSite") [Clause [] gsbod []] - let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - CreateRoutesResult x y z <- createRoutes $ CreateRoutesSettings - { crRoutes = mkName $ name ++ "Routes" - , crApplication = ConT ''YesodApp - , crArgument = ConT $ mkName name - , crExplode = VarE $ mkName "runHandler'" - , crResources = res - , crSite = site - } - return [tySyn, yes, x, {-y, -}z] - -mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] -mkYesodSub name ctxs res = do - let name' = mkName name - let site = mkName $ "site" ++ name - let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") - let sa = ConT (mkName name) - let man = mkName "master" - let ma = VarT man -- FIXME - let sr = ConT $ mkName $ name ++ "Routes" - let mr = ConT ''Routes `AppT` VarT man - let arg = TupleT 4 - `AppT` ma - `AppT` (ArrowT `AppT` ma `AppT` sa) - `AppT` (ArrowT `AppT` sr `AppT` mr) - `AppT` (ArrowT `AppT` mr `AppT` ConT ''String) - CreateRoutesResult x (SigD yname y) z <- createRoutes $ CreateRoutesSettings - { crRoutes = mkName $ name ++ "Routes" - , crApplication = ConT ''YesodApp - , crArgument = arg - , crExplode = VarE $ mkName "runHandlerSub'" - , crResources = res - , crSite = site - } - let helper claz = ClassP claz [VarT man] - let ctxs' = map helper ctxs - let y' = ForallT [PlainTV man] ctxs' y - return [tySyn, x, {-SigD yname y',-} z] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 2c48a9bb..792092d2 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -31,6 +31,8 @@ module Yesod.Response , RepHtml (..) , RepJson (..) , RepHtmlJson (..) + , RepPlain (..) + , RepXml (..) -- * Response type , Response (..) -- * Special responses @@ -157,6 +159,12 @@ instance HasReps RepHtmlJson where [ (TypeHtml, html) , (TypeJson, json) ] +newtype RepPlain = RepPlain Content +instance HasReps RepPlain where + chooseRep (RepPlain c) _ = return (TypePlain, c) +newtype RepXml = RepXml Content +instance HasReps RepXml where + chooseRep (RepXml c) _ = return (TypeXml, c) data Response = Response W.Status [Header] ContentType Content diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 30df8353..d40b1464 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -5,40 +5,22 @@ module Yesod.Yesod , YesodSite (..) , simpleApplyLayout , getApproot - , toWaiApp - , basicHandler ) where import Yesod.Response import Yesod.Request -import Yesod.Definitions import Yesod.Hamlet -import Yesod.Handler hiding (badMethod) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 +import Yesod.Handler import Data.Convertible.Text import Control.Arrow ((***)) - -import Data.Maybe (fromMaybe) -import Web.Mime -import Web.Encodings (parseHttpAccept) -import Web.Routes (Site (..), encodePathInfo, decodePathInfo) -import Web.Routes.Quasi (QuasiSite (..)) -import Data.List (intercalate) - -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 as W +import Yesod.Definitions -import qualified Network.Wai.Handler.SimpleServer as SS -import qualified Network.Wai.Handler.CGI as CGI -import System.Environment (getEnvironment) +import Web.Routes.Quasi (QuasiSite (..)) class YesodSite y where - getSite :: QuasiSite YesodApp (Routes y) y (Routes master) master + getSite :: QuasiSite YesodApp (Routes y) y (Routes y) y class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. @@ -134,77 +116,3 @@ defaultErrorHandler (BadMethod m) = %h1 Method Not Supported %p Method "$cs$" not supported |] m - -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 site = getSite - method = B8.unpack $ W.methodToBS $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) $ cleanupSegments resource - eurl = quasiParse site pathSegments - render u = approot y ++ '/' - : encodePathInfo (fixSegs $ quasiRender site u) - rr <- parseWaiRequest env session - onRequest y rr - print pathSegments -- FIXME remove - let ya = case eurl of - Nothing -> runHandler (errorHandler y NotFound) y Nothing render - Just url -> quasiDispatch site - render - url - id - y - id - (badMethod method) - method - let eh er = runHandler (errorHandler y er) y eurl render - unYesodApp ya eh rr types >>= responseToWaiResponse - -cleanupSegments :: [B.ByteString] -> [String] -cleanupSegments = decodePathInfo . intercalate "/" . map B8.unpack - -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 - -badMethod :: String -> YesodApp -badMethod m = YesodApp $ \eh req cts - -> unYesodApp (eh $ BadMethod m) eh req cts - -fixSegs :: [String] -> [String] -fixSegs [] = [] -fixSegs [x] - | any (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash -fixSegs (x:xs) = x : fixSegs xs diff --git a/yesod.cabal b/yesod.cabal index 2f4b8da8..067a0e5c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -68,7 +68,7 @@ library Yesod.Form Yesod.Hamlet Yesod.Handler - Yesod.Resource + Yesod.Dispatch Yesod.Yesod Yesod.Helpers.Auth Yesod.Helpers.Static From e8812472c00028e65f60260bc14e4f072d8e581e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Apr 2010 16:36:16 -0700 Subject: [PATCH 202/624] Added rudimentary JSON support --- Yesod.hs | 3 ++ Yesod/Helpers/Auth.hs | 17 ++++--- Yesod/Json.hs | 107 ++++++++++++++++++++++++++++++++++++++++++ Yesod/Yesod.hs | 20 ++++++++ runtests.hs | 14 +++--- yesod.cabal | 1 + 6 files changed, 148 insertions(+), 14 deletions(-) create mode 100644 Yesod/Json.hs diff --git a/Yesod.hs b/Yesod.hs index baaf4880..988a4baf 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -23,6 +23,7 @@ module Yesod , module Yesod.Form , module Web.Mime , module Yesod.Hamlet + , module Yesod.Json , Application , Method (..) , cs @@ -32,10 +33,12 @@ module Yesod import Yesod.Response hiding (testSuite) import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) +import Yesod.Json hiding (testSuite) #else import Yesod.Response import Yesod.Request import Web.Mime +import Yesod.Json #endif import Yesod.Dispatch diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 04147fc3..195c2d59 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -165,19 +164,25 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where Nothing -> helper xs Just y -> y -getCheck :: Yesod master => GHandler Auth master RepHtml +getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do ident <- maybeIdentifier dn <- displayName - -- FIXME applyLayoutJson - simpleApplyLayout "Authentication Status" $ [$hamlet| + let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) + applyLayoutJson "Authentication Status" arg html json + where + html = [$hamlet| %h1 Authentication Status %dl %dt identifier %dd $fst$ %dt displayName %dd $snd$ -|] (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) +|] + json (ident, dn) = + jsonMap [ (jsonScalar $ cs "ident", jsonScalar ident) + , (jsonScalar $ cs "displayName", jsonScalar dn) + ] getLogout :: GHandler Auth master () getLogout = do @@ -215,7 +220,7 @@ redirectLogin = do {- FIXME -- | 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 --FIXME unused +requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath = do env <- waiRequest let q = case B8.unpack $ W.queryString env of diff --git a/Yesod/Json.hs b/Yesod/Json.hs new file mode 100644 index 00000000..b6848e9c --- /dev/null +++ b/Yesod/Json.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +module Yesod.Json + ( Json + , jsonToContent + -- * Generate Json output + , jsonScalar + , jsonList + , jsonList' + , jsonMap + , jsonMap' +#if TEST + , testSuite +#endif + ) + where + +import Text.Hamlet.Monad +import Control.Applicative +import Data.Text (Text) +import Web.Encodings +import Yesod.Hamlet +import Control.Monad (when) +#if TEST +import Yesod.Response hiding (testSuite) +import Data.Text.Lazy (unpack) +import qualified Data.Text as T +#else +import Yesod.Response +#endif +import Yesod.Handler + +#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 + +newtype Json url m a = Json { unJson :: Hamlet url m a } + deriving (Functor, Applicative, Monad) + +jsonToContent :: Json (Routes sub) IO () -> GHandler sub master Content +jsonToContent = hamletToContent . unJson + +htmlContentToText :: HtmlContent -> Text +htmlContentToText (Encoded t) = t +htmlContentToText (Unencoded t) = encodeHtml t + +jsonScalar :: Monad m => HtmlContent -> Json url m () +jsonScalar s = Json $ do + outputString "\"" + output $ encodeJson $ htmlContentToText s + outputString "\"" + +jsonList :: Monad m => [Json url m ()] -> Json url m () +jsonList = jsonList' . fromList + +jsonList' :: Monad m => Enumerator (Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonList' (Enumerator enum) = do + Json $ outputString "[" + _ <- enum go False + Json $ outputString "]" + where + go putComma j = do + when putComma $ Json $ outputString "," + () <- j + return $ Right True + +jsonMap :: Monad m => [(Json url m (), Json url m ())] -> Json url m () +jsonMap = jsonMap' . fromList + +jsonMap' :: Monad m => Enumerator (Json url m (), Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonMap' (Enumerator enum) = do + Json $ outputString "{" + _ <- enum go False + Json $ outputString "}" + where + go putComma (k, v) = do + when putComma $ Json $ outputString "," + () <- k + Json $ outputString ":" + () <- v + return $ Right True + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Json" + [ testCase "simple output" caseSimpleOutput + ] + +caseSimpleOutput :: Assertion +caseSimpleOutput = do + let j = do + jsonMap + [ (jsonScalar $ T.pack "foo" , jsonList + [ jsonScalar $ T.pack "bar" + , jsonScalar $ T.pack "baz" + ]) + ] + t <- hamletToText id $ unJson j + "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack t + +#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d40b1464..f4939fe2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -4,6 +4,7 @@ module Yesod.Yesod ( Yesod (..) , YesodSite (..) , simpleApplyLayout + , applyLayoutJson , getApproot ) where @@ -16,6 +17,7 @@ import Control.Arrow ((***)) import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W import Yesod.Definitions +import Yesod.Json import Web.Routes.Quasi (QuasiSite (..)) @@ -59,6 +61,24 @@ class YesodSite a => Yesod a where -- trailing slash. approot :: a -> Approot +applyLayoutJson :: Yesod master + => String -- ^ title + -> x + -> (x -> Hamlet (Routes sub) IO ()) + -> (x -> Json (Routes sub) IO ()) + -> GHandler sub master RepHtmlJson +applyLayoutJson t x toH toJ = do + let pc = PageContent + { pageTitle = cs t + , pageHead = return () -- FIXME allow user to supply? + , pageBody = toH x + } + y <- getYesodMaster + rr <- getRequest + html <- hamletToContent $ applyLayout y pc rr + json <- jsonToContent $ toJ x + return $ RepHtmlJson html json + -- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. simpleApplyLayout :: Yesod master => String -- ^ title diff --git a/runtests.hs b/runtests.hs index 91a0a81b..01d34d1d 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,20 +1,18 @@ 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 +-- FIXME import qualified Test.Errors +-- FIXME import qualified Test.QuasiResource import qualified Web.Mime +import qualified Yesod.Json main :: IO () main = defaultMain [ Yesod.Response.testSuite - , Yesod.Resource.testSuite , Yesod.Request.testSuite - , Data.Object.Html.testSuite - , Test.Errors.testSuite - , Test.QuasiResource.testSuite + -- FIXME , Test.Errors.testSuite + -- FIXME, Test.QuasiResource.testSuite , Web.Mime.testSuite + , Yesod.Json.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index 067a0e5c..fc8cd07d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -67,6 +67,7 @@ library Yesod.Definitions Yesod.Form Yesod.Hamlet + Yesod.Json Yesod.Handler Yesod.Dispatch Yesod.Yesod From dcf9208cf532c03b8920c4fbdb13217f70f3c9d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Apr 2010 16:45:02 -0700 Subject: [PATCH 203/624] Some minor cleanups --- Yesod/Dispatch.hs | 10 +++++----- Yesod/Form.hs | 4 ++-- Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 4 +--- 4 files changed, 9 insertions(+), 11 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 74eaee8d..4afa3f3b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -58,13 +58,13 @@ explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q [Dec] mkYesodGeneral name clazzes isSub res = do let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") let site = mkName $ "site" ++ name let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] explode <- [|explodeHandler|] - CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + CreateRoutesResult x _ z <- createRoutes CreateRoutesSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp , crArgument = ConT $ mkName name @@ -85,11 +85,11 @@ mkYesodGeneral name clazzes isSub res = do `AppT` murl `AppT` master let ctx = if isSub - then map (\c -> ClassP c [master]) clazzes + then map (flip ClassP [master]) clazzes else [] - tvs = if isSub then [PlainTV $ mkName "master"] else [] + tvs = [PlainTV $ mkName "master" | isSub] let y' = SigD site $ ForallT tvs ctx yType - return $ (if isSub then id else (:) yes) $ [y', z, tySyn, x] + return $ (if isSub then id else (:) yes) [y', z, tySyn, x] toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 0b7a80cf..cc0a3e0b 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -45,7 +45,7 @@ instance Functor Form where 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) + (Right (_, f), Right (_, x)) -> Right (Nothing, f x) (Left e1, Left e2) -> Left $ e1 ++ e2 (Left e, _) -> Left e (_, Left e) -> Left e @@ -75,7 +75,7 @@ runFormGet f = do runFormGeneric (getParams rr) f input :: ParamName -> Form [ParamValue] -input pn = Form $ \l -> Right $ (Just pn, l pn) +input pn = Form $ \l -> Right (Just pn, l pn) applyForm :: (x -> Either FormError y) -> Form x -> Form y applyForm f (Form x') = diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ead83da9..17e16413 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -155,7 +155,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do InternalError . (show :: Control.Exception.SomeException -> String) (headers, contents) <- Control.Exception.catch - (unHandler handler $ HandlerData + (unHandler handler HandlerData { handlerRequest = rr , handlerSub = tosa ma , handlerMaster = ma diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 195c2d59..c9e9c10f 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -160,9 +160,7 @@ 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 + helper (x:xs) = fromMaybe (helper xs) $ lookup x extra getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do From fa98452452b705a2703b4489fca9ee48362922f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 21 Apr 2010 18:07:03 -0700 Subject: [PATCH 204/624] Slimmed down dependencies --- Yesod/Form.hs | 9 ++++----- Yesod/Request.hs | 6 ++++-- yesod.cabal | 14 +++----------- 3 files changed, 11 insertions(+), 18 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index cc0a3e0b..4f01afd5 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -25,10 +25,9 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) import Data.Convertible.Text -import Data.Attempt +import Control.Monad.Attempt import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class (MonadIO) -import qualified Safe.Failure noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)" @@ -118,9 +117,9 @@ checkBool = applyForm $ \pv -> Right $ case pv of checkInteger :: Form ParamValue -> Form Integer checkInteger = applyForm $ \pv -> - case Safe.Failure.read pv of - Nothing -> Left "Invalid integer" - Just i -> Right i + case reads pv of + [] -> Left "Invalid integer" + ((i, _):_) -> Right i -- | Instead of calling 'failure' with an 'InvalidArgs', return the error -- messages. diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 0b5e59cc..5c1ae5e1 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -39,7 +39,6 @@ module Yesod.Request ) where import qualified Network.Wai as W -import Data.Function.Predicate (equals) import Yesod.Definitions import Web.Encodings import qualified Data.ByteString as B @@ -119,7 +118,10 @@ iothunk = fmap go . newMVar . Left where -- | All cookies with the given name. cookies :: Request -> ParamName -> [ParamValue] -cookies rr name = map snd . filter (fst `equals` name) . reqCookies $ rr +cookies rr name = + map snd . filter (fst `equals` name) . reqCookies $ rr + where + equals f x y = f y == x parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -- ^ session diff --git a/yesod.cabal b/yesod.cabal index fc8cd07d..eacce498 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -37,27 +37,19 @@ library 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, + wai >= 0.2.0 && < 0.3, + wai-extra >= 0.0.0 && < 0.3, authenticate >= 0.6 && < 0.7, - predicates >= 0.1 && < 0.2, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.4 && < 0.3, + web-encodings >= 0.2.4 && < 0.5, data-object >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, transformers >= 0.2.0 && < 0.3, control-monad-attempt >= 0.2.0 && < 0.3, - syb, text >= 0.5 && < 0.8, convertible-text >= 0.2.0 && < 0.3, - 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, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.0 && < 0.1, hamlet >= 0.0 && < 0.1 From d0c9386d64e7847fc7e617f88be87572291323a1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 06:02:36 -0700 Subject: [PATCH 205/624] Cleaned up Web.Mime, using Strings directly --- Web/Mime.hs | 70 ++++++++++++++++++++++++++++------------------- Yesod/Dispatch.hs | 2 +- Yesod/Response.hs | 7 +++-- 3 files changed, 47 insertions(+), 32 deletions(-) diff --git a/Web/Mime.hs b/Web/Mime.hs index deef197d..7c69e154 100644 --- a/Web/Mime.hs +++ b/Web/Mime.hs @@ -3,10 +3,14 @@ {-# LANGUAGE CPP #-} -- | Generic MIME type module. Could be spun off into its own package. module Web.Mime - ( ContentType (..) - , contentTypeFromBS + ( -- * Data type and conversions + ContentType (..) + , contentTypeFromString + , contentTypeToString + -- * File extensions , typeByExt , ext + -- * Utilities , simpleContentType #if TEST , testSuite @@ -14,8 +18,6 @@ module Web.Mime ) where import Data.Function (on) -import Data.Convertible.Text -import Data.ByteString.Char8 (pack, ByteString, unpack) #if TEST import Test.Framework (testGroup, Test) @@ -26,6 +28,11 @@ import Test.QuickCheck import Control.Monad (when) #endif +-- | Equality is determined by converting to a 'String' via +-- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the +-- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not* +-- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8 +-- encoded. See 'contentTypeToString'. data ContentType = TypeHtml | TypePlain @@ -43,33 +50,41 @@ data ContentType = | TypeOther String deriving (Show) -instance ConvertSuccess ContentType ByteString where - convertSuccess = pack . cs +-- | This is simply a synonym for 'TypeOther'. However, equality works as +-- expected; see 'ContentType'. +contentTypeFromString :: String -> ContentType +contentTypeFromString = TypeOther -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 +-- | This works as expected, with one caveat: the builtin textual content types +-- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of +-- their basic content-type. If another encoding is desired, please use +-- 'TypeOther'. +contentTypeToString :: ContentType -> String +contentTypeToString TypeHtml = "text/html; charset=utf-8" +contentTypeToString TypePlain = "text/plain; charset=utf-8" +contentTypeToString TypeJson = "application/json; charset=utf-8" +contentTypeToString TypeXml = "text/xml" +contentTypeToString TypeAtom = "application/atom+xml" +contentTypeToString TypeJpeg = "image/jpeg" +contentTypeToString TypePng = "image/png" +contentTypeToString TypeGif = "image/gif" +contentTypeToString TypeJavascript = "text/javascript; charset=utf-8" +contentTypeToString TypeCss = "text/css; charset=utf-8" +contentTypeToString TypeFlv = "video/x-flv" +contentTypeToString TypeOgv = "video/ogg" +contentTypeToString TypeOctet = "application/octet-stream" +contentTypeToString (TypeOther s) = s -simpleContentType :: ContentType -> String -simpleContentType = fst . span (/= ';') . cs +-- | Removes \"extra\" information at the end of a content type string. In +-- particular, removes everything after the semicolon, if present. +-- +-- For example, \"text/html; charset=utf-8\" is commonly used to specify the +-- character encoding for HTML data. This function would return \"text/html\". +simpleContentType :: String -> String +simpleContentType = fst . span (/= ';') instance Eq ContentType where - (==) = (==) `on` (cs :: ContentType -> String) - -contentTypeFromBS :: ByteString -> ContentType -contentTypeFromBS = TypeOther . unpack + (==) = (==) `on` contentTypeToString -- | Determine a mime-type based on the file extension. typeByExt :: String -> ContentType @@ -106,5 +121,4 @@ caseTypeByExt :: Assertion caseTypeByExt = do TypeJavascript @=? typeByExt (ext "foo.js") TypeHtml @=? typeByExt (ext "foo.html") - #endif diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4afa3f3b..ba966463 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -141,7 +141,7 @@ cleanupSegments :: [B.ByteString] -> [String] cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack httpAccept :: W.Request -> [ContentType] -httpAccept = map contentTypeFromBS +httpAccept = map (contentTypeFromString . B.unpack) . parseHttpAccept . fromMaybe B.empty . lookup W.Accept diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 792092d2..66ff9b1d 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -133,12 +133,13 @@ instance HasReps () where instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ - case filter (\(ct, _) -> simpleContentType ct `elem` - map simpleContentType cts) a of + case filter (\(ct, _) -> go ct `elem` map go cts) a of ((ct, c):_) -> (ct, c) _ -> case a of (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" + where + go = simpleContentType . contentTypeToString -- | Data with a single representation. staticRep :: ConvertSuccess x Content @@ -227,7 +228,7 @@ headerToPair (Header key value) = responseToWaiResponse :: Response -> IO W.Response responseToWaiResponse (Response sc hs ct c) = do hs' <- mapM headerToPair hs - let hs'' = (W.ContentType, cs ct) : hs' + let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' return $ W.Response sc hs'' $ case c of ContentFile fp -> Left fp ContentEnum e -> Right $ W.Enumerator e From 3265d7a717cbaafbdc9024d3e5cd09f4a6e10642 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 06:03:03 -0700 Subject: [PATCH 206/624] Match refactorings in web-routes-quasi --- Yesod/Dispatch.hs | 30 +++++++----------------------- Yesod/Handler.hs | 3 +-- Yesod/Yesod.hs | 2 +- 3 files changed, 9 insertions(+), 26 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index ba966463..8078d42f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -58,38 +58,21 @@ explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q [Dec] mkYesodGeneral name clazzes isSub res = do let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") let site = mkName $ "site" ++ name let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] explode <- [|explodeHandler|] - CreateRoutesResult x _ z <- createRoutes CreateRoutesSettings + QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp , crArgument = ConT $ mkName name , crExplode = explode , crResources = res , crSite = site + , crMaster = if isSub then Right clazzes else Left (ConT name') } - let master = if isSub - then VarT (mkName "master") - else ConT (mkName name) - murl = ConT ''Routes `AppT` master - sub = ConT $ mkName name - surl = ConT ''Routes `AppT` sub - let yType = ConT ''QuasiSite - `AppT` ConT ''YesodApp - `AppT` surl - `AppT` sub - `AppT` murl - `AppT` master - let ctx = if isSub - then map (flip ClassP [master]) clazzes - else [] - tvs = [PlainTV $ mkName "master" | isSub] - let y' = SigD site $ ForallT tvs ctx yType - return $ (if isSub then id else (:) yes) [y', z, tySyn, x] + return $ (if isSub then id else (:) yes) [w, x, y, z] toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do @@ -120,13 +103,13 @@ toWaiApp' y resource session env = do onRequest y rr print pathSegments -- FIXME remove let ya = case eurl of - Nothing -> runHandler (errorHandler y NotFound) + Left _ -> runHandler (errorHandler y NotFound) render Nothing id y id - Just url -> quasiDispatch site + Right url -> quasiDispatch site render url id @@ -134,7 +117,8 @@ toWaiApp' y resource session env = do id (badMethodApp method) method - let eh er = runHandler (errorHandler y er) render eurl id y id + let eurl' = either (const Nothing) Just eurl + let eh er = runHandler (errorHandler y er) render eurl' id y id unYesodApp ya eh rr types >>= responseToWaiResponse cleanupSegments :: [B.ByteString] -> [String] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 17e16413..a6b38aa8 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -49,6 +49,7 @@ module Yesod.Handler import Yesod.Request import Yesod.Response import Web.Mime +import Web.Routes.Quasi (Routes) import Control.Exception hiding (Handler) import Control.Applicative @@ -63,8 +64,6 @@ import qualified Network.Wai as W import Data.Convertible.Text (cs) -type family Routes y - data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f4939fe2..e2a1888b 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -22,7 +22,7 @@ import Yesod.Json import Web.Routes.Quasi (QuasiSite (..)) class YesodSite y where - getSite :: QuasiSite YesodApp (Routes y) y (Routes y) y + getSite :: QuasiSite YesodApp y y class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. From 26ad604a19f0e2b478bdf945061f44ea90fac638 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 11:03:36 -0700 Subject: [PATCH 207/624] Began major refactoring of code --- Yesod/Dispatch.hs | 92 ++++++++++++++++++++++++++++++--- Yesod/Hamlet.hs | 33 +++++++----- Yesod/Handler.hs | 26 +++++++--- Yesod/Helpers/Auth.hs | 16 +++--- Yesod/Request.hs | 117 +++++++++++++----------------------------- Yesod/Response.hs | 112 +++++++++------------------------------- 6 files changed, 192 insertions(+), 204 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 8078d42f..6fcd0822 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -32,15 +32,34 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe) -import Web.Encodings (parseHttpAccept) +import Web.Encodings import Web.Mime import Data.List (intercalate) import Web.Routes (encodePathInfo, decodePathInfo) -mkYesod :: String -> [Resource] -> Q [Dec] +import Control.Concurrent.MVar +import Control.Arrow ((***)) +import Data.Convertible.Text (cs) + +import Data.Time.Clock + +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. +-- Use 'parseRoutes' in generate to create the 'Resource's. +mkYesod :: String -- ^ name of the argument datatype + -> [Resource] + -> Q [Dec] mkYesod name = mkYesodGeneral name [] False -mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. +-- Use 'parseRoutes' in generate to create the 'Resource's. In general, a +-- subsite is not executable by itself, but instead provides functionality to +-- be embedded in other sites. +mkYesodSub :: String -- ^ name of the argument datatype + -> [Name] -- ^ a list of classes the master datatype must be an instance of + -> [Resource] + -> Q [Dec] mkYesodSub name clazzes = mkYesodGeneral name clazzes True explodeHandler :: HasReps c @@ -74,6 +93,8 @@ mkYesodGeneral name clazzes isSub res = do } return $ (if isSub then id else (:) yes) [w, x, y, z] +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. You can use 'basicHandler' if you wish. toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do key' <- encryptKey a @@ -82,7 +103,7 @@ toWaiApp a = do $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession encryptedCookies key' mins + $ \thePath -> clientsession encryptedCookies key' mins -- FIXME allow user input for encryptedCookies $ toWaiApp' a thePath toWaiApp' :: Yesod y @@ -91,7 +112,7 @@ toWaiApp' :: Yesod y -> [(B.ByteString, B.ByteString)] -> W.Request -> IO W.Response -toWaiApp' y resource session env = do +toWaiApp' y resource session' env = do let site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env @@ -99,7 +120,7 @@ toWaiApp' y resource session env = do eurl = quasiParse site pathSegments render u = approot y ++ '/' : encodePathInfo (fixSegs $ quasiRender site u) - rr <- parseWaiRequest env session + rr <- parseWaiRequest env session' onRequest y rr print pathSegments -- FIXME remove let ya = case eurl of @@ -153,3 +174,62 @@ fixSegs [x] | any (== '.') x = [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs + +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' + session'' = map (cs *** cs) session' + 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) + +-- | 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) + +responseToWaiResponse :: (W.Status, [Header], ContentType, Content) + -> IO W.Response +responseToWaiResponse (sc, hs, ct, c) = do + hs' <- mapM headerToPair hs + let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' + return $ W.Response sc hs'' $ case c of + ContentFile fp -> Left fp + ContentEnum e -> Right $ W.Enumerator e + +-- | 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) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 343b664e..ab185393 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -1,15 +1,20 @@ {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet - ( hamletToContent - , hamletToRepHtml - , PageContent (..) - , Hamlet + ( -- * Hamlet library + Hamlet , hamlet , HtmlContent (..) + -- * Convert to something displayable + , hamletToContent + , hamletToRepHtml + -- * Page templates + , PageContent (..) + -- * data-object , HtmlObject ) where @@ -22,12 +27,19 @@ import Data.Convertible.Text import Data.Object import Control.Arrow ((***)) +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> Hamlet url IO () data PageContent url = PageContent { pageTitle :: HtmlContent , pageHead :: Hamlet url IO () , pageBody :: Hamlet url IO () } +-- FIXME some typeclasses for the stuff below? +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content hamletToContent h = do render <- getUrlRender @@ -40,16 +52,9 @@ hamletToContent h = do Right ((), x) -> return $ Right x iter' iter seed text = iter seed $ cs text -hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml -hamletToRepHtml h = do - c <- hamletToContent h - return $ RepHtml c - --- FIXME some type of JSON combined output... ---hamletToRepHtmlJson :: x --- -> (x -> Hamlet (Routes y) IO ()) --- -> (x -> Json) --- -> Handler y RepHtmlJson +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Hamlet (Routes sub) IO () -> GHandler sub master RepHtml +hamletToRepHtml = fmap RepHtml . hamletToContent instance Monad m => ConvertSuccess String (Hamlet url m ()) where convertSuccess = outputHtml . Unencoded . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a6b38aa8..8bc3fce9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -78,7 +78,7 @@ newtype YesodApp = YesodApp :: (ErrorResponse -> YesodApp) -> Request -> [ContentType] - -> IO Response + -> IO (W.Status, [Header], ContentType, Content) } ------ Handler monad @@ -164,28 +164,28 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts + (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs - return $ Response (getStatus e) hs' ct c + return $ (getStatus e, hs', ct, c) let sendFile' ct fp = do c <- BL.readFile fp - return $ Response W.Status200 headers ct $ cs c + return (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 "" + return (getRedirectStatus rt, hs, TypePlain, cs "") HCSpecial (SendFile ct fp) -> Control.Exception.catch (sendFile' ct fp) (handleError . toErrorHandler) HCContent a -> do (ct, c) <- chooseRep a cts - return $ Response W.Status200 headers ct c + return (W.Status200, headers, ct, c) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error" + return (W.Status500, [], TypePlain, cs "Internal Server Error") ------ Special handlers specialResponse :: SpecialResponse -> GHandler sub master a @@ -231,3 +231,15 @@ header a = addHeader . Header a addHeader :: Header -> GHandler sub master () addHeader h = Handler $ \_ -> return ([h], HCContent ()) + +getStatus :: ErrorResponse -> W.Status +getStatus NotFound = W.Status404 +getStatus (InternalError _) = W.Status500 +getStatus (InvalidArgs _) = W.Status400 +getStatus PermissionDenied = W.Status403 +getStatus (BadMethod _) = W.Status405 + +getRedirectStatus :: RedirectType -> W.Status +getRedirectStatus RedirectPermanent = W.Status301 +getRedirectStatus RedirectTemporary = W.Status302 +getRedirectStatus RedirectSeeOther = W.Status303 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c9e9c10f..f767c9cb 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -36,12 +36,10 @@ import Yesod import Data.Convertible.Text import Control.Monad.Attempt -import qualified Data.ByteString.Char8 as B8 import Data.Maybe import Data.Typeable (Typeable) import Control.Exception (Exception) -import Control.Applicative ((<$>)) -- FIXME check referer header to determine destination @@ -189,16 +187,16 @@ getLogout = do redirectToDest RedirectTemporary $ defaultDest y -- | 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 +maybeIdentifier :: RequestReader m => m (Maybe String) +maybeIdentifier = do + s <- session + return $ listToMaybe $ s authCookieName -- | Gets the display name for a user if available. -displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) +displayName :: RequestReader m => m (Maybe String) displayName = do - rr <- getRequest - return $ fmap cs $ lookup (B8.pack authDisplayName) $ reqSession rr + s <- session + return $ listToMaybe $ s authDisplayName -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5c1ae5e1..880420ca 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,10 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE NoMonomorphismRestriction #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -15,75 +10,73 @@ -- Stability : Stable -- Portability : portable -- --- Code for extracting parameters from requests. +-- | Provides a parsed version of the raw 'W.Request' data. -- --------------------------------------------------------- module Yesod.Request ( - -- * Request - Request (..) + -- * Request datatype + RequestBodyContents + , Request (..) , RequestReader (..) + -- * Convenience functions , waiRequest - , cookies + , languages + -- * Lookup parameters , getParams , postParams - , languages - , parseWaiRequest - -- * Parameter + , cookies + , session + -- * Parameter type synonyms , ParamName , ParamValue , ParamError -#if TEST - , testSuite -#endif ) where import qualified Network.Wai as W 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.IO.Class -import Control.Concurrent.MVar import Control.Monad (liftM) -#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 +-- | The reader monad specialized for 'Request'. class Monad m => 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 list of supported languages supplied by the user. +languages :: RequestReader m => m [Language] +languages = reqLangs `liftM` getRequest --- | Get the req 'W.Request' value. +-- | Get the request\'s 'W.Request' value. waiRequest :: RequestReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest +-- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)] , [(ParamName, FileInfo String BL.ByteString)] ) --- | The req information passed through W, cleaned up a bit. +-- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - , reqSession :: [(B.ByteString, B.ByteString)] + -- | Session data stored in a cookie via the clientsession package. FIXME explain how to extend. + , reqSession :: [(ParamName, ParamValue)] + -- | The POST parameters and submitted files. This is stored in an IO + -- thunk, which essentially means it will be computed once at most, but + -- only if requested. This allows avoidance of the potentially costly + -- parsing of POST bodies for pages which do not use them. , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request + -- | Languages which the client supports. , reqLangs :: [Language] } @@ -94,8 +87,10 @@ multiLookup ((k, v):rest) pn | otherwise = multiLookup rest pn -- | All GET paramater values with the given name. -getParams :: Request -> ParamName -> [ParamValue] -getParams rr = multiLookup $ reqGetParams rr +getParams :: RequestReader m => m (ParamName -> [ParamValue]) +getParams = do + rr <- getRequest + return $ multiLookup $ reqGetParams rr -- | All POST paramater values with the given name. postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue]) @@ -103,52 +98,14 @@ 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 - where - equals f x y = f y == x +cookies :: RequestReader m => m (ParamName -> [ParamValue]) +cookies = do + rr <- getRequest + return $ multiLookup $ 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 +-- | All session data with the given name. +session :: RequestReader m => m (ParamName -> [ParamValue]) +session = do + rr <- getRequest + return $ multiLookup $ reqSession rr diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 66ff9b1d..0f1f9f3e 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- @@ -19,42 +18,28 @@ -- --------------------------------------------------------- module Yesod.Response - ( -- * Representations + ( -- * Content Content (..) + , toContent + -- * Representations , ChooseRep , HasReps (..) , defChooseRep - , ioTextToContent - -- ** Convenience wrappers - , staticRep -- ** Specific content types , RepHtml (..) , RepJson (..) , RepHtmlJson (..) , RepPlain (..) , RepXml (..) - -- * 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 @@ -62,22 +47,19 @@ import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Convertible.Text -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 Web.Mime hiding (testSuite) -#else import Yesod.Request import Web.Mime -#endif - -#if TEST -import Test.Framework (testGroup, Test) -#endif +-- | There are two different methods available for providing content in the +-- response: via files and enumerators. The former allows server to use +-- optimizations (usually the sendfile system call) for serving static files. +-- The latter is a space-efficient approach to content. +-- +-- It can be tedious to write enumerators; often times, you will be well served +-- to use 'toContent'. data Content = ContentFile FilePath | ContentEnum (forall a. (a -> B.ByteString -> IO (Either a a)) @@ -94,13 +76,18 @@ 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 (IO Text) Content where + convertSuccess = swapEnum . WE.fromLBS' . fmap cs -type ChooseRep = [ContentType] -> IO (ContentType, Content) +-- | A synonym for 'convertSuccess' to make the desired output type explicit. +toContent :: ConvertSuccess x Content => x -> Content +toContent = cs --- | It would be nice to simplify 'Content' to the point where this is --- unnecesary. -ioTextToContent :: IO Text -> Content -ioTextToContent = swapEnum . WE.fromLBS' . fmap cs +-- | A function which gives targetted representations of content based on the +-- content-types the user accepts. +type ChooseRep = + [ContentType] -- ^ list of content-types user accepts, ordered by preference + -> IO (ContentType, Content) swapEnum :: W.Enumerator -> Content swapEnum (W.Enumerator e) = ContentEnum e @@ -110,13 +97,16 @@ class HasReps a where chooseRep :: a -> ChooseRep -- | A helper method for generating 'HasReps' instances. +-- +-- This function should be given a list of pairs of content type and conversion +-- functions. If none of the content types match, the first pair is used. 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" + [] -> error "Empty reps to defChooseRep" (x:_) -> x c' <- c a return (ct, c') @@ -141,13 +131,6 @@ instance HasReps [(ContentType, Content)] where where go = simpleContentType . contentTypeToString --- | 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) @@ -167,19 +150,12 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (TypeXml, c) -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 = @@ -197,13 +173,6 @@ data ErrorResponse = | BadMethod String deriving (Show, Eq) -getStatus :: ErrorResponse -> W.Status -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'. data Header = @@ -211,36 +180,3 @@ data Header = | 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 $ contentTypeToString 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 From 09b07a5aad74aa2f117f70b181430a677a18ad86 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 12:04:45 -0700 Subject: [PATCH 208/624] Continued refactoring; cleaned up Yesod.Handler --- Yesod.hs | 25 ++------ Yesod/{Response.hs => Content.hs} | 55 +---------------- Yesod/Definitions.hs | 6 +- Yesod/Dispatch.hs | 3 +- Yesod/Form.hs | 2 +- Yesod/Hamlet.hs | 3 +- Yesod/Handler.hs | 99 +++++++++++++++++++------------ Yesod/Json.hs | 12 ++-- Yesod/Yesod.hs | 3 +- yesod.cabal | 13 ++-- 10 files changed, 92 insertions(+), 129 deletions(-) rename Yesod/{Response.hs => Content.hs} (75%) diff --git a/Yesod.hs b/Yesod.hs index 988a4baf..bc15e2d4 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,21 +1,8 @@ {-# 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.Content , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler @@ -27,25 +14,25 @@ module Yesod , Application , Method (..) , cs + , liftIO ) where #if TEST -import Yesod.Response hiding (testSuite) -import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) import Yesod.Json hiding (testSuite) #else -import Yesod.Response -import Yesod.Request import Web.Mime import Yesod.Json #endif +import Yesod.Content +import Yesod.Request import Yesod.Dispatch import Yesod.Form import Yesod.Yesod import Yesod.Definitions -import Yesod.Handler +import Yesod.Handler hiding (runHandler) import Network.Wai (Application, Method (..)) import Yesod.Hamlet import Data.Convertible.Text (cs) +import Control.Monad.IO.Class (liftIO) diff --git a/Yesod/Response.hs b/Yesod/Content.hs similarity index 75% rename from Yesod/Response.hs rename to Yesod/Content.hs index 0f1f9f3e..dfafc456 100644 --- a/Yesod/Response.hs +++ b/Yesod/Content.hs @@ -4,20 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# 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 + +module Yesod.Content ( -- * Content Content (..) , toContent @@ -31,13 +19,6 @@ module Yesod.Response , RepHtmlJson (..) , RepPlain (..) , RepXml (..) - -- * Special responses - , RedirectType (..) - , SpecialResponse (..) - -- * Error responses - , ErrorResponse (..) - -- * Header - , Header (..) ) where import Data.Maybe (mapMaybe) @@ -50,7 +31,6 @@ import Data.Convertible.Text import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import Yesod.Request import Web.Mime -- | There are two different methods available for providing content in the @@ -149,34 +129,3 @@ instance HasReps RepPlain where newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (TypeXml, c) - --- | Different types of redirects. -data RedirectType = RedirectPermanent - | RedirectTemporary - | RedirectSeeOther - deriving (Show, Eq) - --- | 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 - | BadMethod String - deriving (Show, Eq) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - deriving (Eq, Show) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index fb51a1ed..a6140165 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -15,7 +15,8 @@ -- --------------------------------------------------------- module Yesod.Definitions - ( Approot + ( -- * Type synonyms + Approot , Language -- * Constant values , authCookieName @@ -24,9 +25,12 @@ module Yesod.Definitions , langKey , destCookieName , destCookieTimeout + -- * Other + , Routes ) where import Data.ByteString.Char8 (pack, ByteString) +import Web.Routes.Quasi (Routes) -- | 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 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 6fcd0822..3e356561 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -11,10 +11,11 @@ module Yesod.Dispatch ) where import Yesod.Handler -import Yesod.Response +import Yesod.Content import Yesod.Definitions import Yesod.Yesod import Yesod.Request +import Yesod.Internal import Web.Routes.Quasi import Language.Haskell.TH.Syntax diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4f01afd5..04f1ed9a 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -20,7 +20,6 @@ module Yesod.Form ) where import Yesod.Request -import Yesod.Response (ErrorResponse) import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) @@ -28,6 +27,7 @@ import Data.Convertible.Text import Control.Monad.Attempt import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class (MonadIO) +import Yesod.Internal noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)" diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index ab185393..6492e557 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -21,8 +21,9 @@ module Yesod.Hamlet import Text.Hamlet import Text.Hamlet.Monad (outputHtml) -import Yesod.Response +import Yesod.Content import Yesod.Handler +import Yesod.Definitions import Data.Convertible.Text import Data.Object import Control.Arrow ((***)) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 8bc3fce9..00ae8ec4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -23,17 +23,14 @@ module Yesod.Handler ( -- * Handler monad Handler , GHandler + -- ** Read information from handler , getYesod , getYesodMaster , getUrlRender , getUrlRenderMaster , getRoute - , getRouteMaster - , runHandler - , liftIO - , YesodApp (..) - , Routes - -- * Special handlers + -- * Special responses + , RedirectType (..) , redirect , sendFile , notFound @@ -44,12 +41,16 @@ module Yesod.Handler , addCookie , deleteCookie , header + -- * Internal Yesod + , runHandler + , YesodApp (..) ) where import Yesod.Request -import Yesod.Response +import Yesod.Content +import Yesod.Internal +import Yesod.Definitions import Web.Mime -import Web.Routes.Quasi (Routes) import Control.Exception hiding (Handler) import Control.Applicative @@ -73,6 +74,21 @@ data HandlerData sub master = HandlerData , handlerToMaster :: Routes sub -> Routes master } +-- | A generic handler monad, which can have a different subsite and master +-- site. This monad is a combination of reader for basic arguments, a writer +-- for headers, and an error-type monad for handling special responses. +newtype GHandler sub master a = Handler { + unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) +} + +-- | A 'GHandler' limited to the case where the master and sub sites are the +-- same. This is the usual case for application writing; only code written +-- specifically as a subsite need been concerned with the more general variety. +type Handler yesod = GHandler yesod yesod + +-- | An extension of the basic WAI 'W.Application' datatype to provide extra +-- features needed by Yesod. Users should never need to use this directly, as +-- the 'GHandler' monad and template haskell code should hide it away. newtype YesodApp = YesodApp { unYesodApp :: (ErrorResponse -> YesodApp) @@ -81,17 +97,11 @@ newtype YesodApp = YesodApp -> IO (W.Status, [Header], ContentType, Content) } ------- Handler monad -newtype GHandler sub master a = Handler { - unHandler :: HandlerData sub master - -> IO ([Header], HandlerContents a) -} -type Handler yesod = GHandler yesod yesod - data HandlerContents a = - HCSpecial SpecialResponse + HCContent a | HCError ErrorResponse - | HCContent a + | HCSendFile ContentType FilePath + | HCRedirect RedirectType String instance Functor (GHandler sub master) where fmap = liftM @@ -105,9 +115,10 @@ instance Monad (GHandler sub master) where (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 + HCContent a -> unHandler (f a) rr + HCError e -> return ([], HCError e) + HCSendFile ct fp -> return ([], HCSendFile ct fp) + HCRedirect rt url -> return ([], HCRedirect rt url) return (headers ++ headers', c') instance MonadIO (GHandler sub master) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') @@ -119,28 +130,31 @@ instance RequestReader (GHandler sub master) where getData :: GHandler sub master (HandlerData sub master) getData = Handler $ \r -> return ([], HCContent r) +-- | Get the application argument. getYesod :: GHandler sub master sub getYesod = handlerSub <$> getData +-- | Get the master site appliation argument. getYesodMaster :: GHandler sub master master getYesodMaster = handlerMaster <$> getData +-- | Get the URL rendering function. getUrlRender :: GHandler sub master (Routes sub -> String) getUrlRender = do d <- getData return $ handlerRender d . handlerToMaster d +-- | Get the URL rendering function for the master site. getUrlRenderMaster :: GHandler sub master (Routes master -> String) getUrlRenderMaster = handlerRender <$> getData +-- | Get the route requested by the user. If this is a 404 response- where the +-- user requested an invalid route- this function will return 'Nothing'. getRoute :: GHandler sub master (Maybe (Routes sub)) getRoute = handlerRoute <$> getData -getRouteMaster :: GHandler sub master (Maybe (Routes master)) -getRouteMaster = do - d <- getData - return $ handlerToMaster d <$> handlerRoute d - +-- | Function used internally by Yesod in the process of converting a +-- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c -> (Routes master -> String) @@ -171,45 +185,48 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do c <- BL.readFile fp return (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 (getRedirectStatus rt, hs, TypePlain, cs "") - HCSpecial (SendFile ct fp) -> Control.Exception.catch - (sendFile' ct fp) - (handleError . toErrorHandler) HCContent a -> do (ct, c) <- chooseRep a cts return (W.Status200, headers, ct, c) + HCError e -> handleError e + HCRedirect rt loc -> do + let hs = Header "Location" loc : headers + return (getRedirectStatus rt, hs, TypePlain, cs "") + HCSendFile ct fp -> Control.Exception.catch + (sendFile' ct fp) + (handleError . toErrorHandler) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return (W.Status500, [], TypePlain, cs "Internal Server Error") ------- Special handlers -specialResponse :: SpecialResponse -> GHandler sub master a -specialResponse er = Handler $ \_ -> return ([], HCSpecial er) - -- | Redirect to the given URL. redirect :: RedirectType -> String -> GHandler sub master a -redirect rt = specialResponse . Redirect rt +redirect rt url = Handler $ \_ -> return ([], HCRedirect rt url) +-- | Bypass remaining handler code and output the given file. +-- +-- For some backends, this is more efficient than reading in the file to +-- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = specialResponse . SendFile ct +sendFile ct fp = Handler $ \_ -> return ([], HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound +-- | Return a 405 method not supported page. badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w +-- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a permissionDenied = failure PermissionDenied +-- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a invalidArgs = failure . InvalidArgs @@ -243,3 +260,9 @@ getRedirectStatus :: RedirectType -> W.Status getRedirectStatus RedirectPermanent = W.Status301 getRedirectStatus RedirectTemporary = W.Status302 getRedirectStatus RedirectSeeOther = W.Status303 + +-- | Different types of redirects. +data RedirectType = RedirectPermanent + | RedirectTemporary + | RedirectSeeOther + deriving (Show, Eq) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index b6848e9c..6b81db07 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -20,15 +20,10 @@ import Control.Applicative import Data.Text (Text) import Web.Encodings import Yesod.Hamlet +import Yesod.Definitions import Control.Monad (when) -#if TEST -import Yesod.Response hiding (testSuite) -import Data.Text.Lazy (unpack) -import qualified Data.Text as T -#else -import Yesod.Response -#endif import Yesod.Handler +import Yesod.Content #if TEST import Test.Framework (testGroup, Test) @@ -36,7 +31,8 @@ import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck -import Control.Monad (when) +import Data.Text.Lazy (unpack) +import qualified Data.Text as T #endif newtype Json url m a = Json { unJson :: Hamlet url m a } diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index e2a1888b..eea29116 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,7 +8,7 @@ module Yesod.Yesod , getApproot ) where -import Yesod.Response +import Yesod.Content import Yesod.Request import Yesod.Hamlet import Yesod.Handler @@ -18,6 +18,7 @@ import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W import Yesod.Definitions import Yesod.Json +import Yesod.Internal import Web.Routes.Quasi (QuasiSite (..)) diff --git a/yesod.cabal b/yesod.cabal index eacce498..2aee6820 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -54,19 +54,20 @@ library web-routes-quasi >= 0.0 && < 0.1, hamlet >= 0.0 && < 0.1 exposed-modules: Yesod - Yesod.Request - Yesod.Response + Yesod.Content Yesod.Definitions + Yesod.Dispatch Yesod.Form Yesod.Hamlet - Yesod.Json Yesod.Handler - Yesod.Dispatch + Yesod.Internal + Yesod.Json + Yesod.Request Yesod.Yesod - Yesod.Helpers.Auth - Yesod.Helpers.Static Yesod.Helpers.AtomFeed + Yesod.Helpers.Auth Yesod.Helpers.Sitemap + Yesod.Helpers.Static Web.Mime ghc-options: -Wall From 3701e3c490b843d71bcdc59bc0ed9d1478e57093 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 12:29:20 -0700 Subject: [PATCH 209/624] Continued refactoring; Yesod.Yesod --- Yesod/Hamlet.hs | 6 +-- Yesod/Handler.hs | 6 +++ Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Auth.hs | 12 ++---- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Internal.hs | 25 ++++++++++++ Yesod/Json.hs | 14 +++---- Yesod/Yesod.hs | 84 ++++++++++++++++++++------------------- 8 files changed, 89 insertions(+), 62 deletions(-) create mode 100644 Yesod/Internal.hs diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 6492e557..ee342f9d 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -41,9 +41,9 @@ data PageContent url = PageContent -- FIXME some typeclasses for the stuff below? -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content +hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content hamletToContent h = do - render <- getUrlRender + render <- getUrlRenderMaster return $ ContentEnum $ go render where go render iter seed = do @@ -54,7 +54,7 @@ hamletToContent h = do iter' iter seed text = iter seed $ cs text -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Routes sub) IO () -> GHandler sub master RepHtml +hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent instance Monad m => ConvertSuccess String (Hamlet url m ()) where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 00ae8ec4..aafbaeed 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -29,6 +29,7 @@ module Yesod.Handler , getUrlRender , getUrlRenderMaster , getRoute + , getRouteToMaster -- * Special responses , RedirectType (..) , redirect @@ -153,6 +154,11 @@ getUrlRenderMaster = handlerRender <$> getData getRoute :: GHandler sub master (Maybe (Routes sub)) getRoute = handlerRoute <$> getData +-- | Get the function to promote a route for a subsite to a route for the +-- master site. +getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) +getRouteToMaster = handlerToMaster <$> getData + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 373bef34..046e83a8 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -29,7 +29,7 @@ newtype RepAtom = RepAtom Content instance HasReps RepAtom where chooseRep (RepAtom c) _ = return (TypeAtom, c) -atomFeed :: AtomFeed (Routes sub) -> GHandler sub master RepAtom +atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f767c9cb..1a01edf5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -72,15 +72,9 @@ getOpenIdR = do case getParams rr "dest" of [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x - y <- getYesodMaster - let html = template (getParams rr "message", id) - let pc = PageContent - { pageTitle = cs "Log in via OpenID" - , pageHead = return () - , pageBody = html - } - content <- hamletToContent $ applyLayout y pc rr - return $ RepHtml content + rtom <- getRouteToMaster + let html = template (getParams rr "message", rtom) + applyLayout "Log in via OpenID" $ html where urlForward (_, wrapper) = wrapper OpenIdForward hasMessage = not . null . fst diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 542224a2..361791b7 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -65,7 +65,7 @@ template = [$hamlet| %priority $url.priority.show.cs$ |] -sitemap :: [SitemapUrl (Routes sub)] -> GHandler sub master RepXml +sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml sitemap = fmap RepXml . hamletToContent . template robots :: Routes sub -- ^ sitemap url diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs new file mode 100644 index 00000000..0f89fdda --- /dev/null +++ b/Yesod/Internal.hs @@ -0,0 +1,25 @@ +-- | Normal users should never need access to these. +module Yesod.Internal + ( -- * Error responses + ErrorResponse (..) + -- * Header + , Header (..) + ) where + +-- | 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 [(String, String)] + | PermissionDenied + | BadMethod String + deriving (Show, Eq) + +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie Int String String + | DeleteCookie String + | Header String String + deriving (Eq, Show) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 6b81db07..e927ab49 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -35,26 +35,26 @@ import Data.Text.Lazy (unpack) import qualified Data.Text as T #endif -newtype Json url m a = Json { unJson :: Hamlet url m a } +newtype Json url a = Json { unJson :: Hamlet url IO a } deriving (Functor, Applicative, Monad) -jsonToContent :: Json (Routes sub) IO () -> GHandler sub master Content +jsonToContent :: Json (Routes master) () -> GHandler sub master Content jsonToContent = hamletToContent . unJson htmlContentToText :: HtmlContent -> Text htmlContentToText (Encoded t) = t htmlContentToText (Unencoded t) = encodeHtml t -jsonScalar :: Monad m => HtmlContent -> Json url m () +jsonScalar :: HtmlContent -> Json url () jsonScalar s = Json $ do outputString "\"" output $ encodeJson $ htmlContentToText s outputString "\"" -jsonList :: Monad m => [Json url m ()] -> Json url m () +jsonList :: [Json url ()] -> Json url () jsonList = jsonList' . fromList -jsonList' :: Monad m => Enumerator (Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonList' (Enumerator enum) = do Json $ outputString "[" _ <- enum go False @@ -65,10 +65,10 @@ jsonList' (Enumerator enum) = do () <- j return $ Right True -jsonMap :: Monad m => [(Json url m (), Json url m ())] -> Json url m () +jsonMap :: [(Json url (), Json url ())] -> Json url () jsonMap = jsonMap' . fromList -jsonMap' :: Monad m => Enumerator (Json url m (), Json url m ()) (Json url m) -> Json url m () -- FIXME simplify type +jsonMap' :: Enumerator (Json url (), Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonMap' (Enumerator enum) = do Json $ outputString "{" _ <- enum go False diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index eea29116..ea19619d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,11 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( Yesod (..) , YesodSite (..) - , simpleApplyLayout + , applyLayout , applyLayoutJson - , getApproot ) where import Yesod.Content @@ -36,15 +36,18 @@ class YesodSite a => Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep + errorHandler :: Yesod y + => a + -> ErrorResponse + -> Handler y ChooseRep errorHandler _ = defaultErrorHandler -- | 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 url -- FIXME not so good, should be Routes y - -> Request - -> Hamlet url IO () - applyLayout _ p _ = [$hamlet| + rawApplyLayout :: a + -> PageContent (Routes a) + -> Request + -> Hamlet (Routes a) IO () + rawApplyLayout _ p _ = [$hamlet| !!! %html %head @@ -62,11 +65,27 @@ class YesodSite a => Yesod a where -- trailing slash. approot :: a -> Approot +-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. +applyLayout :: Yesod master + => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ body + -> GHandler sub master RepHtml +applyLayout t b = do + let pc = PageContent + { pageTitle = cs t + , pageHead = return () + , pageBody = b + } + y <- getYesodMaster + rr <- getRequest + content <- hamletToContent $ rawApplyLayout y pc rr + return $ RepHtml content + applyLayoutJson :: Yesod master => String -- ^ title -> x - -> (x -> Hamlet (Routes sub) IO ()) - -> (x -> Json (Routes sub) IO ()) + -> (x -> Hamlet (Routes master) IO ()) + -> (x -> Json (Routes master) ()) -> GHandler sub master RepHtmlJson applyLayoutJson t x toH toJ = do let pc = PageContent @@ -76,49 +95,32 @@ applyLayoutJson t x toH toJ = do } y <- getYesodMaster rr <- getRequest - html <- hamletToContent $ applyLayout y pc rr + html <- hamletToContent $ rawApplyLayout y pc rr json <- jsonToContent $ toJ x return $ RepHtmlJson html json --- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. -simpleApplyLayout :: Yesod master - => String -- ^ title - -> Hamlet (Routes sub) IO () -- ^ body - -> GHandler sub master RepHtml -simpleApplyLayout t b = do - let pc = PageContent - { pageTitle = cs t - , pageHead = return () - , pageBody = b - } - y <- getYesodMaster - rr <- getRequest - content <- hamletToContent $ applyLayout y pc rr - return $ RepHtml content +applyLayout' :: Yesod master + => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ body + -> GHandler sub master ChooseRep +applyLayout' s = fmap chooseRep . applyLayout s -getApproot :: Yesod y => Handler y Approot -getApproot = approot `fmap` getYesod - -simpleApplyLayout' :: Yesod master - => String -- ^ title - -> Hamlet (Routes sub) IO () -- ^ body - -> GHandler sub master ChooseRep -simpleApplyLayout' t = fmap chooseRep . simpleApplyLayout t - -defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep +defaultErrorHandler :: Yesod y + => ErrorResponse + -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - simpleApplyLayout' "Not Found" $ [$hamlet| + applyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $helper$ |] r where helper = Unencoded . cs . W.pathInfo defaultErrorHandler PermissionDenied = - simpleApplyLayout' "Permission Denied" $ [$hamlet| + applyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied|] () defaultErrorHandler (InvalidArgs ia) = - simpleApplyLayout' "Invalid Arguments" $ [$hamlet| + applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ias pair @@ -128,12 +130,12 @@ defaultErrorHandler (InvalidArgs ia) = where ias _ = map (cs *** cs) ia defaultErrorHandler (InternalError e) = - simpleApplyLayout' "Internal Server Error" $ [$hamlet| + applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error %p $cs$ |] e defaultErrorHandler (BadMethod m) = - simpleApplyLayout' "Bad Method" $ [$hamlet| + applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported %p Method "$cs$" not supported |] m From c320d2a45b2cf1fe8288dcd5c453404a389d047d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 23 Apr 2010 12:35:36 -0700 Subject: [PATCH 210/624] Documented Yesod.Yesod --- Yesod/Yesod.hs | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index ea19619d..ed08fa04 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -2,10 +2,14 @@ {-# LANGUAGE RankNTypes #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod - ( Yesod (..) + ( -- * Type classes + Yesod (..) , YesodSite (..) + -- * Convenience functions , applyLayout , applyLayoutJson + -- * Defaults + , defaultErrorHandler ) where import Yesod.Content @@ -22,10 +26,18 @@ import Yesod.Internal import Web.Routes.Quasi (QuasiSite (..)) +-- | This class is automatically instantiated when you use the template haskell +-- mkYesod function. class YesodSite y where getSite :: QuasiSite YesodApp y y +-- | Define settings for a Yesod applications. The only required setting is +-- 'approot'; other than that, there are intelligent defaults. class YesodSite a => Yesod a where + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. + approot :: a -> Approot + -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile @@ -42,12 +54,12 @@ class YesodSite a => Yesod a where -> Handler y ChooseRep errorHandler _ = defaultErrorHandler - -- | Applies some form of layout to <title> and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit. - rawApplyLayout :: a - -> PageContent (Routes a) - -> Request - -> Hamlet (Routes a) IO () - rawApplyLayout _ p _ = [$hamlet| + -- | Applies some form of layout to <title> and <body> contents of a page. + defaultLayout :: a + -> PageContent (Routes a) + -> Request + -> Hamlet (Routes a) IO () + defaultLayout _ p _ = [$hamlet| !!! %html %head @@ -61,11 +73,7 @@ class YesodSite a => Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - approot :: a -> Approot - --- | A convenience wrapper around 'simpleApplyLayout for HTML-only data. +-- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title -> Hamlet (Routes master) IO () -- ^ body @@ -78,9 +86,11 @@ applyLayout t b = do } y <- getYesodMaster rr <- getRequest - content <- hamletToContent $ rawApplyLayout y pc rr + content <- hamletToContent $ defaultLayout y pc rr return $ RepHtml content +-- | Provide both an HTML and JSON representation for a piece of data, using +-- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title -> x @@ -95,7 +105,7 @@ applyLayoutJson t x toH toJ = do } y <- getYesodMaster rr <- getRequest - html <- hamletToContent $ rawApplyLayout y pc rr + html <- hamletToContent $ defaultLayout y pc rr json <- jsonToContent $ toJ x return $ RepHtmlJson html json @@ -105,6 +115,7 @@ applyLayout' :: Yesod master -> GHandler sub master ChooseRep applyLayout' s = fmap chooseRep . applyLayout s +-- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep From a6ab2db6a7565def7636f7fbbf67126e5ac2d06c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 25 Apr 2010 11:05:59 -0700 Subject: [PATCH 211/624] Minor changes --- Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 2 +- Yesod/Json.hs | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index aafbaeed..974b6b0a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -186,7 +186,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let handleError e = do (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs - return $ (getStatus e, hs', ct, c) + return (getStatus e, hs', ct, c) let sendFile' ct fp = do c <- BL.readFile fp return (W.Status200, headers, ct, cs c) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1a01edf5..675272e5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -74,7 +74,7 @@ getOpenIdR = do (x:_) -> addCookie destCookieTimeout destCookieName x rtom <- getRouteToMaster let html = template (getParams rr "message", rtom) - applyLayout "Log in via OpenID" $ html + applyLayout "Log in via OpenID" html where urlForward (_, wrapper) = wrapper OpenIdForward hasMessage = not . null . fst diff --git a/Yesod/Json.hs b/Yesod/Json.hs index e927ab49..d848cec2 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,3 +1,4 @@ +-- FIXME document {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} module Yesod.Json From 84abd28af90ce483f8a717ee7b2a3d6cc9c03209 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 25 Apr 2010 11:20:04 -0700 Subject: [PATCH 212/624] Add back transformers 0.1.* support --- Yesod.hs | 7 ++++++- Yesod/Form.hs | 7 ++++++- Yesod/Handler.hs | 5 +++++ Yesod/Request.hs | 5 +++++ yesod.cabal | 14 ++++++++++---- 5 files changed, 32 insertions(+), 6 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index bc15e2d4..615a1bf6 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} module Yesod ( module Yesod.Request @@ -35,4 +36,8 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application, Method (..)) import Yesod.Hamlet import Data.Convertible.Text (cs) -import Control.Monad.IO.Class (liftIO) +#if TRANSFORMERS_02 +import "transformers" Control.Monad.IO.Class (liftIO) +#else +import "transformers" Control.Monad.Trans (liftIO) +#endif diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 04f1ed9a..7ccbdc7f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} -- | Parse forms (and query strings). module Yesod.Form ( Form (..) @@ -26,7 +27,11 @@ import Data.Time (Day) import Data.Convertible.Text import Control.Monad.Attempt import Data.Maybe (fromMaybe) -import "transformers" Control.Monad.IO.Class (MonadIO) +#if TRANSFORMERS_02 +import "transformers" Control.Monad.IO.Class +#else +import "transformers" Control.Monad.Trans +#endif import Yesod.Internal noParamNameError :: String diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 974b6b0a..6c15ad83 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -6,6 +6,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -56,7 +57,11 @@ import Web.Mime import Control.Exception hiding (Handler) import Control.Applicative +#if TRANSFORMERS_02 import "transformers" Control.Monad.IO.Class +#else +import "transformers" Control.Monad.Trans +#endif import Control.Monad.Attempt import Control.Monad (liftM, ap) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 880420ca..1f68638b 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -37,7 +38,11 @@ import qualified Network.Wai as W import Yesod.Definitions import Web.Encodings import qualified Data.ByteString.Lazy as BL +#if TRANSFORMERS_02 import "transformers" Control.Monad.IO.Class +#else +import "transformers" Control.Monad.Trans +#endif import Control.Monad (liftM) type ParamName = String diff --git a/yesod.cabal b/yesod.cabal index 2aee6820..0acad74e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -19,6 +19,8 @@ extra-source-files: CLI/skel/App.hs, CLI/skel/templates/layout.st, CLI/skel/templates/homepage.st +flag transformers_02 + description: transformers = 0.2.* flag buildtests description: Build the executable to run unit tests default: False @@ -38,14 +40,13 @@ library Buildable: True build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, - wai >= 0.2.0 && < 0.3, - wai-extra >= 0.0.0 && < 0.3, + wai >= 0.0.0 && < 0.3, + wai-extra >= 0.0.0 && < 0.1, authenticate >= 0.6 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.4 && < 0.5, + web-encodings >= 0.2.4 && < 0.3, data-object >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, - transformers >= 0.2.0 && < 0.3, control-monad-attempt >= 0.2.0 && < 0.3, text >= 0.5 && < 0.8, convertible-text >= 0.2.0 && < 0.3, @@ -53,6 +54,11 @@ library web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.0 && < 0.1, hamlet >= 0.0 && < 0.1 + if flag(transformers_02) + build-depends: transformers >= 0.2 && < 0.3 + CPP-OPTIONS: -DTRANSFORMERS_02 + else + build-depends: transformers >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Definitions From 22ef236fefdbd64413c881399af852a753ceeb49 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 30 Apr 2010 09:10:32 +0300 Subject: [PATCH 213/624] redirect and redirectString --- Yesod/Handler.hs | 11 +++++++++-- Yesod/Helpers/Auth.hs | 10 +++++----- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6c15ad83..398f0f07 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -34,6 +34,7 @@ module Yesod.Handler -- * Special responses , RedirectType (..) , redirect + , redirectString , sendFile , notFound , badMethod @@ -212,9 +213,15 @@ safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return (W.Status500, [], TypePlain, cs "Internal Server Error") +-- | Redirect to the given route. +redirect :: RedirectType -> Routes master -> GHandler sub master a +redirect rt url = do + r <- getUrlRenderMaster + redirectString rt $ r url + -- | Redirect to the given URL. -redirect :: RedirectType -> String -> GHandler sub master a -redirect rt url = Handler $ \_ -> return ([], HCRedirect rt url) +redirectString :: RedirectType -> String -> GHandler sub master a +redirectString rt url = Handler $ \_ -> return ([], HCRedirect rt url) -- | Bypass remaining handler code and output the given file. -- diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 675272e5..286c0403 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -99,9 +99,9 @@ getOpenIdForward = do let complete = render OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt - (\err -> redirect RedirectTemporary + (\err -> redirectString RedirectTemporary -- FIXME $ "/auth/openid/?message=" ++ encodeUrl (show err)) - (redirect RedirectTemporary) + (redirectString RedirectTemporary) res getOpenIdComplete :: GHandler Auth master () @@ -109,7 +109,7 @@ getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' - let onFailure err = redirect RedirectTemporary + let onFailure err = redirectString RedirectTemporary -- FIXME $ "/auth/openid/?message=" ++ encodeUrl (show err) let onSuccess (OpenId.Identifier ident) = do @@ -236,7 +236,7 @@ redirectSetDest rt dest = do Nothing -> "/" -- should never happen anyway dest' = ur dest addCookie destCookieTimeout destCookieName curr' - redirect rt dest' + redirectString rt dest' -- FIXME use redirect? -- | Read the 'destCookieName' cookie and redirect to this destination. If the -- cookie is missing, then use the default path provided. @@ -248,4 +248,4 @@ redirectToDest rt def = do (x:_) -> do deleteCookie destCookieName return x - redirect rt dest + redirectString rt dest -- FIXME use redirect? From de7ed94abd4675c1ed5b9e9e9d2a647e792d9e1d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 1 May 2010 22:38:30 +0300 Subject: [PATCH 214/624] Buffering output --- Yesod/Dispatch.hs | 4 +++- yesod.cabal | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 3e356561..c5a1c114 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -21,6 +21,7 @@ import Web.Routes.Quasi import Language.Haskell.TH.Syntax import qualified Network.Wai as W +import qualified Network.Wai.Enumerator as W import Network.Wai.Middleware.CleanPath import Network.Wai.Middleware.ClientSession import Network.Wai.Middleware.Jsonp @@ -220,7 +221,8 @@ responseToWaiResponse (sc, hs, ct, c) = do let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' return $ W.Response sc hs'' $ case c of ContentFile fp -> Left fp - ContentEnum e -> Right $ W.Enumerator e + ContentEnum e -> Right $ W.buffer + $ W.Enumerator e -- | Convert Header to a key/value pair. headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString) diff --git a/yesod.cabal b/yesod.cabal index 0acad74e..6ff0c69c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -40,7 +40,7 @@ library Buildable: True build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, - wai >= 0.0.0 && < 0.3, + wai >= 0.0.1 && < 0.3, wai-extra >= 0.0.0 && < 0.1, authenticate >= 0.6 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, From dda3140695a7af738c61003ee87426317a75c42e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 07:09:28 +0300 Subject: [PATCH 215/624] Better type for jsonmap --- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Helpers/Static.hs | 4 ++++ Yesod/Json.hs | 8 ++++---- yesod.cabal | 2 +- 4 files changed, 11 insertions(+), 7 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 286c0403..7dbd039c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -170,8 +170,8 @@ getCheck = do %dd $snd$ |] json (ident, dn) = - jsonMap [ (jsonScalar $ cs "ident", jsonScalar ident) - , (jsonScalar $ cs "displayName", jsonScalar dn) + jsonMap [ ("ident", jsonScalar ident) + , ("displayName", jsonScalar dn) ] getLogout :: GHandler Auth master () diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index e7ce3f76..40c50657 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -23,6 +23,7 @@ module Yesod.Helpers.Static , fileLookupDir , siteStatic , StaticRoutes + , toStaticRoute , staticArgs , Static ) where @@ -80,3 +81,6 @@ getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] getStaticRoute fp = do Static fl <- getYesod getStatic fl fp + +toStaticRoute :: [String] -> StaticRoutes +toStaticRoute = StaticRoute diff --git a/Yesod/Json.hs b/Yesod/Json.hs index d848cec2..860d00e3 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -18,7 +18,7 @@ module Yesod.Json import Text.Hamlet.Monad import Control.Applicative -import Data.Text (Text) +import Data.Text (Text, pack) import Web.Encodings import Yesod.Hamlet import Yesod.Definitions @@ -66,10 +66,10 @@ jsonList' (Enumerator enum) = do () <- j return $ Right True -jsonMap :: [(Json url (), Json url ())] -> Json url () +jsonMap :: [(String, Json url ())] -> Json url () jsonMap = jsonMap' . fromList -jsonMap' :: Enumerator (Json url (), Json url ()) (Json url) -> Json url () -- FIXME simplify type +jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonMap' (Enumerator enum) = do Json $ outputString "{" _ <- enum go False @@ -77,7 +77,7 @@ jsonMap' (Enumerator enum) = do where go putComma (k, v) = do when putComma $ Json $ outputString "," - () <- k + jsonScalar $ Unencoded $ pack k Json $ outputString ":" () <- v return $ Right True diff --git a/yesod.cabal b/yesod.cabal index 6ff0c69c..6728e1e1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,7 +53,7 @@ library template-haskell, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.0 && < 0.1, - hamlet >= 0.0 && < 0.1 + hamlet >= 0.0.1 && < 0.1 if flag(transformers_02) build-depends: transformers >= 0.2 && < 0.3 CPP-OPTIONS: -DTRANSFORMERS_02 From 9dbf6971adf3b6a057de024b2f41fd38eb6feed0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 07:53:08 +0300 Subject: [PATCH 216/624] Removed examples --- Web/Mime.hs | 2 - Yesod/Json.hs | 9 +- compile-examples.sh | 6 - examples/fact.html | 30 -- examples/fact.lhs | 106 ----- examples/hamlet.hs | 38 -- examples/helloworld.lhs | 23 - examples/i18n.hs | 36 -- examples/pretty-yaml.hs | 67 --- examples/pretty-yaml.st | 16 - examples/real-template.st | 3 - examples/static.hs | 25 -- examples/template.st | 26 -- .../tweedle-templates/category-details.st | 27 -- examples/tweedle-templates/issue-details.st | 37 -- examples/tweedle-templates/layout.st | 22 - examples/tweedle.lhs | 410 ------------------ runtests.hs | 9 +- yesod.cabal | 65 +-- 19 files changed, 11 insertions(+), 946 deletions(-) delete mode 100755 compile-examples.sh delete mode 100644 examples/fact.html delete mode 100644 examples/fact.lhs delete mode 100644 examples/hamlet.hs delete mode 100644 examples/helloworld.lhs delete mode 100644 examples/i18n.hs delete mode 100644 examples/pretty-yaml.hs delete mode 100644 examples/pretty-yaml.st delete mode 100644 examples/real-template.st delete mode 100644 examples/static.hs delete mode 100644 examples/template.st delete mode 100644 examples/tweedle-templates/category-details.st delete mode 100644 examples/tweedle-templates/issue-details.st delete mode 100644 examples/tweedle-templates/layout.st delete mode 100755 examples/tweedle.lhs diff --git a/Web/Mime.hs b/Web/Mime.hs index 7c69e154..d774e32c 100644 --- a/Web/Mime.hs +++ b/Web/Mime.hs @@ -24,8 +24,6 @@ import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) -import Test.QuickCheck -import Control.Monad (when) #endif -- | Equality is determined by converting to a 'String' via diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 860d00e3..c6fe8e02 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -29,11 +29,8 @@ import Yesod.Content #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) -import Test.QuickCheck import Data.Text.Lazy (unpack) -import qualified Data.Text as T #endif newtype Json url a = Json { unJson :: Hamlet url IO a } @@ -93,9 +90,9 @@ caseSimpleOutput :: Assertion caseSimpleOutput = do let j = do jsonMap - [ (jsonScalar $ T.pack "foo" , jsonList - [ jsonScalar $ T.pack "bar" - , jsonScalar $ T.pack "baz" + [ ("foo" , jsonList + [ jsonScalar $ Encoded $ pack "bar" + , jsonScalar $ Encoded $ pack "baz" ]) ] t <- hamletToText id $ unJson j diff --git a/compile-examples.sh b/compile-examples.sh deleted file mode 100755 index f037f0c4..00000000 --- a/compile-examples.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -for f in examples/*.*hs -do - ghc --make -Wall -Werror $f || exit -done diff --git a/examples/fact.html b/examples/fact.html deleted file mode 100644 index 4f849dd4..00000000 --- a/examples/fact.html +++ /dev/null @@ -1,30 +0,0 @@ -<!DOCTYPE html> -<html> - <head> - <title>Factorials - - - - - -
                  -

                  -

                  -
                  - - diff --git a/examples/fact.lhs b/examples/fact.lhs deleted file mode 100644 index 85af7b54..00000000 --- a/examples/fact.lhs +++ /dev/null @@ -1,106 +0,0 @@ -FIXME documentation is out of date in a few places. - -> {-# LANGUAGE QuasiQuotes #-} -> {-# LANGUAGE TemplateHaskell #-} -> {-# LANGUAGE TypeFamilies #-} - -I in general recommend type signatures for everything. However, I wanted -to show in this example how it is possible to get away without the -signatures. - -> {-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -There are only two imports: Yesod includes all of the code we need for creating -a web application, while Network.Wai.Handler.SimpleServer allows us to test our -application easily. A Yesod app can in general run on any WAI handler, so this -application is easily convertible to CGI, FastCGI, or even run on the Happstack -server. - -> import Yesod -> import Network.Wai.Handler.SimpleServer - -The easiest way to start writing a Yesod app is to follow the Yesod typeclass. -You define some data type which will contain all the specific settings and data -you want in your application. This might include database connections, -templates, etc. It's entirely up to you. - -For our simple demonstration, we need no extra data, so we simply define Fact -as: - -> data Fact = Fact - -Now we need to declare an instance of Yesod for Fact. The most important -function to declare is handlers, which defines which functions deal with which -resources (aka URLs). - -You can declare the function however you want, but Yesod.Resource declares a -convenient "resources" quasi-quoter which takes YAML content and generates the -function for you. There is a lot of cool stuff to do with representations going -on here, but this is not the appropriate place to discuss it. - - - -The structure is very simply: top level key is a "resource pattern". A resource pattern is simply a bunch of slash-separated strings, called "resource pattern pieces". There are three special ways to start a piece: - -* $: will take any string - -* \#: will take any integer - -* \*: will "slurp" up all the remaining pieces. Useful for something like - /static/*filepath - -Otherwise, the piece is treated as a literal string which must be matched. - - -Now we have a mapping of verbs to handler functions. We could instead simply -specify a single function which handles all verbs. (Note: a verb is just a -request method.) - -> $(mkYesod "Fact" [$parseRoutes| -> / Index GET -> /#num FactR GET -> /fact FactRedirect GET -> |]) - -> instance Yesod Fact where -> approot _ = "http://localhost:3000" - -This does what it looks like: serves a static HTML file. - -> getIndex = sendFile TypeHtml "examples/fact.html" >> return () - -HtmlObject is a funny beast. Basically, it allows multiple representations of -data, all with HTML entities escaped properly. These representations include: - -* Simple HTML document (only recommended for testing). -* JSON (great for Ajax) -* Input to a HStringTemplate (great for no-Javascript fallback). - -For simplicity here, we don't include a template, though it would be trivial to -do so (see the hellotemplate example). - -> getFactR :: Integer -> Handler y ChooseRep -- FIXME remove -> getFactR _i = error "FIXME" {-simpleApplyLayout "Factorial result" $ cs -> [ ("input", show i) -> , ("result", show $ product [1..fromIntegral i :: Integer]) -> ]-} - -I've decided to have a redirect instead of serving the some data in two -locations. It fits in more properly with the RESTful principal of one name for -one piece of data. - -> getFactRedirect :: Handler y () -> getFactRedirect = do -> res <- runFormPost $ catchFormError -> $ checkInteger -> $ required -> $ input "num" -> let i = either (const "1") show res -> redirect RedirectPermanent $ "../" ++ i ++ "/" - -You could replace this main to use any WAI handler you want. For production, -you could use CGI, FastCGI or a more powerful server. Just check out Hackage -for options (any package starting hack-handler- should suffice). - -> main :: IO () -> main = putStrLn "Running..." >> toWaiApp Fact >>= run 3000 diff --git a/examples/hamlet.hs b/examples/hamlet.hs deleted file mode 100644 index 447bf5dd..00000000 --- a/examples/hamlet.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -import Yesod -import Network.Wai.Handler.SimpleServer - -data Ham = Ham - -mkYesod "Ham" [$parseRoutes| -/ Homepage GET -/#another Another GET -|] - -instance Yesod Ham where - approot _ = "http://localhost:3000" - -data NextLink = NextLink { nextLink :: HamRoutes } - -template :: Monad m => NextLink -> Hamlet HamRoutes m () -template = [$hamlet| -%a!href=@nextLink@ Next page -|] - -getHomepage :: Handler Ham RepHtml -getHomepage = hamletToRepHtml $ template $ NextLink $ Another 1 - -getAnother :: Integer -> Handler Ham RepHtml -getAnother i = hamletToRepHtml $ template $ NextLink next - where - next = case i of - 5 -> Homepage - _ -> Another $ i + 1 - -main :: IO () -main = do - putStrLn "Running..." - toWaiApp Ham >>= run 3000 diff --git a/examples/helloworld.lhs b/examples/helloworld.lhs deleted file mode 100644 index cf889531..00000000 --- a/examples/helloworld.lhs +++ /dev/null @@ -1,23 +0,0 @@ -\begin{code} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -import Yesod -import Network.Wai.Handler.SimpleServer - -data HelloWorld = HelloWorld - -mkYesod "HelloWorld" [$parseRoutes| -/ Home GET -|] - -instance Yesod HelloWorld where - approot _ = "http://localhost:3000" - -getHome :: Handler HelloWorld RepHtml -getHome = simpleApplyLayout "Hello World" $ cs "Hello world!" - -main :: IO () -main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000 -\end{code} diff --git a/examples/i18n.hs b/examples/i18n.hs deleted file mode 100644 index ae0651d4..00000000 --- a/examples/i18n.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -import Yesod -import Network.Wai.Handler.SimpleServer - -data I18N = I18N - -mkYesod "I18N" [$parseRoutes| -/ Homepage GET -/set/$lang SetLang GET -|] - -instance Yesod I18N where - approot _ = "http://localhost:3000" - -getHomepage :: Handler y [(ContentType, Content)] -getHomepage = do - ls <- languages - let hello = chooseHello ls - return [(TypePlain, cs hello :: Content)] - -chooseHello :: [Language] -> String -chooseHello [] = "Hello" -chooseHello ("he":_) = "שלום" -chooseHello ("es":_) = "Hola" -chooseHello (_:rest) = chooseHello rest - -getSetLang :: String -> Handler y () -getSetLang lang = do - addCookie 1 langKey lang - redirect RedirectTemporary "/" - -main :: IO () -main = putStrLn "Running..." >> toWaiApp I18N >>= run 3000 diff --git a/examples/pretty-yaml.hs b/examples/pretty-yaml.hs deleted file mode 100644 index 1054936b..00000000 --- a/examples/pretty-yaml.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -import Yesod -import Data.Object.Yaml -import Network.Wai.Handler.SimpleServer -import Web.Encodings -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Object.String - -data PY = PY - -mkYesod "PY" [$parseRoutes| -/ Homepage GET POST -|] - -instance Yesod PY where - approot _ = "http://localhost:3000" - -template :: Monad m => TempArgs url m -> Hamlet url m () -template = [$hamlet| -!!! -%html - %head - %meta!charset=utf-8 - %title Pretty YAML - %body - %form!method=post!action=.!enctype=multipart/form-data - File name: - %input!type=file!name=yaml - %input!type=submit - $if hasYaml - %div ^yaml^ -|] - -data TempArgs url m = TempArgs - { hasYaml :: Bool - , yaml :: Hamlet url m () - } - -getHomepage :: Handler PY RepHtml -getHomepage = hamletToRepHtml - $ template $ TempArgs False (return ()) - ---FIXMEpostHomepage :: Handler PY RepHtmlJson -postHomepage :: Handler PY RepHtml -postHomepage = do - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr - fi <- case lookup "yaml" files of - Nothing -> invalidArgs [("yaml", "Missing input")] - Just x -> return x - so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi - {- FIXME - let ho' = fmap Text to - templateHtmlJson "pretty-yaml" ho' $ \ho -> - return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject) - -} - let ho = cs (so :: StringObject) :: HtmlObject - hamletToRepHtml $ template $ TempArgs True (cs ho) - -main :: IO () -main = do - putStrLn "Running..." - toWaiApp PY >>= run 3000 diff --git a/examples/pretty-yaml.st b/examples/pretty-yaml.st deleted file mode 100644 index 68e1e604..00000000 --- a/examples/pretty-yaml.st +++ /dev/null @@ -1,16 +0,0 @@ - - - - -Pretty YAML - - -
                  -File name: - -
                  -$if(yaml)$ -
                  $yaml$
                  -$endif$ - - diff --git a/examples/real-template.st b/examples/real-template.st deleted file mode 100644 index 17161eeb..00000000 --- a/examples/real-template.st +++ /dev/null @@ -1,3 +0,0 @@ -This is a more realistic template. -foo: $foo$ -This is the default argument: $default$ diff --git a/examples/static.hs b/examples/static.hs deleted file mode 100644 index 670d0a94..00000000 --- a/examples/static.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet - -import Yesod -import Yesod.Helpers.Static -import Network.Wai.Handler.SimpleServer - -data StaticExample = StaticExample - -mkYesod "StaticExample" [$parseRoutes| -/ Root StaticRoutes siteStatic getStaticSite -|] - -instance Yesod StaticExample where - approot _ = "http://localhost:3000" - -getStaticSite :: StaticExample -> Static -getStaticSite _ = fileLookupDir "dist/doc/html/yesod" - -main :: IO () -main = do - putStrLn "Running..." - toWaiApp StaticExample >>= run 3000 diff --git a/examples/template.st b/examples/template.st deleted file mode 100644 index f71953cf..00000000 --- a/examples/template.st +++ /dev/null @@ -1,26 +0,0 @@ - - - - - $title$ - - - -
                  - $content$ -
                  - - diff --git a/examples/tweedle-templates/category-details.st b/examples/tweedle-templates/category-details.st deleted file mode 100644 index 0c3bdecb..00000000 --- a/examples/tweedle-templates/category-details.st +++ /dev/null @@ -1,27 +0,0 @@ -$layout( - title={Category $name$}; - content={ - -

                  $name$

                  - -
                  New subcategory:
                  -

                  Sub categories

                  - - -
                  New issue:
                  -

                  Issues

                  - - -$cat.issues:{issue| - -}$ -
                  TitleStatusPriority
                  $issue.name$$issue.status$$issue.priority$
                  -})$ diff --git a/examples/tweedle-templates/issue-details.st b/examples/tweedle-templates/issue-details.st deleted file mode 100644 index eaca279a..00000000 --- a/examples/tweedle-templates/issue-details.st +++ /dev/null @@ -1,37 +0,0 @@ -$layout( - title={Issue $issue.name$ -- Category $cat.name$}; - content={ -

                  $issue.name$

                  -

                  $cat.name$

                  - -$if(ident)$ -
                  -

                  Add new message

                  - - - - - -
                  Status (optional)
                  Priority (optional)
                  Description
                  - -$else$ -

                  You must log in to add a message.

                  -OpenID: - -$endif$ - -

                  Messages

                  -$issue.messages:{message| -
                  -

                  Author: $message.author$

                  -

                  Created: $message.creation$

                  - $if(message.status)$ -

                  Updated status: $message.status$

                  - $endif$ - $if(message.priority)$ -

                  Updated priority: $message.priority$

                  - $endif$ -
                  $message.text$
                  -
                  -}$ -})$ diff --git a/examples/tweedle-templates/layout.st b/examples/tweedle-templates/layout.st deleted file mode 100644 index 9a38943b..00000000 --- a/examples/tweedle-templates/layout.st +++ /dev/null @@ -1,22 +0,0 @@ - - - -$title$ -- Tweedle - - - -$content$ - - diff --git a/examples/tweedle.lhs b/examples/tweedle.lhs deleted file mode 100755 index 00bfe98c..00000000 --- a/examples/tweedle.lhs +++ /dev/null @@ -1,410 +0,0 @@ -#!/usr/bin/env runhaskell - -FIXME documentation out of date. - -> {-# LANGUAGE QuasiQuotes #-} -> {-# LANGUAGE TemplateHaskell #-} -> {-# LANGUAGE TypeFamilies #-} - -While coming up on the first release of Yesod, I realized I needed a nice, comprehensive tutorial. I didn't want to do the typical blog example, since it's so trite. I considered doing a Reddit or Twitter clone (the former became a bit of a meme a few weeks ago), but then I needed to set up a bug tracker for some commercial projects I was working on, and I decided that it would be a great example program. - -Before getting started, a quick word of warning: Yesod at this point really provides nothing in terms of data storage (aka, the model). There is wonderful integration with the data-object package, and the data-object-yaml package provides good serialization, but this is all very inefficient in practice. For simplicity, I've gone ahead and used this as the storage model; this should not be done for production code. - -There's a lot of boilerplate code at the beginning that just has to do with object storage; if you'd like to skip it, just start reading from the main function. - -Anyway, here's the import list. - -> import Yesod -> import Yesod.Helpers.Auth -> import Data.Object.Yaml -> import Data.Object.String -> import Control.Concurrent -> import qualified Safe.Failure as SF -> import Data.Time -> import Data.Attempt (Attempt, fromAttempt) -> import Control.Arrow (second) -> import qualified Network.Wai.Handler.SimpleServer -> import Data.Monoid -> import Data.Text (pack) -> import Control.Applicative ((<$>), (<*>)) -> import Data.Maybe (fromMaybe) -> import qualified Network.Wai as W - -One of the goals of Yesod is to make it work with the compiler to help you program. Instead of configuration files, it uses typeclasses to both change default behavior and enable extra features. An example of the former is error pages, while an example of the latter is authentication. - -To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle. - -> data Tweedle = Tweedle Settings (MVar Category) - -(For now, just ignore the TemplateGroup, its purpose becomes apparent later.) - -This issue database is fully hierarchical: each category can contain subcategories and issues. This might be too much nesting for many uses, but it's what my project demanded. - -Also, if I cared about efficiency here, a trie or map would probably be a better data structure. As stated above, it doesn't matter. - -> data Category = Category -> { subCats :: [Category] -> , subIssues :: [Issue] -> , categoryId :: Integer -> , catName :: String -> } - -> data Issue = Issue -> { issueName :: String -> , issueMessages :: [Message] -> , issueId :: Integer -> } - -Further simplifications: authors will just be represented by their OpenID URL. - -> data Message = Message -> { messageAuthor :: OpenId -> , messageStatus :: Maybe String -> , messagePriority :: Maybe String -> , messageText :: String -> , messageCreation :: UTCTime -> } - -> type OpenId = String - -We need to be able to serialize this data to and from YAML files. You can consider all of the following code boilerplate. - -> messageToSO :: Message -> StringObject -> messageToSO m = Mapping $ map (second Scalar) -> [ ("author", messageAuthor m) -> , ("status", show $ messageStatus m) -> , ("priority", show $ messagePriority m) -> , ("text", messageText m) -> , ("creation", show $ messageCreation m) -> ] -> messageFromSO :: StringObject -> Attempt Message -> messageFromSO so = do -> m <- fromMapping so -> a <- lookupScalar "author" m -> s <- lookupScalar "status" m >>= SF.read -> p <- lookupScalar "priority" m >>= SF.read -> t <- lookupScalar "text" m -> c <- lookupScalar "creation" m >>= SF.read -> return $ Message a s p t c -> issueToSO :: Issue -> StringObject -> issueToSO i = Mapping -> [ ("name", Scalar $ issueName i) -> , ("messages", Sequence $ map messageToSO $ issueMessages i) -> , ("id", Scalar $ show $ issueId i) -> ] -> issueFromSO :: StringObject -> Attempt Issue -> issueFromSO so = do -> m <- fromMapping so -> n <- lookupScalar "name" m -> i <- lookupScalar "id" m >>= SF.read -> ms <- lookupSequence "messages" m >>= mapM messageFromSO -> return $ Issue n ms i -> categoryToSO :: Category -> StringObject -> categoryToSO c = Mapping -> [ ("cats", Sequence $ map categoryToSO $ subCats c) -> , ("issues", Sequence $ map issueToSO $ subIssues c) -> , ("id", Scalar $ show $ categoryId c) -> , ("name", Scalar $ catName c) -> ] -> categoryFromSO :: StringObject -> Attempt Category -> categoryFromSO so = do -> m <- fromMapping so -> cats <- lookupSequence "cats" m >>= mapM categoryFromSO -> issues <- lookupSequence "issues" m >>= mapM issueFromSO -> i <- lookupScalar "id" m >>= SF.read -> n <- lookupScalar "name" m -> return $ Category cats issues i n - -Well, that was a mouthful. You can safely ignore all of that: it has nothing to do with actual web programming. - -Next is the Settings datatype. Normally I create a settings file so I can easily make changes between development and production systems without recompiling, but once again we are aiming for simplicity here. - -> data Settings = Settings - -Many web frameworks make the simplifying assumptions that "/" will be the path to the root of your application. In real life, this doesn't always happen. In Yesod, you must specify explicitly your application root and then create an instance of YesodApproot (see below). Again, the compiler will let you know this: once you use a feature that depends on knowing the approot, you'll get a compiler error if you haven't created the instance. - -> { sApproot :: String -> , issueFile :: FilePath - -Yesod comes built in with support for HStringTemplate. You'll see later how this ties in with data-object (and in particular HtmlObject) to help avoid XSS attacks. - -> , templatesDir :: FilePath -> } - -And now we'll hardcode the settings instead of loading from a file. I'll do it in the IO monad anyway, since that would be the normal function signature. - -> loadSettings :: IO Settings -> loadSettings = return $ Settings "http://localhost:3000/" "issues.yaml" "examples/tweedle-templates" - -And now we need a function to load up our Tweedle data type. - -> loadTweedle :: IO Tweedle -> loadTweedle = do -> settings <- loadSettings - -Note that this will die unless an issues file is present. We could instead check for the file and create it if missing, but instead, just put the following into issues.yaml: - -{cats: [], issues: [], id: 0, name: "Top Category"} - -> issuesSO <- decodeFile $ issueFile settings -> issues <- fromAttempt $ categoryFromSO issuesSO -> missues <- newMVar issues -> tg <- error "FIXME switch to hamlet" -- loadTemplateGroup $ templatesDir settings -> return $ Tweedle settings missues tg - -And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer. - -> main :: IO () -> main = do -> putStrLn "Running at http://localhost:3000/" -> tweedle <- loadTweedle -> app <- toWaiApp tweedle -> Network.Wai.Handler.SimpleServer.run 3000 app - -Well, that was a *lot* of boilerplate code that had nothing to do with web programming. Now the real stuff begins. I would recommend trying to run the code up to now an see what happens. The compiler will complain that there is no instance of Yesod for Tweedle. This is what I meant by letting the compiler help us out. So now we've got to create the Yesod instance. - -The Yesod typeclass includes many functions, most of which have default implementations. I'm not going to go through all of them here, please see the documentation. - -The most important function is resources: this is where all of the URL mapping will occur. Yesod adheres to Restful principles very strongly. A "resource" is essentially a URL. Each resource should be unique; for example, do not create /user/5/ as well as /user/by-number/5/. In addition to resources, we also determine which function should handle your request based on the request method. In other words, a POST and a GET are completely different. - -One of the middlewares that Yesod installs is called MethodOverride; please see the documentation there for more details, but essentially it allows us to work past a limitation in the form tag of HTML to use PUT and DELETE methods as well. - -Instead of using regular expressions to handle the URL mapping, Yesod uses resource patterns. A resource is a set of tokens separated by slashes. Each of those tokens can be one of: - -* A static string. -* An integer variable (begins with #), which will match any integer. -* A string varaible (begins with $), which will match any single value. -* A "slurp" variable, which will match all of the remaining tokens. It must be the last token. - -Yesod uses quasi quotation to make specifying the resource pattern simple and safe: your entire set of patterns is checked at compile time to see if you have overlapping rules. - -> mkYesod "Tweedle" [$parseRoutes| - -Now we need to figure out all of the resources available in our application. We'll need a homepage: - -> / Homepage GET - -We will also need to allow authentication. We use the slurp pattern here and accept all request methods. The authHandler method (in the Yesod.Helpers.Auth module) will handle everything itself. - -> /auth/* AuthHandler - -We're going to refer to categories and issues by their unique numerical id. We're also going to make this system append only: there is no way to change the history. - -> /category/#id CategoryH GET PUT -> /category/#id/issues Issues PUT -> /issue/#id IssueH GET PUT -> |] - -So if you make a PUT request to "/category/5", you will be creating a subcategory of category 5. "GET /issue/27/" will display details on issue 27. This is all we need. - -If you try to compile the code until this point, the compiler will tell you that you have to define all of the above-mentioned functions. We'll do that in a second; for now, if you'd like to see the rest of the error messages, uncomment this next block of code. - -> {- -> homepageH = return () -> categoryDetailsH _ = return () -> createCategoryH _ = return () -> createIssueH _ = return () -> issueDetailsH _ = return () -> addMessageH _ = return () -> -} - -Now the compiler is telling us that there's no instance of YesodAuth for Tweedle. YesodAuth- as you might imagine- keeps settings on authentication. We're going to go ahead a create an instance now. The default settings work if you set up authHandler for "/auth/*" (which we did) and are using openid (which we are). So all we need to do is: - -> instance YesodAuth Tweedle - -Running that tells us that we're missing a YesodApproot instance as well. That's easy enough to fix: - -> instance Yesod Tweedle where -> approot (Tweedle settings _ _) = sApproot settings - -Congratulations, you have a working web application! Gratned, it doesn't actually do much yet, but you *can* use it to log in via openid. Just go to http://localhost:3000/auth/openid/. - -Now it's time to implement the real code here. We'll start with the homepage. For this program, I just want the homepage to redirect to the main category (which will be category 0). So let's create that redirect: - -> getHomepage :: Handler Tweedle () -> getHomepage = do -> ar <- getApproot -> redirect RedirectPermanent $ ar ++ "category/0/" - -Simple enough. Notice that we used the getApproot function; if we wanted, we could have just assumed the approot was "/", but this is more robust. - -Now the category details function. We're just going to have two lists: subcategories and direct subissues. Each one will have a name and numerical ID. - -But here's a very nice feature of Yesod: We're going to have multiple representations of this data. The main one people will use is the HTML representation. However, we're also going to provide a JSON representation. This will make it very simple to write clients or to AJAXify this application in the future. - -> getCategoryH :: Integer -> Handler Tweedle RepHtmlJson - -That function signature tells us a lot: the parameter is the category ID, and we'll be returning something that has both an HTML and JSON representation. - -> getCategoryH catId = do - -getYesod returns our Tweedle data type. Remember, we wrapped it in an MVar; since this is a read-only operation, will unwrap the MVar immediately. - -> Tweedle _ mvarTopCat _ <- getYesod -> topcat <- liftIO $ readMVar mvarTopCat - -Next we need to find the requested category. You'll see the (boilerplate) function below. If the category doesn't exist, we want to return a 404 response page. So: - -> (parents, cat) <- maybe notFound return $ findCat catId [] topcat - -Now we want to convert the category into an HtmlObject. By doing so, we will get automatic HTML entity encoding; in other words, no XSS attacks. - -> let catHelper (Category _ _ cid name) = Mapping -> [ ("name", Scalar $ Text $ pack name) -> , ("id", Scalar $ Text $ pack $ show cid) -> ] -> let statusHelper = fromMaybe "No status set" -> . getLast . mconcat . map (Last . messageStatus) -> let priorityHelper = fromMaybe "No priority set" -> . getLast . mconcat . map (Last . messagePriority) -> let issueHelper (Issue name messages iid) = Mapping -> [ ("name", Scalar $ Text $ pack name) -> , ("id", Scalar $ Text $ pack $ show iid) -> , ("status", Scalar $ Text $ pack $ statusHelper messages) -> , ("priority", Scalar $ Text $ pack $ priorityHelper messages) -> ] -> let ho = Mapping -> [ ("cats", Sequence $ map catHelper $ subCats cat) -> , ("issues", Sequence $ map issueHelper $ subIssues cat) -> ] - -And now we'll use a String Template to display the whole thing. - -> templateHtmlJson "category-details" ho $ \_ -> return -> . setHtmlAttrib "cat" ho -> . setHtmlAttrib "name" (catName cat) -> . setHtmlAttrib "parents" (Sequence $ map catHelper parents) - -> findCat :: Integer -> [Category] -> Category -> Maybe ([Category], Category) -> findCat i parents c@(Category cats _ i' _) -> | i == i' = Just (parents, c) -> | otherwise = getFirst $ mconcat $ map (First . findCat i (parents ++ [c])) cats - -Now we get a new missing instance: YesodTemplate. As you can imagine, this is because of calling the templateHtmlJson function. This is easily enough solved (and explains why we needed TemplateGroup as part of Tweedle). - -> instance YesodTemplate Tweedle where -> getTemplateGroup (Tweedle _ _ tg) = tg - -Now we actually get some output! I'm not going to cover the syntax of string templates here, but you should read the files in the examples/tweedle-templates directory. - -Next, we need to implement createCategoryH. There are two parts to this process: parsing the form submission, and then modifying the database. Pay attention to the former, but you can ignore the latter if you wish. Also, this code does not do much for error checking, as that would needlessly complicate matters. - -> putCategoryH :: Integer -> Handler Tweedle () -> putCategoryH parentid = do - -Yesod uses a formlets-style interface for parsing submissions. This following line says we want a parameter named catname, which precisely one value (required) and that value must have a non-zero length (notEmpty). - -> catname <- runFormPost $ notEmpty $ required $ input "catname" -> newid <- modifyDB $ createCategory parentid catname -> ar <- getApproot -> redirect RedirectPermanent $ ar ++ "category/" ++ show newid ++ "/" - -And here's the database modification code we need. Once again, this is not web-specific. - -> modifyDB :: (Category -> (Category, x)) -> Handler Tweedle x -> modifyDB f = do -> Tweedle settings mcat _ <- getYesod -> liftIO $ modifyMVar mcat $ \cat -> do -> let (cat', x) = f cat -> encodeFile (issueFile settings) $ categoryToSO cat' -> return (cat', x) - -> createCategory :: Integer -> String -> Category -> (Category, Integer) -> createCategory parentid catname topcat = -> let newid = highCatId topcat + 1 -> topcat' = addChild parentid (Category [] [] newid catname) topcat -> in (topcat', newid) -> where -> highCatId (Category cats _ i _) = maximum $ i : map highCatId cats -> addChild i' newcat (Category cats issues i name) -> | i' /= i = Category (map (addChild i' newcat) cats) issues i name -> | otherwise = Category (cats ++ [newcat]) issues i name - -Next is creating an issue. This is almost identical to creating a category. - -> putIssues :: Integer -> Handler Tweedle () -> putIssues catid = do -> issuename <- runFormPost $ notEmpty $ required $ input "issuename" -> newid <- modifyDB $ createIssue catid issuename -> ar <- getApproot -> redirect RedirectPermanent $ ar ++ "issue/" ++ show newid ++ "/" - -> createIssue :: Integer -> String -> Category -> (Category, Integer) -> createIssue catid issuename topcat = -> let newid = highIssueId topcat + 1 -> topcat' = addIssue catid (Issue issuename [] newid) topcat -> in (topcat', newid) -> where -> highIssueId (Category cats issues _ _) = -> maximum $ 0 : (map issueId issues) ++ map highIssueId cats -> addIssue i' newissue (Category cats issues i name) -> | i' /= i = Category (map (addIssue i' newissue) cats) issues i name -> | otherwise = Category cats (issues ++ [newissue]) i name - -Two functions to go. Now we want to show details of issues. This isn't too different from categoryDetailsH above, except for one feature: we need to know if a user is logged in. If they are logged in, we'll show an "add message" box; otherwise, we'll show a login box. Once again, we're getting the JSON representation easily. - -> getIssueH :: Integer -> Handler Tweedle RepHtmlJson -> getIssueH iid = do -> Tweedle _ mvarTopCat _ <- getYesod -> topcat <- liftIO $ readMVar mvarTopCat -> (cat, issue) <- maybe notFound return $ findIssue iid topcat -> let messageHelper m = Mapping $ map (second $ Scalar . Text . pack) -> $ (maybe id (\x -> (:) ("status", x)) $ messageStatus m) -> $ (maybe id (\x -> (:) ("priority", x)) $ messagePriority m) -> [ ("author", messageAuthor m) -> , ("text", messageText m) -> , ("creation", show $ messageCreation m) -> ] -> let ho = Mapping -> [ ("name", Scalar $ Text $ pack $ issueName issue) -> , ("messages", Sequence $ map messageHelper $ issueMessages issue) -> ] - -Now we determine is the user is logged in via the maybeIdentifier function. Later on, we'll see how we can force a user to be logged in using authIdentifier. - -> ident <- maybeIdentifier - -> templateHtmlJson "issue-details" ho $ \_ -> return -> . setHtmlAttrib "issue" ho -> . maybe id (setHtmlAttrib "ident") ident -> . setHtmlAttrib "cat" (Mapping -> [ ("name", Scalar $ Text $ pack $ catName cat) -> , ("id", Scalar $ Text $ pack $ show $ categoryId cat) -> ]) - -And now the supporting model code. This function returns the requested Issue along with the containing category. - -> findIssue :: Integer -> Category -> Maybe (Category, Issue) -> findIssue iid c@(Category cats issues _ _) = -> case filter (\issue -> issueId issue == iid) issues of -> [] -> getFirst $ mconcat $ map (First . findIssue iid) cats -> (issue:_) -> Just (c, issue) - -Cool, just one function left! This should probably all make sense by now. Notice, however, the use of authIdentifier: if the user is not logged in, they will be redirected to the login page automatically. - -> putIssueH :: Integer -> Handler Tweedle () -> putIssueH issueid = do -> ident <- authIdentifier -> (status, priority, text) <- runFormPost $ -> (,,) -> <$> optional (input "status") -> <*> optional (input "priority") -> <*> required (input "text") -> now <- liftIO getCurrentTime -> let message = Message ident status priority text now -> modifyDB $ addMessage issueid message -> ar <- getApproot -> redirect RedirectPermanent $ ar ++ "issue/" ++ show issueid ++ "/" - -> addMessage :: Integer -> Message -> Category -> (Category, ()) -> addMessage issueid message (Category cats issues catid catname) = -> (Category (map (fst . addMessage issueid message) cats) (map go issues) catid catname, ()) -> where -> go (Issue name messages iid) -> | iid == issueid = Issue name (messages ++ [message]) iid -> | otherwise = Issue name messages iid - -> handleAuthHandler :: [String] -> Handler Tweedle ChooseRep -> handleAuthHandler pieces = do -> m <- W.requestMethod `fmap` waiRequest -> authHandler m pieces diff --git a/runtests.hs b/runtests.hs index 01d34d1d..3357961c 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,7 +1,5 @@ import Test.Framework (defaultMain) -import qualified Yesod.Response -import qualified Yesod.Request -- FIXME import qualified Test.Errors -- FIXME import qualified Test.QuasiResource import qualified Web.Mime @@ -9,10 +7,9 @@ import qualified Yesod.Json main :: IO () main = defaultMain - [ Yesod.Response.testSuite - , Yesod.Request.testSuite + [ + Web.Mime.testSuite + , Yesod.Json.testSuite -- FIXME , Test.Errors.testSuite -- FIXME, Test.QuasiResource.testSuite - , Web.Mime.testSuite - , Yesod.Json.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index 6728e1e1..6e26a588 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -25,19 +25,7 @@ flag buildtests description: Build the executable to run unit tests default: False -flag buildsamples - description: Build the executable sample applications. - default: False - -flag nolib - description: Skip building of the library. - default: False - library - if flag(nolib) - Buildable: False - else - Buildable: True build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, wai >= 0.0.1 && < 0.3, @@ -94,57 +82,14 @@ executable runtests QuickCheck >= 2 && < 3 else Buildable: False + if flag(transformers_02) + build-depends: transformers >= 0.2 && < 0.3 + CPP-OPTIONS: -DTRANSFORMERS_02 + else + build-depends: transformers >= 0.1 && < 0.2 ghc-options: -Wall main-is: runtests.hs -executable helloworld - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/helloworld.lhs - -executable hamlet - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/hamlet.hs - -executable fact - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/fact.lhs - -executable i18n - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/i18n.hs - -executable pretty-yaml - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/pretty-yaml.hs - -executable tweedle - if flag(buildsamples) - Buildable: True - else - Buildable: False - ghc-options: -Wall - main-is: examples/tweedle.lhs - source-repository head type: git location: git://github.com/snoyberg/yesod.git From 57e4bef9574dec3c2544d9bdd4f22e2a042c95de Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 2 May 2010 07:56:16 +0300 Subject: [PATCH 217/624] Removed old tests and yesod CLI --- CLI/skel/App.hs | 70 ------------------------ CLI/skel/LICENSE | 25 --------- CLI/skel/settings.yaml | 5 -- CLI/skel/static/style.css | 10 ---- CLI/skel/templates/homepage.st | 7 --- CLI/skel/templates/layout.st | 11 ---- CLI/skel/webapp.cabal | 21 -------- CLI/yesod.hs | 76 -------------------------- Test/Errors.hs | 59 -------------------- Test/QuasiResource.hs | 99 ---------------------------------- Test/rep.st | 1 - Test/resource-patterns.yaml | 10 ---- runtests.hs | 7 +-- yesod.cabal | 18 +------ 14 files changed, 3 insertions(+), 416 deletions(-) delete mode 100644 CLI/skel/App.hs delete mode 100644 CLI/skel/LICENSE delete mode 100644 CLI/skel/settings.yaml delete mode 100644 CLI/skel/static/style.css delete mode 100644 CLI/skel/templates/homepage.st delete mode 100644 CLI/skel/templates/layout.st delete mode 100644 CLI/skel/webapp.cabal delete mode 100644 CLI/yesod.hs delete mode 100644 Test/Errors.hs delete mode 100644 Test/QuasiResource.hs delete mode 100644 Test/rep.st delete mode 100644 Test/resource-patterns.yaml diff --git a/CLI/skel/App.hs b/CLI/skel/App.hs deleted file mode 100644 index 9b1a37d9..00000000 --- a/CLI/skel/App.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# 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 diff --git a/CLI/skel/LICENSE b/CLI/skel/LICENSE deleted file mode 100644 index 29ed9276..00000000 --- a/CLI/skel/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -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. diff --git a/CLI/skel/settings.yaml b/CLI/skel/settings.yaml deleted file mode 100644 index e98384d4..00000000 --- a/CLI/skel/settings.yaml +++ /dev/null @@ -1,5 +0,0 @@ -approot: http://localhost:3000/ -static-root: http://localhost:3000/static/ -static-dir: static -template-dir: templates -port: 3000 diff --git a/CLI/skel/static/style.css b/CLI/skel/static/style.css deleted file mode 100644 index d5de60d6..00000000 --- a/CLI/skel/static/style.css +++ /dev/null @@ -1,10 +0,0 @@ -html { - background: #ccc; -} -body { - width: 760px; - margin: 10px auto; - padding: 10px; - border: 1px solid #333; - background: #fff; -} diff --git a/CLI/skel/templates/homepage.st b/CLI/skel/templates/homepage.st deleted file mode 100644 index fffa55d9..00000000 --- a/CLI/skel/templates/homepage.st +++ /dev/null @@ -1,7 +0,0 @@ -\$layout( - title={Homepage}; - content={ -

                  Homepage

                  -

                  You probably want to put your own content here.

                  - } -)\$ diff --git a/CLI/skel/templates/layout.st b/CLI/skel/templates/layout.st deleted file mode 100644 index fadca393..00000000 --- a/CLI/skel/templates/layout.st +++ /dev/null @@ -1,11 +0,0 @@ - - - - \$title\$ - - \$extrahead\$ - - - \$content\$ - - diff --git a/CLI/skel/webapp.cabal b/CLI/skel/webapp.cabal deleted file mode 100644 index 0fe22111..00000000 --- a/CLI/skel/webapp.cabal +++ /dev/null @@ -1,21 +0,0 @@ -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 diff --git a/CLI/yesod.hs b/CLI/yesod.hs deleted file mode 100644 index 3f6606f9..00000000 --- a/CLI/yesod.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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." diff --git a/Test/Errors.hs b/Test/Errors.hs deleted file mode 100644 index 7dfbac61..00000000 --- a/Test/Errors.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE EmptyDataDecls #-} -module Test.Errors (testSuite) where - -import Yesod -import Yesod.Helpers.Auth -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -data Errors -instance Yesod Errors where - resources = [$mkResources| -/denied: - Get: denied -/needs-ident: - Get: needsIdent -/has-args: - Get: hasArgs -|] -instance YesodApproot Errors where - approot _ = "IGNORED/" -instance YesodAuth Errors - -denied :: Handler Errors () -denied = permissionDenied - -needsIdent :: Handler Errors (Html, HtmlObject) -needsIdent = do - i <- authIdentifier - return (cs "", cs i) - -hasArgs :: Handler Errors (Html, HtmlObject) -hasArgs = do - {- FIXME wait for new request API - (a, b) <- runRequest $ (,) <$> getParam "firstParam" - <*> getParam "secondParam" - -} - let (a, b) = ("foo", "bar") - return (cs "", cs [a :: String, b]) - -caseErrorMessages :: Assertion -caseErrorMessages = do return () -{- FIXME - app <- toWaiApp Errors - res <- app $ def { pathInfo = B8.pack "/denied/" } - assertBool "/denied/" $ "Permission denied" `isInfixOf` show res - res' <- app $ def { pathInfo = B8.pack "/needs-ident/" } - assertBool "/needs-ident/" $ "IGNORED/auth/openid/" `isInfixOf` show res' - -} - {- FIXME this test is not yet ready - res3 <- app $ def { pathInfo = "/has-args/" } - assertBool "/has-args/" $ "secondParam" `isInfixOf` show res3 - -} - -testSuite :: Test -testSuite = testGroup "Test.Errors" - [ testCase "errorMessages" caseErrorMessages - ] diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs deleted file mode 100644 index c07a3644..00000000 --- a/Test/QuasiResource.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE QuasiQuotes #-} - -module Test.QuasiResource (testSuite) where - -import Yesod -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -import Data.List -import Network.Wai (Method (..)) - -data MyYesod = MyYesod - -instance Show (Handler MyYesod ChooseRep) where show _ = "Another handler" - -addHead' :: HtmlObject -> (Html, HtmlObject) -addHead' x = (cs "", x) - -addHead :: Monad m => HtmlObject -> m (Html, HtmlObject) -addHead = return . addHead' - -getStatic :: Method -> [String] -> Handler MyYesod (Html, HtmlObject) -getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p] -pageIndex :: Handler MyYesod (Html, HtmlObject) -pageIndex = addHead $ toHtmlObject ["pageIndex"] -pageAdd :: Handler MyYesod ChooseRep -pageAdd = return $ chooseRep $ addHead' $ toHtmlObject ["pageAdd"] -pageDetail :: String -> Handler MyYesod ChooseRep -pageDetail s = return $ chooseRep $ addHead' $ toHtmlObject ["pageDetail", s] -pageDelete :: String -> Handler MyYesod (Html, HtmlObject) -pageDelete s = addHead $ toHtmlObject ["pageDelete", s] -pageUpdate :: String -> Handler MyYesod ChooseRep -pageUpdate s = return $ chooseRep $ addHead' $ toHtmlObject ["pageUpdate", s] -userInfo :: Integer -> Handler MyYesod (Html, HtmlObject) -userInfo i = addHead $ toHtmlObject ["userInfo", show i] -userVariable :: Integer -> String -> Handler MyYesod (Html, HtmlObject) -userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s] -userPage :: Integer -> [String] -> Handler MyYesod (Html, HtmlObject) -userPage i p = addHead $ toHtmlObject ["userPage", show i, show p] - -instance Show (Method -> Handler MyYesod ChooseRep) where - show _ = "verb -> handler" -instance Show (Resource -> Method -> Handler MyYesod ChooseRep) where - show _ = "resource -> verb -> handler" -handler :: Resource -> Method -> Handler MyYesod ChooseRep -handler = [$mkResources| -/static/*filepath/: getStatic -/page/: - GET: pageIndex - PUT: pageAdd -/page/$page/: - GET: pageDetail - DELETE: pageDelete - POST: pageUpdate -/user/#id/: - GET: userInfo -/user/#id/profile/$variable/: - GET: userVariable -/user/#id/page/*page/: - GET: userPage -|] - -ph :: [String] -> Handler MyYesod ChooseRep -> Assertion -ph ss h = do - let eh = return . chooseRep . addHead' . toHtmlObject . show - rr = error "No raw request" - y = MyYesod - cts = [TypeHtml] - res <- runHandler h eh rr y cts - res' <- myShow res - mapM_ (helper res') ss - where - helper haystack needle = - assertBool (show ("needle", needle, ss, haystack)) - $ needle `isInfixOf` haystack - -myShow :: Response -> IO String -myShow (Response sc hs ct c) = runContent c >>= \c' -> return $ unlines - [ show sc - , unlines $ map show hs - , show ct - , show c' - ] - -caseQuasi :: Assertion -caseQuasi = do - ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] GET - ph ["404"] $ handler ["foo", "bar", "baz"] GET - ph ["200", "pageIndex"] $ handler ["page"] GET - ph ["404"] $ handler ["user"] GET - ph ["404"] $ handler ["user", "five"] GET - ph ["200", "userInfo", "5"] $ handler ["user", "5"] GET - ph ["200", "userVar"] $ handler ["user", "5", "profile", "email"] GET - -testSuite :: Test -testSuite = testGroup "Test.QuasiResource" - [ testCase "quasi" caseQuasi - ] diff --git a/Test/rep.st b/Test/rep.st deleted file mode 100644 index 127b7fd7..00000000 --- a/Test/rep.st +++ /dev/null @@ -1 +0,0 @@ -foo:$o.foo$, bar:$o.bar$ diff --git a/Test/resource-patterns.yaml b/Test/resource-patterns.yaml deleted file mode 100644 index fb2eda77..00000000 --- a/Test/resource-patterns.yaml +++ /dev/null @@ -1,10 +0,0 @@ -/static/*filepath/: getStatic -/page/: - GET: pageIndex - PUT: pageAdd -/page/$page/: - GET: pageDetail - DELETE: pageDelete - POST: pageUpdate -/user/#id/: - GET: userInfo diff --git a/runtests.hs b/runtests.hs index 3357961c..94e448e5 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,15 +1,10 @@ import Test.Framework (defaultMain) --- FIXME import qualified Test.Errors --- FIXME import qualified Test.QuasiResource import qualified Web.Mime import qualified Yesod.Json main :: IO () main = defaultMain - [ - Web.Mime.testSuite + [ Web.Mime.testSuite , Yesod.Json.testSuite - -- FIXME , Test.Errors.testSuite - -- FIXME, Test.QuasiResource.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index 6e26a588..27c57553 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -5,19 +5,11 @@ license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman 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 +stability: Stable 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 +homepage: http://docs.yesodweb.com/yesod/ flag transformers_02 description: transformers = 0.2.* @@ -65,12 +57,6 @@ library Web.Mime ghc-options: -Wall -executable yesod - ghc-options: -Wall - build-depends: file-embed >= 0.0.3 && < 0.1, - HStringTemplate >= 0.6.2 && < 0.7 - main-is: CLI/yesod.hs - executable runtests if flag(buildtests) Buildable: True From 180a5ec9cef1eeb28203ce604f2739b1c8f3585e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 2 May 2010 08:12:49 +0300 Subject: [PATCH 218/624] More documentation work --- Yesod/Hamlet.hs | 2 +- Yesod/Json.hs | 26 ++++++++++++++++++++++++-- Yesod/Yesod.hs | 12 ++++++++++-- 3 files changed, 35 insertions(+), 5 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index ee342f9d..790a3412 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -25,7 +25,7 @@ import Yesod.Content import Yesod.Handler import Yesod.Definitions import Data.Convertible.Text -import Data.Object +import Data.Object -- FIXME should we kill this? import Control.Arrow ((***)) -- | Content for a web page. By providing this datatype, we can easily create diff --git a/Yesod/Json.hs b/Yesod/Json.hs index c6fe8e02..47ea56ec 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,8 +1,9 @@ --- FIXME document +-- | Efficient generation of JSON documents, with HTML-entity encoding handled via types. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} module Yesod.Json - ( Json + ( -- * Monad + Json , jsonToContent -- * Generate Json output , jsonScalar @@ -33,9 +34,19 @@ import Test.HUnit hiding (Test) import Data.Text.Lazy (unpack) #endif +-- | A monad for generating Json output. In truth, it is just a newtype wrapper +-- around 'Hamlet'; we thereby get the benefits of Hamlet (interleaving IO and +-- enumerator output) without accidently mixing non-JSON content. +-- +-- This is an opaque type to avoid any possible insertion of non-JSON content. +-- Due to the limited nature of the JSON format, you can create any valid JSON +-- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. newtype Json url a = Json { unJson :: Hamlet url IO a } deriving (Functor, Applicative, Monad) +-- | Extract the final result from the given 'Json' value. +-- +-- See also: applyLayoutJson in "Yesod.Yesod". jsonToContent :: Json (Routes master) () -> GHandler sub master Content jsonToContent = hamletToContent . unJson @@ -43,15 +54,24 @@ htmlContentToText :: HtmlContent -> Text htmlContentToText (Encoded t) = t htmlContentToText (Unencoded t) = encodeHtml t +-- | Outputs a single scalar. This function essentially: +-- +-- * Performs HTML entity escaping as necesary. +-- +-- * Performs JSON encoding. +-- +-- * Wraps the resulting string in quotes. jsonScalar :: HtmlContent -> Json url () jsonScalar s = Json $ do outputString "\"" output $ encodeJson $ htmlContentToText s outputString "\"" +-- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. jsonList :: [Json url ()] -> Json url () jsonList = jsonList' . fromList +-- | Same as 'jsonList', but uses an 'Enumerator' for input. jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonList' (Enumerator enum) = do Json $ outputString "[" @@ -63,9 +83,11 @@ jsonList' (Enumerator enum) = do () <- j return $ Right True +-- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. jsonMap :: [(String, Json url ())] -> Json url () jsonMap = jsonMap' . fromList +-- | Same as 'jsonMap', but uses an 'Enumerator' for input. jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () -- FIXME simplify type jsonMap' (Enumerator enum) = do Json $ outputString "{" diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index ed08fa04..b69e2ef0 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -27,7 +27,7 @@ import Yesod.Internal import Web.Routes.Quasi (QuasiSite (..)) -- | This class is automatically instantiated when you use the template haskell --- mkYesod function. +-- mkYesod function. You should never need to deal with it directly. class YesodSite y where getSite :: QuasiSite YesodApp y y @@ -36,6 +36,14 @@ class YesodSite y where class YesodSite a => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. + -- + -- If you want to be lazy, you can supply an empty string under the + -- following conditions: + -- + -- * Your application is served from the root of the domain. + -- + -- * You do not use any features that require absolute URLs, such as Atom + -- feeds and XML sitemaps. approot :: a -> Approot -- | The encryption key to be used for encrypting client sessions. @@ -54,7 +62,7 @@ class YesodSite a => Yesod a where -> Handler y ChooseRep errorHandler _ = defaultErrorHandler - -- | Applies some form of layout to and <body> contents of a page. + -- | Applies some form of layout to the contents of a page. defaultLayout :: a -> PageContent (Routes a) -> Request From d4afec1277daf3417b2897708493357b5530d233 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 08:20:36 +0300 Subject: [PATCH 219/624] Removed a number of FIXMEs --- Yesod/Dispatch.hs | 1 - Yesod/Hamlet.hs | 1 - Yesod/Helpers/Auth.hs | 32 ++++++++------------------------ Yesod/Helpers/Sitemap.hs | 4 ---- Yesod/Helpers/Static.hs | 2 -- Yesod/Yesod.hs | 2 +- 6 files changed, 9 insertions(+), 33 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c5a1c114..9dfa3819 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -124,7 +124,6 @@ toWaiApp' y resource session' env = do : encodePathInfo (fixSegs $ quasiRender site u) rr <- parseWaiRequest env session' onRequest y rr - print pathSegments -- FIXME remove let ya = case eurl of Left _ -> runHandler (errorHandler y NotFound) render diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 790a3412..a33b05b9 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -38,7 +38,6 @@ data PageContent url = PageContent , pageBody :: Hamlet url IO () } --- FIXME some typeclasses for the stuff below? -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 7dbd039c..988b950e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -98,9 +98,9 @@ getOpenIdForward = do render <- getUrlRender let complete = render OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete + let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) attempt - (\err -> redirectString RedirectTemporary -- FIXME - $ "/auth/openid/?message=" ++ encodeUrl (show err)) + (\err -> redirectString RedirectTemporary $ errurl err) (redirectString RedirectTemporary) res @@ -109,9 +109,9 @@ getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' - let onFailure err = redirectString RedirectTemporary -- FIXME - $ "/auth/openid/?message=" - ++ encodeUrl (show err) + render <- getUrlRender + let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) + let onFailure err = redirectString RedirectTemporary $ errurl err let onSuccess (OpenId.Identifier ident) = do y <- getYesod header authCookieName ident @@ -207,22 +207,6 @@ redirectLogin = do Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? redirectSetDest RedirectTemporary r -{- FIXME --- | 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 :: RedirectType @@ -230,13 +214,13 @@ redirectSetDest :: RedirectType -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender + toMaster <- getRouteToMaster curr <- getRoute let curr' = case curr of Just x -> ur x Nothing -> "/" -- should never happen anyway - dest' = ur dest addCookie destCookieTimeout destCookieName curr' - redirectString rt dest' -- FIXME use redirect? + redirect rt $ toMaster dest -- | Read the 'destCookieName' cookie and redirect to this destination. If the -- cookie is missing, then use the default path provided. @@ -248,4 +232,4 @@ redirectToDest rt def = do (x:_) -> do deleteCookie destCookieName return x - redirectString rt dest -- FIXME use redirect? + redirectString rt dest diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 361791b7..f3701b0b 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -39,10 +39,6 @@ showFreq Weekly = "weekly" showFreq Monthly = "monthly" showFreq Yearly = "yearly" showFreq Never = "never" -{- FIXME -instance ConvertSuccess SitemapChangeFreq Html where - convertSuccess = (cs :: String -> Html) . cs --} data SitemapUrl url = SitemapUrl { sitemapLoc :: url diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 40c50657..c8b24dd5 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in web-routes-quasi --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static @@ -42,7 +41,6 @@ data Static = Static FileLookup staticArgs :: FileLookup -> Static staticArgs = Static --- FIXME bug in web-routes-quasi generates warning here $(mkYesodSub "Static" [] [$parseRoutes| /* StaticRoute GET |]) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b69e2ef0..166728dc 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -108,7 +108,7 @@ applyLayoutJson :: Yesod master applyLayoutJson t x toH toJ = do let pc = PageContent { pageTitle = cs t - , pageHead = return () -- FIXME allow user to supply? + , pageHead = return () , pageBody = toH x } y <- getYesodMaster From 9424736c3e9e986c264ffd16216f7d4b6f2ac391 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 08:28:50 +0300 Subject: [PATCH 220/624] Added haddock upload script --- haddock.sh | 2 ++ 1 file changed, 2 insertions(+) create mode 100755 haddock.sh diff --git a/haddock.sh b/haddock.sh new file mode 100755 index 00000000..63fea4b2 --- /dev/null +++ b/haddock.sh @@ -0,0 +1,2 @@ +cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html' +scp -r dist/doc/html/ snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock From ace423891549801436b7643523834d01c4972045 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 22:24:22 +0300 Subject: [PATCH 221/624] Not exporting WAI Method --- Yesod.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 615a1bf6..665214eb 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,7 +13,6 @@ module Yesod , module Yesod.Hamlet , module Yesod.Json , Application - , Method (..) , cs , liftIO ) where @@ -33,7 +32,7 @@ import Yesod.Form import Yesod.Yesod import Yesod.Definitions import Yesod.Handler hiding (runHandler) -import Network.Wai (Application, Method (..)) +import Network.Wai (Application) import Yesod.Hamlet import Data.Convertible.Text (cs) #if TRANSFORMERS_02 From ca3c5b098d0c0a894a5fc3e37bb02e3dcab535d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 22:24:50 +0300 Subject: [PATCH 222/624] Some more JSON outputting functions --- Yesod/Json.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 47ea56ec..e300b124 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -5,6 +5,8 @@ module Yesod.Json ( -- * Monad Json , jsonToContent + , jsonToRepJson + , htmlContentToText -- FIXME put elsewhere? -- * Generate Json output , jsonScalar , jsonList @@ -50,6 +52,10 @@ newtype Json url a = Json { unJson :: Hamlet url IO a } jsonToContent :: Json (Routes master) () -> GHandler sub master Content jsonToContent = hamletToContent . unJson +-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. +jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson +jsonToRepJson = fmap RepJson . jsonToContent + htmlContentToText :: HtmlContent -> Text htmlContentToText (Encoded t) = t htmlContentToText (Unencoded t) = encodeHtml t From 27981e04f40b1f1beebfb748ba9aa75cddb4ce61 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 2 May 2010 22:25:16 +0300 Subject: [PATCH 223/624] Auth now usable --- Yesod/Helpers/Auth.hs | 15 +++++++++------ yesod.cabal | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 988b950e..88880b59 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -25,7 +25,10 @@ module Yesod.Helpers.Auth , displayName , redirectLogin , Auth (..) + , AuthRoutes (..) , siteAuth + , LoginType (..) + , YesodAuth (..) ) where import Web.Encodings @@ -45,15 +48,16 @@ import Control.Exception (Exception) data LoginType = OpenId | Rpxnow +class Yesod master => YesodAuth master where + onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () + data Auth = Auth { defaultDest :: String - , onRpxnowLogin :: forall master. Yesod master - => Rpxnow.Identifier -> GHandler Auth master () , rpxnowApiKey :: Maybe String , defaultLoginType :: LoginType } -$(mkYesodSub "Auth" [''Yesod] [$parseRoutes| +$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -118,7 +122,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: Yesod master => GHandler Auth master () +handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -137,8 +141,7 @@ handleRpxnowR = do (s:_) -> s (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token - auth <- getYesod - onRpxnowLogin auth ident + onRpxnowLogin ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest diff --git a/yesod.cabal b/yesod.cabal index 27c57553..670fd907 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,7 @@ library convertible-text >= 0.2.0 && < 0.3, template-haskell, web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.0 && < 0.1, + web-routes-quasi >= 0.1 && < 0.2, hamlet >= 0.0.1 && < 0.1 if flag(transformers_02) build-depends: transformers >= 0.2 && < 0.3 From 086b73ac599b04a7169cebf1c7341a1cbae5fb1c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 3 May 2010 20:56:26 +0300 Subject: [PATCH 224/624] Moved all auth settings into YesodAuth typeclass --- Yesod/Helpers/Auth.hs | 49 +++++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 20 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 88880b59..f3e56a40 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,13 +49,20 @@ import Control.Exception (Exception) data LoginType = OpenId | Rpxnow class Yesod master => YesodAuth master where + defaultDest :: master -> Routes master + + liftAuthRoute :: master -> Routes Auth -> Routes master + onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () + onRpxnowLogin _ = return () + + rpxnowApiKey :: master -> Maybe String + rpxnowApiKey _ = Nothing + + defaultLoginType :: master -> LoginType + defaultLoginType _ = OpenId data Auth = Auth - { defaultDest :: String - , rpxnowApiKey :: Maybe String - , defaultLoginType :: LoginType - } $(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /check Check GET @@ -108,23 +115,24 @@ getOpenIdForward = do (redirectString RedirectTemporary) res -getOpenIdComplete :: GHandler Auth master () +getOpenIdComplete :: YesodAuth master => GHandler Auth master () getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' render <- getUrlRender + renderm <- getUrlRenderMaster let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) let onFailure err = redirectString RedirectTemporary $ errurl err let onSuccess (OpenId.Identifier ident) = do - y <- getYesod + y <- getYesodMaster header authCookieName ident - redirectToDest RedirectTemporary $ defaultDest y + redirectToDest RedirectTemporary $ renderm $ defaultDest y attempt onFailure onSuccess res handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do - ay <- getYesod + ay <- getYesodMaster apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound @@ -133,10 +141,11 @@ handleRpxnowR = do let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken (x:_) -> x + render <- getUrlRenderMaster let dest = case pp "dest" of [] -> case getParams rr "dest" of - [] -> defaultDest ay - ("":_) -> defaultDest ay + [] -> render $ defaultDest ay + ("":_) -> render $ defaultDest ay (('#':rest):_) -> rest (s:_) -> s (d:_) -> d @@ -177,11 +186,12 @@ getCheck = do , ("displayName", jsonScalar dn) ] -getLogout :: GHandler Auth master () +getLogout :: YesodAuth master => GHandler Auth master () getLogout = do - y <- getYesod + y <- getYesodMaster deleteCookie authCookieName - redirectToDest RedirectTemporary $ defaultDest y + render <- getUrlRenderMaster + redirectToDest RedirectTemporary $ render $ defaultDest y -- | Gets the identifier for a user if available. maybeIdentifier :: RequestReader m => m (Maybe String) @@ -197,33 +207,32 @@ displayName = do -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. -authIdentifier :: GHandler Auth master String +authIdentifier :: YesodAuth master => GHandler sub master String authIdentifier = maybeIdentifier >>= maybe redirectLogin return -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie -- appropriately. -redirectLogin :: GHandler Auth master a +redirectLogin :: YesodAuth master => GHandler sub master a redirectLogin = do - y <- getYesod + y <- getYesodMaster let r = case defaultLoginType y of OpenId -> OpenIdR Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? - redirectSetDest RedirectTemporary r + redirectSetDest RedirectTemporary $ liftAuthRoute y r -- | Redirect to the given URL, and set a cookie with the current URL so the -- user will ultimately be sent back here. redirectSetDest :: RedirectType - -> Routes sub -- ^ redirect page + -> Routes master -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender - toMaster <- getRouteToMaster curr <- getRoute let curr' = case curr of Just x -> ur x Nothing -> "/" -- should never happen anyway addCookie destCookieTimeout destCookieName curr' - redirect rt $ toMaster dest + redirect rt dest -- | Read the 'destCookieName' cookie and redirect to this destination. If the -- cookie is missing, then use the default path provided. From f1fc97eda00690952b0316ebc5eee89d3825fb8e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 4 May 2010 13:15:03 +0300 Subject: [PATCH 225/624] Fixed haddock script --- Yesod/Yesod.hs | 20 +++++--------------- haddock.sh | 2 +- 2 files changed, 6 insertions(+), 16 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 166728dc..a0b4d56f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -63,11 +63,8 @@ class YesodSite a => Yesod a where errorHandler _ = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: a - -> PageContent (Routes a) - -> Request - -> Hamlet (Routes a) IO () - defaultLayout _ p _ = [$hamlet| + defaultLayout :: PageContent (Routes a) -> GHandler sub a Content + defaultLayout p = hamletToContent $ [$hamlet| !!! %html %head @@ -86,16 +83,12 @@ applyLayout :: Yesod master => String -- ^ title -> Hamlet (Routes master) IO () -- ^ body -> GHandler sub master RepHtml -applyLayout t b = do - let pc = PageContent +applyLayout t b = + RepHtml `fmap` defaultLayout PageContent { pageTitle = cs t , pageHead = return () , pageBody = b } - y <- getYesodMaster - rr <- getRequest - content <- hamletToContent $ defaultLayout y pc rr - return $ RepHtml content -- | Provide both an HTML and JSON representation for a piece of data, using -- the default layout for the HTML output ('defaultLayout'). @@ -106,14 +99,11 @@ applyLayoutJson :: Yesod master -> (x -> Json (Routes master) ()) -> GHandler sub master RepHtmlJson applyLayoutJson t x toH toJ = do - let pc = PageContent + html <- defaultLayout PageContent { pageTitle = cs t , pageHead = return () , pageBody = toH x } - y <- getYesodMaster - rr <- getRequest - html <- hamletToContent $ defaultLayout y pc rr json <- jsonToContent $ toJ x return $ RepHtmlJson html json diff --git a/haddock.sh b/haddock.sh index 63fea4b2..337c58c7 100755 --- a/haddock.sh +++ b/haddock.sh @@ -1,2 +1,2 @@ cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html' -scp -r dist/doc/html/ snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock +scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/ From 746754d510a720cb400ee06a1d4117864eb2ffcf Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 4 May 2010 17:30:23 +0300 Subject: [PATCH 226/624] Added getAuth function --- Yesod/Helpers/Auth.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f3e56a40..b04dbb12 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -29,6 +29,7 @@ module Yesod.Helpers.Auth , siteAuth , LoginType (..) , YesodAuth (..) + , getAuth ) where import Web.Encodings @@ -46,6 +47,9 @@ import Control.Exception (Exception) -- FIXME check referer header to determine destination +getAuth :: a -> Auth +getAuth = const Auth + data LoginType = OpenId | Rpxnow class Yesod master => YesodAuth master where From 56fc788d3f52e308612bbac23da349d7e9812dd6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 4 May 2010 22:02:16 +0300 Subject: [PATCH 227/624] Using cabal MIN_VERSION for transformers --- Yesod.hs | 2 +- Yesod/Form.hs | 2 +- Yesod/Handler.hs | 2 +- Yesod/Request.hs | 2 +- yesod.cabal | 15 ++------------- 5 files changed, 6 insertions(+), 17 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 665214eb..f90f5f33 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -35,7 +35,7 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import Data.Convertible.Text (cs) -#if TRANSFORMERS_02 +#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class (liftIO) #else import "transformers" Control.Monad.Trans (liftIO) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 7ccbdc7f..4e00384a 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -27,7 +27,7 @@ import Data.Time (Day) import Data.Convertible.Text import Control.Monad.Attempt import Data.Maybe (fromMaybe) -#if TRANSFORMERS_02 +#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class #else import "transformers" Control.Monad.Trans diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 398f0f07..52d4e656 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -58,7 +58,7 @@ import Web.Mime import Control.Exception hiding (Handler) import Control.Applicative -#if TRANSFORMERS_02 +#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class #else import "transformers" Control.Monad.Trans diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 1f68638b..574d1ba9 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -38,7 +38,7 @@ import qualified Network.Wai as W import Yesod.Definitions import Web.Encodings import qualified Data.ByteString.Lazy as BL -#if TRANSFORMERS_02 +#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class #else import "transformers" Control.Monad.Trans diff --git a/yesod.cabal b/yesod.cabal index 670fd907..3da5cdbf 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -11,8 +11,6 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/yesod/ -flag transformers_02 - description: transformers = 0.2.* flag buildtests description: Build the executable to run unit tests default: False @@ -33,12 +31,8 @@ library template-haskell, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.1 && < 0.2, - hamlet >= 0.0.1 && < 0.1 - if flag(transformers_02) - build-depends: transformers >= 0.2 && < 0.3 - CPP-OPTIONS: -DTRANSFORMERS_02 - else - build-depends: transformers >= 0.1 && < 0.2 + hamlet >= 0.0.1 && < 0.1, + transformers >= 0.1 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Definitions @@ -68,11 +62,6 @@ executable runtests QuickCheck >= 2 && < 3 else Buildable: False - if flag(transformers_02) - build-depends: transformers >= 0.2 && < 0.3 - CPP-OPTIONS: -DTRANSFORMERS_02 - else - build-depends: transformers >= 0.1 && < 0.2 ghc-options: -Wall main-is: runtests.hs From ed56c8731775f5c80f7c0c46ea885ba430e7a0cd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 4 May 2010 22:08:20 +0300 Subject: [PATCH 228/624] Exposing fullRender --- Yesod/Dispatch.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 9dfa3819..b941a2eb 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -8,6 +8,8 @@ module Yesod.Dispatch -- * Convert to WAI , toWaiApp , basicHandler + -- * Utilities + , fullRender ) where import Yesod.Handler @@ -120,8 +122,7 @@ toWaiApp' y resource session' env = do types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource eurl = quasiParse site pathSegments - render u = approot y ++ '/' - : encodePathInfo (fixSegs $ quasiRender site u) + render = fullRender (approot y) site rr <- parseWaiRequest env session' onRequest y rr let ya = case eurl of @@ -143,6 +144,14 @@ toWaiApp' y resource session' env = do let eh er = runHandler (errorHandler y er) render eurl' id y id unYesodApp ya eh rr types >>= responseToWaiResponse +-- | Fully render a route to an absolute URL. +fullRender :: String -- ^ approot, no trailing slash + -> QuasiSite YesodApp arg arg + -> Routes arg + -> String +fullRender ar site route = + ar ++ '/' : encodePathInfo (fixSegs $ quasiRender site route) + cleanupSegments :: [B.ByteString] -> [String] cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack From 8d58cc805134d305dd4ce629e13b7b7bf42019dd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 4 May 2010 22:11:25 +0300 Subject: [PATCH 229/624] urlRenderOverride --- Yesod/Dispatch.hs | 5 ++++- Yesod/Yesod.hs | 6 ++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index b941a2eb..19369a09 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -122,7 +122,10 @@ toWaiApp' y resource session' env = do types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource eurl = quasiParse site pathSegments - render = fullRender (approot y) site + render u = + case urlRenderOverride y u of + Nothing -> fullRender (approot y) site u + Just s -> s rr <- parseWaiRequest env session' onRequest y rr let ya = case eurl of diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a0b4d56f..d70ef4a1 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -78,6 +78,12 @@ class YesodSite a => Yesod a where onRequest :: a -> Request -> IO () onRequest _ _ = return () + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid + -- sending cookies. + urlRenderOverride :: a -> Routes a -> Maybe String + urlRenderOverride _ _ = Nothing + -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title From fd0ce32687e59b87a60ef1fc394ed9aad0117fe0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 5 May 2010 00:46:54 +0300 Subject: [PATCH 230/624] Added proper sessions --- Yesod.hs | 4 +-- Yesod/Definitions.hs | 58 ------------------------------------- Yesod/Dispatch.hs | 24 +++++++++++----- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 67 +++++++++++++++++++++++++++++++------------ Yesod/Helpers/Auth.hs | 13 +++++++++ Yesod/Json.hs | 2 +- Yesod/Request.hs | 5 ++-- Yesod/Yesod.hs | 5 ++-- yesod.cabal | 1 - 10 files changed, 87 insertions(+), 94 deletions(-) delete mode 100644 Yesod/Definitions.hs diff --git a/Yesod.hs b/Yesod.hs index f90f5f33..1e9ecb3e 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -5,7 +5,6 @@ module Yesod module Yesod.Request , module Yesod.Content , module Yesod.Yesod - , module Yesod.Definitions , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Form @@ -15,6 +14,7 @@ module Yesod , Application , cs , liftIO + , Routes ) where #if TEST @@ -30,7 +30,6 @@ import Yesod.Request import Yesod.Dispatch import Yesod.Form import Yesod.Yesod -import Yesod.Definitions import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet @@ -40,3 +39,4 @@ import "transformers" Control.Monad.IO.Class (liftIO) #else import "transformers" Control.Monad.Trans (liftIO) #endif +import Web.Routes.Quasi (Routes) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs deleted file mode 100644 index a6140165..00000000 --- a/Yesod/Definitions.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# 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 - ( -- * Type synonyms - Approot - , Language - -- * Constant values - , authCookieName - , authDisplayName - , encryptedCookies - , langKey - , destCookieName - , destCookieTimeout - -- * Other - , Routes - ) where - -import Data.ByteString.Char8 (pack, ByteString) -import Web.Routes.Quasi (Routes) - --- | 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 - -authCookieName :: String -authCookieName = "IDENTIFIER" - -authDisplayName :: String -authDisplayName = "DISPLAY_NAME" - -encryptedCookies :: [ByteString] -- FIXME make this extensible -encryptedCookies = [pack authDisplayName, pack authCookieName] - -langKey :: String -langKey = "_LANG" - -destCookieName :: String -destCookieName = "DEST" - -destCookieTimeout :: Int -destCookieTimeout = 120 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 19369a09..d5712ba9 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -14,7 +14,6 @@ module Yesod.Dispatch import Yesod.Handler import Yesod.Content -import Yesod.Definitions import Yesod.Yesod import Yesod.Request import Yesod.Internal @@ -97,6 +96,9 @@ mkYesodGeneral name clazzes isSub res = do } return $ (if isSub then id else (:) yes) [w, x, y, z] +sessionName :: B.ByteString +sessionName = B.pack "_SESSION" + -- | Convert the given argument into a WAI application, executable with any WAI -- handler. You can use 'basicHandler' if you wish. toWaiApp :: Yesod y => y -> IO W.Application @@ -107,17 +109,23 @@ toWaiApp a = do $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession encryptedCookies key' mins -- FIXME allow user input for encryptedCookies + $ \thePath -> clientsession [sessionName] key' mins $ toWaiApp' a thePath +parseSession :: B.ByteString -> [(String, String)] +parseSession bs = case reads $ cs bs of + [] -> [] + ((x, _):_) -> x + toWaiApp' :: Yesod y => y -> [B.ByteString] -> [(B.ByteString, B.ByteString)] -> W.Request -> IO W.Response -toWaiApp' y resource session' env = do - let site = getSite +toWaiApp' y resource fullSession env = do + let session' = maybe [] parseSession $ lookup sessionName fullSession + site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource @@ -188,8 +196,11 @@ fixSegs [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs +langKey :: String +langKey = "_LANG" + parseWaiRequest :: W.Request - -> [(B.ByteString, B.ByteString)] -- ^ session + -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env @@ -203,9 +214,8 @@ parseWaiRequest env session' = do langs'' = case lookup langKey gets' of Nothing -> langs' Just x -> x : langs' - session'' = map (cs *** cs) session' rbthunk <- iothunk $ rbHelper env - return $ Request gets' cookies' session'' rbthunk env langs'' + return $ Request gets' cookies' session' rbthunk env langs'' rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index a33b05b9..a30c42be 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -23,10 +23,10 @@ import Text.Hamlet import Text.Hamlet.Monad (outputHtml) import Yesod.Content import Yesod.Handler -import Yesod.Definitions import Data.Convertible.Text import Data.Object -- FIXME should we kill this? import Control.Arrow ((***)) +import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 52d4e656..39413f51 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -44,6 +44,9 @@ module Yesod.Handler , addCookie , deleteCookie , header + -- * Session + , setSession + , clearSession -- * Internal Yesod , runHandler , YesodApp (..) @@ -52,8 +55,9 @@ module Yesod.Handler import Yesod.Request import Yesod.Content import Yesod.Internal -import Yesod.Definitions import Web.Mime +import Web.Routes.Quasi (Routes) +import Data.List (foldl') import Control.Exception hiding (Handler) import Control.Applicative @@ -85,7 +89,8 @@ data HandlerData sub master = HandlerData -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses. newtype GHandler sub master a = Handler { - unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) + unHandler :: HandlerData sub master + -> IO ([Header], [(String, Maybe String)], HandlerContents a) } -- | A 'GHandler' limited to the case where the master and sub sites are the @@ -117,25 +122,25 @@ instance Applicative (GHandler sub master) where (<*>) = ap instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway - return x = Handler $ \_ -> return ([], HCContent x) + return x = Handler $ \_ -> return ([], [], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do - (headers, c) <- handler rr - (headers', c') <- + (headers, session', c) <- handler rr + (headers', session'', c') <- case c of HCContent a -> unHandler (f a) rr - HCError e -> return ([], HCError e) - HCSendFile ct fp -> return ([], HCSendFile ct fp) - HCRedirect rt url -> return ([], HCRedirect rt url) - return (headers ++ headers', c') + HCError e -> return ([], [], HCError e) + HCSendFile ct fp -> return ([], [], HCSendFile ct fp) + HCRedirect rt url -> return ([], [], HCRedirect rt url) + return (headers ++ headers', session' ++ session'', c') instance MonadIO (GHandler sub master) where - liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') + liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i') instance Failure ErrorResponse (GHandler sub master) where - failure e = Handler $ \_ -> return ([], HCError e) + failure e = Handler $ \_ -> return ([], [], HCError e) instance RequestReader (GHandler sub master) where - getRequest = Handler $ \r -> return ([], HCContent $ handlerRequest r) + getRequest = handlerRequest <$> getData getData :: GHandler sub master (HandlerData sub master) -getData = Handler $ \r -> return ([], HCContent r) +getData = Handler $ \r -> return ([], [], HCContent r) -- | Get the application argument. getYesod :: GHandler sub master sub @@ -165,6 +170,16 @@ getRoute = handlerRoute <$> getData getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) getRouteToMaster = handlerToMaster <$> getData +modifySession :: [(String, String)] -> (String, Maybe String) + -> [(String, String)] +modifySession orig (k, v) = + case v of + Nothing -> dropKeys k orig + Just v' -> (k, v') : dropKeys k orig + +dropKeys :: String -> [(String, x)] -> [(String, x)] +dropKeys k = filter $ \(x, _) -> x /= k + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c @@ -179,7 +194,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) - (headers, contents) <- Control.Exception.catch + (headersOrig, session', contents) <- Control.Exception.catch (unHandler handler HandlerData { handlerRequest = rr , handlerSub = tosa ma @@ -188,7 +203,9 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRender = mrender , handlerToMaster = tomr }) - (\e -> return ([], HCError $ toErrorHandler e)) + (\e -> return ([], [], HCError $ toErrorHandler e)) + let finalSession = foldl' modifySession (reqSession rr) session' + headers = Header "_SESSION" (show finalSession) : headersOrig -- FIXME let handleError e = do (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs @@ -221,14 +238,14 @@ redirect rt url = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = Handler $ \_ -> return ([], HCRedirect rt url) +redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = Handler $ \_ -> return ([], HCSendFile ct fp) +sendFile ct fp = Handler $ \_ -> return ([], [], HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -264,8 +281,22 @@ deleteCookie = addHeader . DeleteCookie header :: String -> String -> GHandler sub master () header a = addHeader . Header a +-- | Set a variable in the user's session. +-- +-- The session is handled by the clientsession package: it sets an encrypted +-- and hashed cookie on the client. This ensures that all data is secure and +-- not tampered with. +setSession :: String -- ^ key + -> String -- ^ value + -> GHandler sub master () +setSession k v = Handler $ \_ -> return ([], [(k, Just v)], HCContent ()) + +-- | Unsets a session variable. See 'setSession'. +clearSession :: String -> GHandler sub master () +clearSession k = Handler $ \_ -> return ([], [(k, Nothing)], HCContent ()) + addHeader :: Header -> GHandler sub master () -addHeader h = Handler $ \_ -> return ([h], HCContent ()) +addHeader h = Handler $ \_ -> return ([h], [], HCContent ()) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index b04dbb12..360be935 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -46,6 +46,7 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) -- FIXME check referer header to determine destination +-- FIXME switch to session getAuth :: a -> Auth getAuth = const Auth @@ -249,3 +250,15 @@ redirectToDest rt def = do deleteCookie destCookieName return x redirectString rt dest + +authCookieName :: String -- FIXME don't use cookies!!! +authCookieName = "IDENTIFIER" + +authDisplayName :: String +authDisplayName = "DISPLAY_NAME" + +destCookieTimeout :: Int +destCookieTimeout = 120 + +destCookieName :: String +destCookieName = "DEST" diff --git a/Yesod/Json.hs b/Yesod/Json.hs index e300b124..081df005 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -24,10 +24,10 @@ import Control.Applicative import Data.Text (Text, pack) import Web.Encodings import Yesod.Hamlet -import Yesod.Definitions import Control.Monad (when) import Yesod.Handler import Yesod.Content +import Web.Routes.Quasi (Routes) #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 574d1ba9..e7ae9b32 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -35,7 +35,6 @@ module Yesod.Request ) where import qualified Network.Wai as W -import Yesod.Definitions import Web.Encodings import qualified Data.ByteString.Lazy as BL #if MIN_VERSION_transformers(0,2,0) @@ -56,7 +55,7 @@ instance RequestReader ((->) Request) where getRequest = id -- | Get the list of supported languages supplied by the user. -languages :: RequestReader m => m [Language] +languages :: RequestReader m => m [String] languages = reqLangs `liftM` getRequest -- | Get the request\'s 'W.Request' value. @@ -82,7 +81,7 @@ data Request = Request , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. - , reqLangs :: [Language] + , reqLangs :: [String] } multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d70ef4a1..9c61f3f7 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -20,11 +20,10 @@ import Data.Convertible.Text import Control.Arrow ((***)) import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W -import Yesod.Definitions import Yesod.Json import Yesod.Internal -import Web.Routes.Quasi (QuasiSite (..)) +import Web.Routes.Quasi (QuasiSite (..), Routes) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -44,7 +43,7 @@ class YesodSite a => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> Approot + approot :: a -> String -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 diff --git a/yesod.cabal b/yesod.cabal index 3da5cdbf..8b140bd4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -35,7 +35,6 @@ library transformers >= 0.1 && < 0.3 exposed-modules: Yesod Yesod.Content - Yesod.Definitions Yesod.Dispatch Yesod.Form Yesod.Hamlet From 6db05899363ca0436757b6dbb7b3a9bf93794404 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 5 May 2010 05:12:56 +0300 Subject: [PATCH 231/624] Fixed some various FIXMEs --- Yesod/Dispatch.hs | 2 +- Yesod/Hamlet.hs | 7 +++++++ Yesod/Helpers/Auth.hs | 22 +++++++++++----------- Yesod/Json.hs | 7 +------ Yesod/Request.hs | 2 +- 5 files changed, 21 insertions(+), 19 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index d5712ba9..4ed91308 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -109,7 +109,7 @@ toWaiApp a = do $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession [sessionName] key' mins + $ \thePath -> clientsession [sessionName] key' mins -- FIXME middleware is not helping us here, drop it $ toWaiApp' a thePath parseSession :: B.ByteString -> [(String, String)] diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index a30c42be..01ced745 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -9,6 +9,7 @@ module Yesod.Hamlet Hamlet , hamlet , HtmlContent (..) + , htmlContentToText -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -27,6 +28,12 @@ import Data.Convertible.Text import Data.Object -- FIXME should we kill this? import Control.Arrow ((***)) import Web.Routes.Quasi (Routes) +import Data.Text (Text) +import Web.Encodings (encodeHtml) + +htmlContentToText :: HtmlContent -> Text +htmlContentToText (Encoded t) = t +htmlContentToText (Unencoded t) = encodeHtml t -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 360be935..24079970 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -46,7 +46,6 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) -- FIXME check referer header to determine destination --- FIXME switch to session getAuth :: a -> Auth getAuth = const Auth @@ -131,7 +130,7 @@ getOpenIdComplete = do let onFailure err = redirectString RedirectTemporary $ errurl err let onSuccess (OpenId.Identifier ident) = do y <- getYesodMaster - header authCookieName ident + setSession identKey ident redirectToDest RedirectTemporary $ renderm $ defaultDest y attempt onFailure onSuccess res @@ -156,8 +155,8 @@ handleRpxnowR = do (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token onRpxnowLogin ident - header authCookieName $ Rpxnow.identifier ident - header authDisplayName $ getDisplayName ident + setSession identKey $ Rpxnow.identifier ident + setSession displayNameKey $ getDisplayName ident redirectToDest RedirectTemporary dest data MissingToken = MissingToken @@ -194,7 +193,7 @@ getCheck = do getLogout :: YesodAuth master => GHandler Auth master () getLogout = do y <- getYesodMaster - deleteCookie authCookieName + clearSession identKey render <- getUrlRenderMaster redirectToDest RedirectTemporary $ render $ defaultDest y @@ -202,13 +201,13 @@ getLogout = do maybeIdentifier :: RequestReader m => m (Maybe String) maybeIdentifier = do s <- session - return $ listToMaybe $ s authCookieName + return $ listToMaybe $ s identKey -- | Gets the display name for a user if available. displayName :: RequestReader m => m (Maybe String) displayName = do s <- session - return $ listToMaybe $ s authDisplayName + return $ listToMaybe $ s displayNameKey -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. @@ -251,12 +250,13 @@ redirectToDest rt def = do return x redirectString rt dest -authCookieName :: String -- FIXME don't use cookies!!! -authCookieName = "IDENTIFIER" +identKey :: String +identKey = "IDENTIFIER" -authDisplayName :: String -authDisplayName = "DISPLAY_NAME" +displayNameKey :: String +displayNameKey = "DISPLAY_NAME" +-- FIXME export DEST stuff as its own module destCookieTimeout :: Int destCookieTimeout = 120 diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 081df005..8cb6f10b 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -6,7 +6,6 @@ module Yesod.Json Json , jsonToContent , jsonToRepJson - , htmlContentToText -- FIXME put elsewhere? -- * Generate Json output , jsonScalar , jsonList @@ -21,7 +20,7 @@ module Yesod.Json import Text.Hamlet.Monad import Control.Applicative -import Data.Text (Text, pack) +import Data.Text (pack) import Web.Encodings import Yesod.Hamlet import Control.Monad (when) @@ -56,10 +55,6 @@ jsonToContent = hamletToContent . unJson jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson jsonToRepJson = fmap RepJson . jsonToContent -htmlContentToText :: HtmlContent -> Text -htmlContentToText (Encoded t) = t -htmlContentToText (Unencoded t) = encodeHtml t - -- | Outputs a single scalar. This function essentially: -- -- * Performs HTML entity escaping as necesary. diff --git a/Yesod/Request.hs b/Yesod/Request.hs index e7ae9b32..5d4feb18 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -72,7 +72,7 @@ type RequestBodyContents = data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - -- | Session data stored in a cookie via the clientsession package. FIXME explain how to extend. + -- | Session data stored in a cookie via the clientsession package. , reqSession :: [(ParamName, ParamValue)] -- | The POST parameters and submitted files. This is stored in an IO -- thunk, which essentially means it will be computed once at most, but From 5c5b2ca81d6b8411a15ce540aaaa1f3c37879759 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 5 May 2010 05:26:44 +0300 Subject: [PATCH 232/624] Removed data-object --- Yesod/Hamlet.hs | 26 -------------------------- Yesod/Json.hs | 4 ++-- yesod.cabal | 1 - 3 files changed, 2 insertions(+), 29 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 01ced745..e8947155 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -15,8 +15,6 @@ module Yesod.Hamlet , hamletToRepHtml -- * Page templates , PageContent (..) - -- * data-object - , HtmlObject ) where @@ -25,8 +23,6 @@ import Text.Hamlet.Monad (outputHtml) import Yesod.Content import Yesod.Handler import Data.Convertible.Text -import Data.Object -- FIXME should we kill this? -import Control.Arrow ((***)) import Web.Routes.Quasi (Routes) import Data.Text (Text) import Web.Encodings (encodeHtml) @@ -65,27 +61,5 @@ hamletToRepHtml = fmap RepHtml . hamletToContent 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' _ = map cs s - convertSuccess (Mapping m) = template () where - template :: Monad m => () -> Hamlet url m () - template = [$hamlet| - %dl - $forall pairs pair - %dt $pair.fst$ - %dd ^pair.snd^|] - pairs _ = map (cs *** cs) m instance ConvertSuccess String HtmlContent where convertSuccess = Unencoded . cs - -type HtmlObject = Object String HtmlContent - -instance ConvertSuccess (Object String String) HtmlObject where - convertSuccess = fmap cs diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 8cb6f10b..44b56fc5 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -73,7 +73,7 @@ jsonList :: [Json url ()] -> Json url () jsonList = jsonList' . fromList -- | Same as 'jsonList', but uses an 'Enumerator' for input. -jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -- FIXME simplify type +jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () jsonList' (Enumerator enum) = do Json $ outputString "[" _ <- enum go False @@ -89,7 +89,7 @@ jsonMap :: [(String, Json url ())] -> Json url () jsonMap = jsonMap' . fromList -- | Same as 'jsonMap', but uses an 'Enumerator' for input. -jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () -- FIXME simplify type +jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () jsonMap' (Enumerator enum) = do Json $ outputString "{" _ <- enum go False diff --git a/yesod.cabal b/yesod.cabal index 8b140bd4..9a86a6b1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -23,7 +23,6 @@ library authenticate >= 0.6 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.4 && < 0.3, - data-object >= 0.2.0 && < 0.3, directory >= 1 && < 1.1, control-monad-attempt >= 0.2.0 && < 0.3, text >= 0.5 && < 0.8, From 58b2990794097930e986b19ca6e6170ad46ef1bf Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 5 May 2010 07:34:27 +0300 Subject: [PATCH 233/624] Migrated away from clientsession middleware --- Yesod/Dispatch.hs | 87 +++++++++++++++++++++++++++++++---------------- Yesod/Handler.hs | 17 +++++---- yesod.cabal | 5 +-- 3 files changed, 68 insertions(+), 41 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4ed91308..eaf56ab8 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -34,7 +34,6 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B -import Data.Maybe (fromMaybe) import Web.Encodings import Web.Mime import Data.List (intercalate) @@ -44,7 +43,11 @@ import Control.Concurrent.MVar import Control.Arrow ((***)) import Data.Convertible.Text (cs) -import Data.Time.Clock +import Data.Time + +import Control.Monad +import Data.Maybe +import Web.ClientSession -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. @@ -96,21 +99,18 @@ mkYesodGeneral name clazzes isSub res = do } return $ (if isSub then id else (:) yes) [w, x, y, z] -sessionName :: B.ByteString -sessionName = B.pack "_SESSION" +sessionName :: String +sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI -- handler. You can use 'basicHandler' if you wish. toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do - key' <- encryptKey a - let mins = clientSessionDuration a return $ gzip $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession [sessionName] key' mins -- FIXME middleware is not helping us here, drop it - $ toWaiApp' a thePath + $ toWaiApp' a parseSession :: B.ByteString -> [(String, String)] parseSession bs = case reads $ cs bs of @@ -120,11 +120,20 @@ parseSession bs = case reads $ cs bs of toWaiApp' :: Yesod y => y -> [B.ByteString] - -> [(B.ByteString, B.ByteString)] -> W.Request -> IO W.Response -toWaiApp' y resource fullSession env = do - let session' = maybe [] parseSession $ lookup sessionName fullSession +toWaiApp' y resource env = do + key' <- encryptKey y + now <- getCurrentTime + let getExpires m = fromIntegral (m * 60) `addUTCTime` now + let exp' = getExpires $ clientSessionDuration y + let host = W.remoteHost env + let session' = do + (_, raw) <- filter (\(x, _) -> x == W.Cookie) $ W.requestHeaders env + (name, val) <- parseCookies raw + guard $ name == B.pack sessionName + decoded <- maybeToList $ decodeCookie key' now host val + parseSession decoded site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env @@ -153,7 +162,16 @@ toWaiApp' y resource fullSession env = do method let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id - unYesodApp ya eh rr types >>= responseToWaiResponse + (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types + let sessionVal = encrypt key' $ B.pack $ show $ ACookie exp' host $ B.pack + $ show sessionFinal + let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs'' + return $ W.Response s hs''' $ case c of + ContentFile fp -> Left fp + ContentEnum e -> Right $ W.buffer + $ W.Enumerator e -- | Fully render a route to an absolute URL. fullRender :: String -- ^ approot, no trailing slash @@ -235,25 +253,34 @@ iothunk = fmap go . newMVar . Left where val <- comp return (Right val, val) -responseToWaiResponse :: (W.Status, [Header], ContentType, Content) - -> IO W.Response -responseToWaiResponse (sc, hs, ct, c) = do - hs' <- mapM headerToPair hs - let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' - return $ W.Response sc hs'' $ case c of - ContentFile fp -> Left fp - ContentEnum e -> Right $ W.buffer - $ W.Enumerator e - -- | 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=" +headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time + -> Header + -> (W.ResponseHeader, B.ByteString) +headerToPair getExpires (AddCookie minutes key value) = + let expires = getExpires minutes + in (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) -headerToPair (DeleteCookie key) = return +headerToPair _ (DeleteCookie key) = (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) +headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value) + +decodeCookie :: Word256 -- ^ key + -> UTCTime -- ^ current time + -> B.ByteString -- ^ remote host field + -> B.ByteString -- ^ cookie value + -> Maybe B.ByteString +decodeCookie key now rhost encrypted = do + decrypted <- decrypt key $ B.unpack encrypted + (ACookie expire rhost' val) <- + case reads $ B.unpack decrypted of + [] -> Nothing + ((x, _):_) -> Just x + guard $ expire > now + guard $ rhost' == rhost + guard $ not $ B.null val + return val + +data ACookie = ACookie UTCTime B.ByteString B.ByteString + deriving (Show, Read) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 39413f51..7743a0de 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -106,7 +106,7 @@ newtype YesodApp = YesodApp :: (ErrorResponse -> YesodApp) -> Request -> [ContentType] - -> IO (W.Status, [Header], ContentType, Content) + -> IO (W.Status, [Header], ContentType, Content, [(String, String)]) } data HandlerContents a = @@ -194,7 +194,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) - (headersOrig, session', contents) <- Control.Exception.catch + (headers, session', contents) <- Control.Exception.catch (unHandler handler HandlerData { handlerRequest = rr , handlerSub = tosa ma @@ -205,22 +205,21 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do }) (\e -> return ([], [], HCError $ toErrorHandler e)) let finalSession = foldl' modifySession (reqSession rr) session' - headers = Header "_SESSION" (show finalSession) : headersOrig -- FIXME let handleError e = do - (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts + (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs - return (getStatus e, hs', ct, c) + return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = do c <- BL.readFile fp - return (W.Status200, headers, ct, cs c) + return (W.Status200, headers, ct, cs c, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts - return (W.Status200, headers, ct, c) + return (W.Status200, headers, ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers - return (getRedirectStatus rt, hs, TypePlain, cs "") + return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession) HCSendFile ct fp -> Control.Exception.catch (sendFile' ct fp) (handleError . toErrorHandler) @@ -228,7 +227,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.Status500, [], TypePlain, cs "Internal Server Error") + return (W.Status500, [], TypePlain, cs "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a diff --git a/yesod.cabal b/yesod.cabal index 9a86a6b1..533b8c85 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -27,11 +27,12 @@ library control-monad-attempt >= 0.2.0 && < 0.3, text >= 0.5 && < 0.8, convertible-text >= 0.2.0 && < 0.3, - template-haskell, + template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.1 && < 0.2, hamlet >= 0.0.1 && < 0.1, - transformers >= 0.1 && < 0.3 + transformers >= 0.1 && < 0.3, + clientsession >= 0.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From e8a042db2dda771c9b688f5970c97e5a0d1af3e7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 6 May 2010 17:01:52 +0300 Subject: [PATCH 234/624] MonadCatchIO --- Yesod/Handler.hs | 17 ++++++++++++++--- yesod.cabal | 3 ++- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7743a0de..d29821b0 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -52,6 +52,7 @@ module Yesod.Handler , YesodApp (..) ) where +import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal @@ -59,7 +60,8 @@ import Web.Mime import Web.Routes.Quasi (Routes) import Data.List (foldl') -import Control.Exception hiding (Handler) +import Control.Exception hiding (Handler, catch) +import qualified Control.Exception as E import Control.Applicative #if MIN_VERSION_transformers(0,2,0) @@ -67,6 +69,8 @@ import "transformers" Control.Monad.IO.Class #else import "transformers" Control.Monad.Trans #endif +import qualified Control.Monad.CatchIO as C +import Control.Monad.CatchIO (catch) import Control.Monad.Attempt import Control.Monad (liftM, ap) @@ -134,6 +138,13 @@ instance Monad (GHandler sub master) where return (headers ++ headers', session' ++ session'', c') instance MonadIO (GHandler sub master) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i') +instance C.MonadCatchIO (GHandler sub master) where + catch (Handler m) f = + Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d) + block (Handler m) = + Handler $ \d -> E.block (m d) + unblock (Handler m) = + Handler $ \d -> E.unblock (m d) instance Failure ErrorResponse (GHandler sub master) where failure e = Handler $ \_ -> return ([], [], HCError e) instance RequestReader (GHandler sub master) where @@ -194,7 +205,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) - (headers, session', contents) <- Control.Exception.catch + (headers, session', contents) <- E.catch (unHandler handler HandlerData { handlerRequest = rr , handlerSub = tosa ma @@ -220,7 +231,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do HCRedirect rt loc -> do let hs = Header "Location" loc : headers return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession) - HCSendFile ct fp -> Control.Exception.catch + HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) diff --git a/yesod.cabal b/yesod.cabal index 533b8c85..45f0b980 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,8 @@ library web-routes-quasi >= 0.1 && < 0.2, hamlet >= 0.0.1 && < 0.1, transformers >= 0.1 && < 0.3, - clientsession >= 0.2 && < 0.3 + clientsession >= 0.2 && < 0.3, + MonadCatchIO-transformers >= 0.2.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 4578808df11d9a1c0c81aa1c86235db565e73781 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 7 May 2010 09:24:35 +0300 Subject: [PATCH 235/624] Exposing some keys from Auth --- Yesod/Helpers/Auth.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 24079970..845b8f16 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -30,6 +30,8 @@ module Yesod.Helpers.Auth , LoginType (..) , YesodAuth (..) , getAuth + , identKey + , displayNameKey ) where import Web.Encodings From 5df1351a746592b962d4d2643c6905fe9de459ef Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 7 May 2010 10:07:33 +0300 Subject: [PATCH 236/624] Added EmailAuth --- Yesod/Helpers/EmailAuth.hs | 274 +++++++++++++++++++++++++++++++++++++ yesod.cabal | 5 +- 2 files changed, 278 insertions(+), 1 deletion(-) create mode 100644 Yesod/Helpers/EmailAuth.hs diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs new file mode 100644 index 00000000..a32b65a2 --- /dev/null +++ b/Yesod/Helpers/EmailAuth.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} +module Yesod.Helpers.EmailAuth + ( getEmailAuth + , EmailAuth + , siteEmailAuth + , EmailAuthRoutes (..) + , YesodEmailAuth (..) + ) where + +import Yesod +import Yesod.Helpers.Auth +import System.Random +import Data.Maybe +import Control.Applicative +import Control.Monad +import Data.Digest.Pure.MD5 + +class Yesod y => YesodEmailAuth y where + addUnverified :: y + -> String -- ^ email + -> String -- ^ verification key + -> IO Integer -- ^ login_id + sendVerifyEmail :: y + -> String -- ^ email + -> String -- ^ verification key + -> String -- ^ verify URL + -> IO () + getVerifyKey :: y + -> Integer -- ^ login_id + -> IO (Maybe String) + verifyAccount :: y + -> Integer -- ^ login_id + -> IO () + setPassword :: y + -> Integer -- ^ login_id + -> String -- ^ salted password + -> IO () + getCreds :: y + -> String -- ^ email address + -> IO (Maybe (Integer, Maybe String, Bool, String)) -- ^ id, salted pass, is verified, verify key + getEmail :: y -> Integer -> IO (Maybe String) + + randomKey :: y -> IO String + randomKey _ = do + stdgen <- newStdGen + return $ take 10 $ randomRs ('A', 'Z') stdgen + + onSuccessfulLogin :: y -> Routes y + onSuccessfulLogout :: y -> Routes y + + onEmailAuthLogin :: y + -> String -- ^ email + -> Integer -- ^ login_id + -> IO () + +data EmailAuth = EmailAuth + +getEmailAuth :: a -> EmailAuth +getEmailAuth _ = EmailAuth + +mkYesodSub "EmailAuth" [''YesodEmailAuth] [$parseRoutes| +/register RegisterR GET POST +/verify/#/$ VerifyR GET +/login LoginR GET POST +/set-password PasswordR GET POST +/logout LogoutR GET +|] + +getRegisterR :: Yesod master => GHandler EmailAuth master RepHtml +getRegisterR = do + toMaster <- getRouteToMaster + applyLayout "Register a new account" $ [$hamlet| +%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. +%form!method=post!action=@id@ + %label!for=email E-mail + %input#email!type=email!name=email!width=150 + %input!type=submit!value=Register +|] $ toMaster RegisterR + +postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml +postRegisterR = do + email <- runFormPost $ checkEmail $ required $ input "email" + y <- getYesodMaster + creds <- liftIO $ getCreds y email + (lid, verKey) <- + case creds of + Nothing -> liftIO $ do + key <- randomKey y + lid <- addUnverified y email key + return (lid, key) + Just (lid, _, _, key) -> return (lid, key) + render <- getUrlRender + let verUrl = render $ VerifyR lid verKey + liftIO $ sendVerifyEmail y email verKey verUrl + applyLayout "Confirmation e-mail sent" $ [$hamlet| +%p A confirmation e-mail has been sent to $id$. +|] $ cs email + +checkEmail :: Form ParamValue -> Form ParamValue +checkEmail = notEmpty -- FIXME + +getVerifyR :: YesodEmailAuth master + => Integer -> String -> GHandler EmailAuth master RepHtml +getVerifyR lid key = do + y <- getYesodMaster + realKey <- liftIO $ getVerifyKey y lid + memail <- liftIO $ getEmail y lid + case (realKey == Just key, memail) of + (True, Just email) -> do + liftIO $ verifyAccount y lid + setLoginSession email lid + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster PasswordR + _ -> applyLayout "Invalid verification key" $ [$hamlet| +%p I'm sorry, but that was an invalid verification key. + |] () + +messageKey :: String +messageKey = "MESSAGE" + +getMessage :: GHandler sub master (Maybe HtmlContent) +getMessage = do + s <- session + clearSession messageKey + return $ listToMaybe $ map (Encoded . cs) $ s messageKey + +setMessage :: String -> GHandler sub master () +setMessage = setSession messageKey . cs + +getLoginR :: Yesod master => GHandler EmailAuth master RepHtml +getLoginR = do + toMaster <- getRouteToMaster + msg <- getMessage + applyLayout "Login" $ [$hamlet| +$maybe snd msg + %p.message $msg$ +%p Please log in to your account. +%p + %a!href=@fst.fst@ I don't have an account +%form!method=post!action=@fst.snd@ + %table + %tr + %th E-mail + %td + %input!type=email!name=email + %tr + %th Password + %td + %input!type=password!name=password + %tr + %td!colspan=2 + %input!type=submit!value=Login +|] ((toMaster RegisterR, toMaster LoginR), msg) + +postLoginR :: YesodEmailAuth master => GHandler EmailAuth master () +postLoginR = do + (email, pass) <- runFormPost $ (,) + <$> checkEmail (required $ input "email") + <*> required (input "password") + y <- getYesodMaster + creds <- liftIO $ getCreds y email + let mlid = + case creds of + Just (lid, Just realpass, True, _) -> + if isValidPass pass realpass then Just lid else Nothing + _ -> Nothing + case mlid of + Just lid -> do + setLoginSession email lid + redirect RedirectTemporary $ onSuccessfulLogin y + Nothing -> do + setMessage "Invalid email/password combination" + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + +getPasswordR :: Yesod master => GHandler EmailAuth master RepHtml +getPasswordR = do + l <- isJust <$> isLoggedIn + toMaster <- getRouteToMaster + unless l $ do + setMessage "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster LoginR + msg <- getMessage + applyLayout "Set password" $ [$hamlet| +$maybe fst msg + %p.message $msg$ +%h3 Set a new password +%form!method=post!action=@snd@ + %table + %tr + %th New password + %td + %input!type=password!name=new + %tr + %th Confirm + %td + %input!type=password!name=confirm + %tr + %td!colspan=2 + %input!type=submit!value=Submit +|] (msg, toMaster PasswordR) + +postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master () +postPasswordR = do + (new, confirm) <- runFormPost $ (,) + <$> notEmpty (required $ input "new") + <*> notEmpty (required $ input "confirm") + toMaster <- getRouteToMaster + when (new /= confirm) $ do + setMessage "Passwords did not match, please try again" + redirect RedirectTemporary $ toMaster PasswordR + mlid <- isLoggedIn + lid <- case mlid of + Just lid -> return lid + Nothing -> do + setMessage "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster LoginR + salted <- liftIO $ saltPass new + y <- getYesodMaster + liftIO $ setPassword y lid salted + setMessage "Password updated" + redirect RedirectTemporary $ toMaster LoginR + +getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml +getLogoutR = do + clearSession identKey + clearSession displayNameKey + clearSession emailAuthIdKey + y <- getYesodMaster + redirect RedirectTemporary $ onSuccessfulLogout y + +saltLength :: Int +saltLength = 5 + +isValidPass :: String -- ^ cleartext password + -> String -- ^ salted password + -> Bool +isValidPass clear salted = + let salt = take saltLength salted + in salted == saltPass' salt clear + +saltPass :: String -> IO String +saltPass pass = do + stdgen <- newStdGen + let salt = take saltLength $ randomRs ('A', 'Z') stdgen + return $ saltPass' salt pass + +saltPass' :: String -> String -> String -- FIXME better salting scheme? +saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) + +emailAuthIdKey :: String +emailAuthIdKey = "EMAIL_AUTH_ID" + +setLoginSession :: YesodEmailAuth master + => String -> Integer -> GHandler sub master () +setLoginSession email lid = do + setSession identKey email + setSession displayNameKey email + setSession emailAuthIdKey $ show lid + y <- getYesodMaster + liftIO $ onEmailAuthLogin y email lid + +isLoggedIn :: GHandler sub master (Maybe Integer) +isLoggedIn = do + s <- session + return $ + if null (s identKey) + then Nothing + else listToMaybe (s emailAuthIdKey) >>= readMay + +readMay :: String -> Maybe Integer +readMay s = case reads s of + [] -> Nothing + ((i, _):_) -> Just i diff --git a/yesod.cabal b/yesod.cabal index 45f0b980..a7ea9626 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -33,7 +33,9 @@ library hamlet >= 0.0.1 && < 0.1, transformers >= 0.1 && < 0.3, clientsession >= 0.2 && < 0.3, - MonadCatchIO-transformers >= 0.2.2 && < 0.3 + MonadCatchIO-transformers >= 0.2.2 && < 0.3, + pureMD5 >= 1.0.0.3 && < 1.1, + random >= 1.0.0.2 && < 1.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch @@ -48,6 +50,7 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static + Yesod.Helpers.EmailAuth Web.Mime ghc-options: -Wall From 7a4f1ad6de074ecc2ee53189ece14d64719ff416 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 8 May 2010 22:09:43 +0300 Subject: [PATCH 237/624] Updated to hamlet 0.2 --- Yesod/Helpers/AtomFeed.hs | 24 ++++++++++++------------ Yesod/Helpers/Auth.hs | 22 +++++++++------------- Yesod/Helpers/EmailAuth.hs | 26 +++++++++++++------------- Yesod/Helpers/Sitemap.hs | 6 +++--- Yesod/Yesod.hs | 18 +++++++++--------- yesod.cabal | 2 +- 6 files changed, 47 insertions(+), 51 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 046e83a8..378315c2 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -52,22 +52,22 @@ xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url IO () template = [$hamlet| -%feed!xmlns=$xmlns$ - %title $atomTitle.cs$ - %link!rel=self!href=@atomLinkSelf@ - %link!href=@atomLinkHome@ - %updated $atomUpdated.formatW3.cs$ - %id @atomLinkHome@ - $forall atomEntries entry +%feed!xmlns=$.xmlns$ + %title $.atomTitle.cs$ + %link!rel=self!href=@.atomLinkSelf@ + %link!href=@.atomLinkHome@ + %updated $.atomUpdated.formatW3.cs$ + %id @.atomLinkHome@ + $forall .atomEntries entry ^entry.entryTemplate^ |] entryTemplate :: AtomFeedEntry url -> Hamlet url IO () entryTemplate = [$hamlet| %entry - %id @atomEntryLink@ - %link!href=@atomEntryLink@ - %updated $atomEntryUpdated.formatW3.cs$ - %title $atomEntryTitle.cs$ - %content!type=html $atomEntryContent.cdata$ + %id @.atomEntryLink@ + %link!href=@.atomEntryLink@ + %updated $.atomEntryUpdated.formatW3.cs$ + %title $.atomEntryTitle.cs$ + %content!type=html $.atomEntryContent.cdata$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 845b8f16..e4b9d72b 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -43,6 +43,7 @@ import Data.Convertible.Text import Control.Monad.Attempt import Data.Maybe +import Control.Applicative import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -90,21 +91,16 @@ getOpenIdR = do [] -> return () (x:_) -> addCookie destCookieTimeout destCookieName x rtom <- getRouteToMaster - let html = template (getParams rr "message", rtom) - applyLayout "Log in via OpenID" html - where - urlForward (_, wrapper) = wrapper OpenIdForward - hasMessage = not . null . fst - message ([], _) = cs "" - message (m:_, _) = cs m - template = [$hamlet| -$if hasMessage - %p.message $message$ + let message = cs <$> (listToMaybe $ getParams rr "message") + let urlForward = rtom OpenIdForward + applyLayout "Log in via OpenID" $ [$hamlet| +$maybe message msg + %p.message $msg$ %form!method=get!action=@urlForward@ %label!for=openid OpenID: %input#openid!type=text!name=openid %input!type=submit!value=Login -|] +|] () getOpenIdForward :: GHandler Auth master () getOpenIdForward = do @@ -183,9 +179,9 @@ getCheck = do %h1 Authentication Status %dl %dt identifier - %dd $fst$ + %dd $.fst$ %dt displayName - %dd $snd$ + %dd $.snd$ |] json (ident, dn) = jsonMap [ ("ident", jsonScalar ident) diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index a32b65a2..9fc28c24 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -71,11 +71,11 @@ getRegisterR = do toMaster <- getRouteToMaster applyLayout "Register a new account" $ [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. -%form!method=post!action=@id@ +%form!method=post!action=@RegisterR.toMaster@ %label!for=email E-mail %input#email!type=email!name=email!width=150 %input!type=submit!value=Register -|] $ toMaster RegisterR +|] () postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml postRegisterR = do @@ -93,8 +93,8 @@ postRegisterR = do let verUrl = render $ VerifyR lid verKey liftIO $ sendVerifyEmail y email verKey verUrl applyLayout "Confirmation e-mail sent" $ [$hamlet| -%p A confirmation e-mail has been sent to $id$. -|] $ cs email +%p A confirmation e-mail has been sent to $email.cs$. +|] () checkEmail :: Form ParamValue -> Form ParamValue checkEmail = notEmpty -- FIXME @@ -132,12 +132,12 @@ getLoginR = do toMaster <- getRouteToMaster msg <- getMessage applyLayout "Login" $ [$hamlet| -$maybe snd msg - %p.message $msg$ +$maybe msg ms + %p.message $ms$ %p Please log in to your account. %p - %a!href=@fst.fst@ I don't have an account -%form!method=post!action=@fst.snd@ + %a!href=@RegisterR.toMaster@ I don't have an account +%form!method=post!action=@LoginR.toMaster@ %table %tr %th E-mail @@ -150,7 +150,7 @@ $maybe snd msg %tr %td!colspan=2 %input!type=submit!value=Login -|] ((toMaster RegisterR, toMaster LoginR), msg) +|] () postLoginR :: YesodEmailAuth master => GHandler EmailAuth master () postLoginR = do @@ -182,10 +182,10 @@ getPasswordR = do redirect RedirectTemporary $ toMaster LoginR msg <- getMessage applyLayout "Set password" $ [$hamlet| -$maybe fst msg - %p.message $msg$ +$maybe msg ms + %p.message $ms$ %h3 Set a new password -%form!method=post!action=@snd@ +%form!method=post!action=@PasswordR.toMaster@ %table %tr %th New password @@ -198,7 +198,7 @@ $maybe fst msg %tr %td!colspan=2 %input!type=submit!value=Submit -|] (msg, toMaster PasswordR) +|] () postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master () postPasswordR = do diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index f3701b0b..3e030fc0 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -47,13 +47,13 @@ data SitemapUrl url = SitemapUrl , priority :: Double } -sitemapNS :: [SitemapUrl url] -> HtmlContent -sitemapNS _ = cs "http://www.sitemaps.org/schemas/sitemap/0.9" +sitemapNS :: HtmlContent +sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" template :: [SitemapUrl url] -> Hamlet url IO () template = [$hamlet| %urlset!xmlns=$sitemapNS$ - $forall id url + $forall .id url %url %loc @url.sitemapLoc@ %lastmod $url.sitemapLastMod.formatW3.cs$ diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9c61f3f7..f4ec0d51 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -67,11 +67,11 @@ class YesodSite a => Yesod a where !!! %html %head - %title $pageTitle$ - ^pageHead^ + %title $p.pageTitle$ + ^p.pageHead^ %body - ^pageBody^ -|] p + ^p.pageBody^ +|] () -- | Gets called at the beginning of each request. Useful for logging. onRequest :: a -> Request -> IO () @@ -126,7 +126,7 @@ defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $helper$ +%p $.helper$ |] r where helper = Unencoded . cs . W.pathInfo @@ -146,10 +146,10 @@ defaultErrorHandler (InvalidArgs ia) = defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error -%p $cs$ -|] e +%p $e.cs$ +|] () defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported -%p Method "$cs$" not supported -|] m +%p Method "$m.cs$" not supported +|] () diff --git a/yesod.cabal b/yesod.cabal index a7ea9626..eae3bc17 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,7 +30,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.1 && < 0.2, - hamlet >= 0.0.1 && < 0.1, + hamlet >= 0.2.0 && < 0.3, transformers >= 0.1 && < 0.3, clientsession >= 0.2 && < 0.3, MonadCatchIO-transformers >= 0.2.2 && < 0.3, From db5b82f74d0b4909d24b415777a17c63815878f2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 8 May 2010 23:34:31 +0300 Subject: [PATCH 238/624] Reverse order, no args from hamlet --- Yesod/Helpers/AtomFeed.hs | 30 +++++++++++++++--------------- Yesod/Helpers/Auth.hs | 11 +++++------ Yesod/Helpers/EmailAuth.hs | 22 +++++++++++----------- Yesod/Helpers/Sitemap.hs | 12 ++++++------ Yesod/Yesod.hs | 37 +++++++++++++++++-------------------- 5 files changed, 54 insertions(+), 58 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 378315c2..4bcd6b0f 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -51,23 +51,23 @@ xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url IO () -template = [$hamlet| -%feed!xmlns=$.xmlns$ - %title $.atomTitle.cs$ - %link!rel=self!href=@.atomLinkSelf@ - %link!href=@.atomLinkHome@ - %updated $.atomUpdated.formatW3.cs$ - %id @.atomLinkHome@ - $forall .atomEntries entry - ^entry.entryTemplate^ +template arg = [$hamlet| +%feed!xmlns=$xmlns.arg$ + %title $cs.atomTitle.arg$ + %link!rel=self!href=@atomLinkSelf.arg@ + %link!href=@atomLinkHome.arg@ + %updated $cs.formatW3.atomUpdated.arg$ + %id @atomLinkHome.arg@ + $forall atomEntries.arg entry + ^entryTemplate.entry^ |] entryTemplate :: AtomFeedEntry url -> Hamlet url IO () -entryTemplate = [$hamlet| +entryTemplate arg = [$hamlet| %entry - %id @.atomEntryLink@ - %link!href=@.atomEntryLink@ - %updated $.atomEntryUpdated.formatW3.cs$ - %title $.atomEntryTitle.cs$ - %content!type=html $.atomEntryContent.cdata$ + %id @atomEntryLink.arg@ + %link!href=@atomEntryLink.arg@ + %updated $cs.formatW3.atomEntryUpdated.arg$ + %title $cs.atomEntryTitle.arg$ + %content!type=html $cdata.atomEntryContent.arg$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e4b9d72b..09eed898 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -92,15 +92,14 @@ getOpenIdR = do (x:_) -> addCookie destCookieTimeout destCookieName x rtom <- getRouteToMaster let message = cs <$> (listToMaybe $ getParams rr "message") - let urlForward = rtom OpenIdForward applyLayout "Log in via OpenID" $ [$hamlet| $maybe message msg %p.message $msg$ -%form!method=get!action=@urlForward@ +%form!method=get!action=@rtom.OpenIdForward@ %label!for=openid OpenID: %input#openid!type=text!name=openid %input!type=submit!value=Login -|] () +|] getOpenIdForward :: GHandler Auth master () getOpenIdForward = do @@ -175,13 +174,13 @@ getCheck = do let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) applyLayoutJson "Authentication Status" arg html json where - html = [$hamlet| + html (x, y) = [$hamlet| %h1 Authentication Status %dl %dt identifier - %dd $.fst$ + %dd $x$ %dt displayName - %dd $.snd$ + %dd $y$ |] json (ident, dn) = jsonMap [ ("ident", jsonScalar ident) diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index 9fc28c24..0474ff85 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -71,11 +71,11 @@ getRegisterR = do toMaster <- getRouteToMaster applyLayout "Register a new account" $ [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. -%form!method=post!action=@RegisterR.toMaster@ +%form!method=post!action=@toMaster.RegisterR@ %label!for=email E-mail %input#email!type=email!name=email!width=150 %input!type=submit!value=Register -|] () +|] postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml postRegisterR = do @@ -93,8 +93,8 @@ postRegisterR = do let verUrl = render $ VerifyR lid verKey liftIO $ sendVerifyEmail y email verKey verUrl applyLayout "Confirmation e-mail sent" $ [$hamlet| -%p A confirmation e-mail has been sent to $email.cs$. -|] () +%p A confirmation e-mail has been sent to $cs.email$. +|] checkEmail :: Form ParamValue -> Form ParamValue checkEmail = notEmpty -- FIXME @@ -113,7 +113,7 @@ getVerifyR lid key = do redirect RedirectTemporary $ toMaster PasswordR _ -> applyLayout "Invalid verification key" $ [$hamlet| %p I'm sorry, but that was an invalid verification key. - |] () + |] messageKey :: String messageKey = "MESSAGE" @@ -136,8 +136,8 @@ $maybe msg ms %p.message $ms$ %p Please log in to your account. %p - %a!href=@RegisterR.toMaster@ I don't have an account -%form!method=post!action=@LoginR.toMaster@ + %a!href=@toMaster.RegisterR@ I don't have an account +%form!method=post!action=@toMaster.LoginR@ %table %tr %th E-mail @@ -150,7 +150,7 @@ $maybe msg ms %tr %td!colspan=2 %input!type=submit!value=Login -|] () +|] postLoginR :: YesodEmailAuth master => GHandler EmailAuth master () postLoginR = do @@ -181,11 +181,11 @@ getPasswordR = do setMessage "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR msg <- getMessage - applyLayout "Set password" $ [$hamlet| + applyLayout "Set password" [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password -%form!method=post!action=@PasswordR.toMaster@ +%form!method=post!action=@toMaster.PasswordR@ %table %tr %th New password @@ -198,7 +198,7 @@ $maybe msg ms %tr %td!colspan=2 %input!type=submit!value=Submit -|] () +|] postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master () postPasswordR = do diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 3e030fc0..9116dd0c 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -51,14 +51,14 @@ sitemapNS :: HtmlContent sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" template :: [SitemapUrl url] -> Hamlet url IO () -template = [$hamlet| +template urls = [$hamlet| %urlset!xmlns=$sitemapNS$ - $forall .id url + $forall urls url %url - %loc @url.sitemapLoc@ - %lastmod $url.sitemapLastMod.formatW3.cs$ - %changefreq $url.sitemapChangeFreq.showFreq.cs$ - %priority $url.priority.show.cs$ + %loc @sitemapLoc.url@ + %lastmod $cs.formatW3.sitemapLastMod.url$ + %changefreq $cs.showFreq.sitemapChangeFreq.url$ + %priority $cs.show.priority.url$ |] sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f4ec0d51..9a62c8b6 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,7 +17,6 @@ import Yesod.Request import Yesod.Hamlet import Yesod.Handler import Data.Convertible.Text -import Control.Arrow ((***)) import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W import Yesod.Json @@ -63,15 +62,15 @@ class YesodSite a => Yesod a where -- | Applies some form of layout to the contents of a page. defaultLayout :: PageContent (Routes a) -> GHandler sub a Content - defaultLayout p = hamletToContent $ [$hamlet| + defaultLayout p = hamletToContent [$hamlet| !!! %html %head - %title $p.pageTitle$ - ^p.pageHead^ + %title $pageTitle.p$ + ^pageHead.p^ %body - ^p.pageBody^ -|] () + ^pageBody.p^ +|] -- | Gets called at the beginning of each request. Useful for logging. onRequest :: a -> Request -> IO () @@ -126,30 +125,28 @@ defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $.helper$ -|] r +%p $Unencoded.cs.pathInfo.r$ +|] where - helper = Unencoded . cs . W.pathInfo + pathInfo = W.pathInfo defaultErrorHandler PermissionDenied = applyLayout' "Permission Denied" $ [$hamlet| -%h1 Permission denied|] () +%h1 Permission denied|] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl - $forall ias pair - %dt $pair.fst$ - %dd $pair.snd$ -|] () - where - ias _ = map (cs *** cs) ia + $forall ia pair + %dt $cs.fst.pair$ + %dd $cs.snd.pair$ +|] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error -%p $e.cs$ -|] () +%p $cs.e$ +|] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported -%p Method "$m.cs$" not supported -|] () +%p Method "$cs.m$" not supported +|] From 32465f4e971df3b50028dae795e7c095467112e1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 9 May 2010 02:15:15 +0300 Subject: [PATCH 239/624] Master/Sub bikeshedding --- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 39 +++++++++++++++++++++----------------- Yesod/Helpers/Auth.hs | 31 ++++++++++++++++-------------- Yesod/Helpers/EmailAuth.hs | 15 ++++++++------- Yesod/Helpers/Sitemap.hs | 4 ++-- Yesod/Helpers/Static.hs | 2 +- 6 files changed, 51 insertions(+), 42 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e8947155..f11bd3ba 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -45,7 +45,7 @@ data PageContent url = PageContent -- Yesod 'Response'. hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content hamletToContent h = do - render <- getUrlRenderMaster + render <- getUrlRender return $ ContentEnum $ go render where go render iter seed = do diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d29821b0..f4921e7a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -26,20 +26,23 @@ module Yesod.Handler , GHandler -- ** Read information from handler , getYesod - , getYesodMaster + , getYesodSub , getUrlRender - , getUrlRenderMaster , getRoute , getRouteToMaster -- * Special responses + -- ** Redirecting , RedirectType (..) , redirect + , redirectParams , redirectString - , sendFile + -- ** Errors , notFound , badMethod , permissionDenied , invalidArgs + -- ** Sending static files + , sendFile -- * Setting headers , addCookie , deleteCookie @@ -59,6 +62,7 @@ import Yesod.Internal import Web.Mime import Web.Routes.Quasi (Routes) import Data.List (foldl') +import Web.Encodings (encodeUrlPairs) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -153,23 +157,17 @@ instance RequestReader (GHandler sub master) where getData :: GHandler sub master (HandlerData sub master) getData = Handler $ \r -> return ([], [], HCContent r) --- | Get the application argument. -getYesod :: GHandler sub master sub -getYesod = handlerSub <$> getData +-- | Get the sub application argument. +getYesodSub :: GHandler sub master sub +getYesodSub = handlerSub <$> getData -- | Get the master site appliation argument. -getYesodMaster :: GHandler sub master master -getYesodMaster = handlerMaster <$> getData +getYesod :: GHandler sub master master +getYesod = handlerMaster <$> getData -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Routes sub -> String) -getUrlRender = do - d <- getData - return $ handlerRender d . handlerToMaster d - --- | Get the URL rendering function for the master site. -getUrlRenderMaster :: GHandler sub master (Routes master -> String) -getUrlRenderMaster = handlerRender <$> getData +getUrlRender :: GHandler sub master (Routes master -> String) +getUrlRender = handlerRender <$> getData -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. @@ -243,9 +241,16 @@ safeEh er = YesodApp $ \_ _ _ -> do -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a redirect rt url = do - r <- getUrlRenderMaster + r <- getUrlRender redirectString rt $ r url +-- | Redirects to the given route with the associated query-string parameters. +redirectParams :: RedirectType -> Routes master -> [(String, String)] + -> GHandler sub master a +redirectParams rt url params = do + r <- getUrlRender + redirectString rt $ r url ++ '?' : encodeUrlPairs params + -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 09eed898..763201c5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -108,11 +108,12 @@ getOpenIdForward = do [x] -> return x _ -> invalidArgs [("openid", show ExpectedSingleParam)] render <- getUrlRender - let complete = render OpenIdComplete + toMaster <- getRouteToMaster + let complete = render $ toMaster OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete - let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) attempt - (\err -> redirectString RedirectTemporary $ errurl err) + (\err -> redirectParams RedirectTemporary (toMaster OpenIdR) + [("message", show err)]) (redirectString RedirectTemporary) res @@ -121,19 +122,20 @@ getOpenIdComplete = do rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' - render <- getUrlRender - renderm <- getUrlRenderMaster + renderm <- getUrlRender + toMaster <- getRouteToMaster + let render = renderm . toMaster let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) let onFailure err = redirectString RedirectTemporary $ errurl err let onSuccess (OpenId.Identifier ident) = do - y <- getYesodMaster + y <- getYesod setSession identKey ident redirectToDest RedirectTemporary $ renderm $ defaultDest y attempt onFailure onSuccess res handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do - ay <- getYesodMaster + ay <- getYesod apiKey <- case rpxnowApiKey ay of Just x -> return x Nothing -> notFound @@ -142,11 +144,11 @@ handleRpxnowR = do let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken (x:_) -> x - render <- getUrlRenderMaster + renderm <- getUrlRender let dest = case pp "dest" of [] -> case getParams rr "dest" of - [] -> render $ defaultDest ay - ("":_) -> render $ defaultDest ay + [] -> renderm $ defaultDest ay + ("":_) -> renderm $ defaultDest ay (('#':rest):_) -> rest (s:_) -> s (d:_) -> d @@ -189,9 +191,9 @@ getCheck = do getLogout :: YesodAuth master => GHandler Auth master () getLogout = do - y <- getYesodMaster + y <- getYesod clearSession identKey - render <- getUrlRenderMaster + render <- getUrlRender redirectToDest RedirectTemporary $ render $ defaultDest y -- | Gets the identifier for a user if available. @@ -215,7 +217,7 @@ authIdentifier = maybeIdentifier >>= maybe redirectLogin return -- appropriately. redirectLogin :: YesodAuth master => GHandler sub master a redirectLogin = do - y <- getYesodMaster + y <- getYesod let r = case defaultLoginType y of OpenId -> OpenIdR Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? @@ -228,9 +230,10 @@ redirectSetDest :: RedirectType -> GHandler sub master a redirectSetDest rt dest = do ur <- getUrlRender + tm <- getRouteToMaster curr <- getRoute let curr' = case curr of - Just x -> ur x + Just x -> ur $ tm x Nothing -> "/" -- should never happen anyway addCookie destCookieTimeout destCookieName curr' redirect rt dest diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index 0474ff85..46c64066 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -80,7 +80,7 @@ getRegisterR = do postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml postRegisterR = do email <- runFormPost $ checkEmail $ required $ input "email" - y <- getYesodMaster + y <- getYesod creds <- liftIO $ getCreds y email (lid, verKey) <- case creds of @@ -90,7 +90,8 @@ postRegisterR = do return (lid, key) Just (lid, _, _, key) -> return (lid, key) render <- getUrlRender - let verUrl = render $ VerifyR lid verKey + tm <- getRouteToMaster + let verUrl = render $ tm $ VerifyR lid verKey liftIO $ sendVerifyEmail y email verKey verUrl applyLayout "Confirmation e-mail sent" $ [$hamlet| %p A confirmation e-mail has been sent to $cs.email$. @@ -102,7 +103,7 @@ checkEmail = notEmpty -- FIXME getVerifyR :: YesodEmailAuth master => Integer -> String -> GHandler EmailAuth master RepHtml getVerifyR lid key = do - y <- getYesodMaster + y <- getYesod realKey <- liftIO $ getVerifyKey y lid memail <- liftIO $ getEmail y lid case (realKey == Just key, memail) of @@ -157,7 +158,7 @@ postLoginR = do (email, pass) <- runFormPost $ (,) <$> checkEmail (required $ input "email") <*> required (input "password") - y <- getYesodMaster + y <- getYesod creds <- liftIO $ getCreds y email let mlid = case creds of @@ -216,7 +217,7 @@ postPasswordR = do setMessage "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR salted <- liftIO $ saltPass new - y <- getYesodMaster + y <- getYesod liftIO $ setPassword y lid salted setMessage "Password updated" redirect RedirectTemporary $ toMaster LoginR @@ -226,7 +227,7 @@ getLogoutR = do clearSession identKey clearSession displayNameKey clearSession emailAuthIdKey - y <- getYesodMaster + y <- getYesod redirect RedirectTemporary $ onSuccessfulLogout y saltLength :: Int @@ -257,7 +258,7 @@ setLoginSession email lid = do setSession identKey email setSession displayNameKey email setSession emailAuthIdKey $ show lid - y <- getYesodMaster + y <- getYesod liftIO $ onEmailAuthLogin y email lid isLoggedIn :: GHandler sub master (Maybe Integer) diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 9116dd0c..3c150abc 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -67,5 +67,5 @@ sitemap = fmap RepXml . hamletToContent . template robots :: Routes sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do - r <- getUrlRender - return $ RepPlain $ cs $ "Sitemap: " ++ r smurl + tm <- getRouteToMaster + RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|] diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index c8b24dd5..1e133f5f 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -77,7 +77,7 @@ getStatic fl fp' = do getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] getStaticRoute fp = do - Static fl <- getYesod + Static fl <- getYesodSub getStatic fl fp toStaticRoute :: [String] -> StaticRoutes From 2067d5d687e61137a4664ca87116c749a0637dde Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 9 May 2010 14:30:24 +0300 Subject: [PATCH 240/624] Added head to applyLayout(Json) --- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Helpers/EmailAuth.hs | 10 +++++----- Yesod/Yesod.hs | 12 +++++++----- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 763201c5..65c5e1d7 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -92,7 +92,7 @@ getOpenIdR = do (x:_) -> addCookie destCookieTimeout destCookieName x rtom <- getRouteToMaster let message = cs <$> (listToMaybe $ getParams rr "message") - applyLayout "Log in via OpenID" $ [$hamlet| + applyLayout "Log in via OpenID" (return ()) [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@ @@ -174,7 +174,7 @@ getCheck = do ident <- maybeIdentifier dn <- displayName let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) - applyLayoutJson "Authentication Status" arg html json + applyLayoutJson "Authentication Status" (return ()) arg html json where html (x, y) = [$hamlet| %h1 Authentication Status diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index 46c64066..dcbbde1c 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -69,7 +69,7 @@ mkYesodSub "EmailAuth" [''YesodEmailAuth] [$parseRoutes| getRegisterR :: Yesod master => GHandler EmailAuth master RepHtml getRegisterR = do toMaster <- getRouteToMaster - applyLayout "Register a new account" $ [$hamlet| + applyLayout "Register a new account" (return ()) [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.RegisterR@ %label!for=email E-mail @@ -93,7 +93,7 @@ postRegisterR = do tm <- getRouteToMaster let verUrl = render $ tm $ VerifyR lid verKey liftIO $ sendVerifyEmail y email verKey verUrl - applyLayout "Confirmation e-mail sent" $ [$hamlet| + applyLayout "Confirmation e-mail sent" (return ()) [$hamlet| %p A confirmation e-mail has been sent to $cs.email$. |] @@ -112,7 +112,7 @@ getVerifyR lid key = do setLoginSession email lid toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster PasswordR - _ -> applyLayout "Invalid verification key" $ [$hamlet| + _ -> applyLayout "Invalid verification key" (return ()) [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -132,7 +132,7 @@ getLoginR :: Yesod master => GHandler EmailAuth master RepHtml getLoginR = do toMaster <- getRouteToMaster msg <- getMessage - applyLayout "Login" $ [$hamlet| + applyLayout "Login" (return ()) [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account. @@ -182,7 +182,7 @@ getPasswordR = do setMessage "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR msg <- getMessage - applyLayout "Set password" [$hamlet| + applyLayout "Set password" (return ()) [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9a62c8b6..8ec5587d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -85,12 +85,13 @@ class YesodSite a => Yesod a where -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ head -> Hamlet (Routes master) IO () -- ^ body -> GHandler sub master RepHtml -applyLayout t b = +applyLayout t h b = RepHtml `fmap` defaultLayout PageContent { pageTitle = cs t - , pageHead = return () + , pageHead = h , pageBody = b } @@ -98,14 +99,15 @@ applyLayout t b = -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title + -> Hamlet (Routes master) IO () -- ^ head -> x -> (x -> Hamlet (Routes master) IO ()) -> (x -> Json (Routes master) ()) -> GHandler sub master RepHtmlJson -applyLayoutJson t x toH toJ = do +applyLayoutJson t h x toH toJ = do html <- defaultLayout PageContent { pageTitle = cs t - , pageHead = return () + , pageHead = h , pageBody = toH x } json <- jsonToContent $ toJ x @@ -115,7 +117,7 @@ applyLayout' :: Yesod master => String -- ^ title -> Hamlet (Routes master) IO () -- ^ body -> GHandler sub master ChooseRep -applyLayout' s = fmap chooseRep . applyLayout s +applyLayout' s = fmap chooseRep . applyLayout s (return ()) -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y From c3f236ce9cd1f9761fb544714e17c58ec919ffb6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 10 May 2010 16:33:05 +0300 Subject: [PATCH 241/624] Ultimate dest and messages --- Yesod/Handler.hs | 72 ++++++++++++++++++++++++++++++++++++++ Yesod/Helpers/EmailAuth.hs | 22 +++--------- Yesod/Request.hs | 7 ++++ 3 files changed, 84 insertions(+), 17 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f4921e7a..a9fb2325 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,14 @@ module Yesod.Handler -- * Session , setSession , clearSession + -- ** Ultimate destination + , setUltDest + , setUltDestString + , setUltDest' + , redirectUltDest + -- ** Messages + , setMessage + , getMessage -- * Internal Yesod , runHandler , YesodApp (..) @@ -83,6 +91,9 @@ import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W import Data.Convertible.Text (cs) +import Text.Hamlet +import Data.Text (Text) +import Web.Encodings (encodeHtml) data HandlerData sub master = HandlerData { handlerRequest :: Request @@ -255,6 +266,67 @@ redirectParams rt url params = do redirectString :: RedirectType -> String -> GHandler sub master a redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) +ultDestKey :: String +ultDestKey = "_ULT" + +-- | Sets the ultimate destination variable to the given route. +-- +-- An ultimate destination is stored in the user session and can be loaded +-- later by 'redirectUltDest'. +setUltDest :: Routes master -> GHandler sub master () +setUltDest dest = do + render <- getUrlRender + setUltDestString $ render dest + +-- | Same as 'setUltDest', but use the given string. +setUltDestString :: String -> GHandler sub master () +setUltDestString = setSession ultDestKey + +-- | Same as 'setUltDest', but uses the current page. +-- +-- If this is a 404 handler, there is no current page, and then this call does +-- nothing. +setUltDest' :: GHandler sub master () +setUltDest' = do + route <- getRoute + tm <- getRouteToMaster + maybe (return ()) setUltDest $ tm <$> route + +-- | Redirect to the ultimate destination in the user's session. Clear the +-- value from the session. +-- +-- The ultimate destination is set with 'setUltDest'. +redirectUltDest :: RedirectType + -> Routes master -- ^ default destination if nothing in session + -> GHandler sub master () +redirectUltDest rt def = do + mdest <- lookupSession ultDestKey + clearSession ultDestKey + maybe (redirect rt def) (redirectString rt) mdest + +msgKey :: String +msgKey = "_MSG" + +-- | Sets a message in the user's session. +-- +-- See 'getMessage'. +setMessage :: HtmlContent -> GHandler sub master () +setMessage = setSession msgKey . cs . htmlContentToText + +-- | Gets the message in the user's session, if available, and then clears the +-- variable. +-- +-- See 'setMessage'. +getMessage :: GHandler sub master (Maybe HtmlContent) +getMessage = do + clearSession msgKey + (fmap $ fmap $ Encoded . cs) $ lookupSession msgKey + +-- | FIXME move this definition into hamlet +htmlContentToText :: HtmlContent -> Text +htmlContentToText (Encoded t) = t +htmlContentToText (Unencoded t) = encodeHtml t + -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs index dcbbde1c..d0ec8825 100644 --- a/Yesod/Helpers/EmailAuth.hs +++ b/Yesod/Helpers/EmailAuth.hs @@ -116,18 +116,6 @@ getVerifyR lid key = do %p I'm sorry, but that was an invalid verification key. |] -messageKey :: String -messageKey = "MESSAGE" - -getMessage :: GHandler sub master (Maybe HtmlContent) -getMessage = do - s <- session - clearSession messageKey - return $ listToMaybe $ map (Encoded . cs) $ s messageKey - -setMessage :: String -> GHandler sub master () -setMessage = setSession messageKey . cs - getLoginR :: Yesod master => GHandler EmailAuth master RepHtml getLoginR = do toMaster <- getRouteToMaster @@ -170,7 +158,7 @@ postLoginR = do setLoginSession email lid redirect RedirectTemporary $ onSuccessfulLogin y Nothing -> do - setMessage "Invalid email/password combination" + setMessage $ cs "Invalid email/password combination" toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster LoginR @@ -179,7 +167,7 @@ getPasswordR = do l <- isJust <$> isLoggedIn toMaster <- getRouteToMaster unless l $ do - setMessage "You must be logged in to set a password" + setMessage $ cs "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR msg <- getMessage applyLayout "Set password" (return ()) [$hamlet| @@ -208,18 +196,18 @@ postPasswordR = do <*> notEmpty (required $ input "confirm") toMaster <- getRouteToMaster when (new /= confirm) $ do - setMessage "Passwords did not match, please try again" + setMessage $ cs "Passwords did not match, please try again" redirect RedirectTemporary $ toMaster PasswordR mlid <- isLoggedIn lid <- case mlid of Just lid -> return lid Nothing -> do - setMessage "You must be logged in to set a password" + setMessage $ cs "You must be logged in to set a password" redirect RedirectTemporary $ toMaster LoginR salted <- liftIO $ saltPass new y <- getYesod liftIO $ setPassword y lid salted - setMessage "Password updated" + setMessage $ cs "Password updated" redirect RedirectTemporary $ toMaster LoginR getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5d4feb18..3a96a633 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -28,6 +28,7 @@ module Yesod.Request , postParams , cookies , session + , lookupSession -- * Parameter type synonyms , ParamName , ParamValue @@ -113,3 +114,9 @@ session :: RequestReader m => m (ParamName -> [ParamValue]) session = do rr <- getRequest return $ multiLookup $ reqSession rr + +-- | Lookup for session data. +lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupSession pn = do + rr <- getRequest + return $ lookup pn $ reqSession rr From 9b03a86353dba76378fde47eab5d7ed618085645 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 10 May 2010 16:39:55 +0300 Subject: [PATCH 242/624] Migrated auth to ult dest --- Yesod/Helpers/Auth.hs | 88 ++++++++++--------------------------------- 1 file changed, 20 insertions(+), 68 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 65c5e1d7..1bc0ec75 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -27,9 +27,7 @@ module Yesod.Helpers.Auth , Auth (..) , AuthRoutes (..) , siteAuth - , LoginType (..) , YesodAuth (..) - , getAuth , identKey , displayNameKey ) where @@ -48,28 +46,18 @@ import Control.Applicative import Data.Typeable (Typeable) import Control.Exception (Exception) --- FIXME check referer header to determine destination - -getAuth :: a -> Auth -getAuth = const Auth - -data LoginType = OpenId | Rpxnow - class Yesod master => YesodAuth master where defaultDest :: master -> Routes master - liftAuthRoute :: master -> Routes Auth -> Routes master + defaultLoginRoute :: master -> Routes master onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () onRpxnowLogin _ = return () - rpxnowApiKey :: master -> Maybe String - rpxnowApiKey _ = Nothing - - defaultLoginType :: master -> LoginType - defaultLoginType _ = OpenId - data Auth = Auth + { authIsOpenIdEnabled :: Bool + , authRpxnowApiKey :: Maybe String + } $(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /check Check GET @@ -89,7 +77,7 @@ getOpenIdR = do rr <- getRequest case getParams rr "dest" of [] -> return () - (x:_) -> addCookie destCookieTimeout destCookieName x + (x:_) -> setUltDestString x rtom <- getRouteToMaster let message = cs <$> (listToMaybe $ getParams rr "message") applyLayout "Log in via OpenID" (return ()) [$hamlet| @@ -130,13 +118,14 @@ getOpenIdComplete = do let onSuccess (OpenId.Identifier ident) = do y <- getYesod setSession identKey ident - redirectToDest RedirectTemporary $ renderm $ defaultDest y + redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod - apiKey <- case rpxnowApiKey ay of + auth <- getYesodSub + apiKey <- case authRpxnowApiKey auth of Just x -> return x Nothing -> notFound rr <- getRequest @@ -144,19 +133,19 @@ handleRpxnowR = do let token = case getParams rr "token" ++ pp "token" of [] -> failure MissingToken (x:_) -> x - renderm <- getUrlRender - let dest = case pp "dest" of - [] -> case getParams rr "dest" of - [] -> renderm $ defaultDest ay - ("":_) -> renderm $ defaultDest ay - (('#':rest):_) -> rest - (s:_) -> s - (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token onRpxnowLogin ident setSession identKey $ Rpxnow.identifier ident setSession displayNameKey $ getDisplayName ident - redirectToDest RedirectTemporary dest + either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ + case pp "dest" of + (d:_) -> Right d + [] -> case getParams rr "dest" of + [] -> Left $ defaultDest ay + ("":_) -> Left $ defaultDest ay + (('#':rest):_) -> Right rest + (s:_) -> Right s + data MissingToken = MissingToken deriving (Show, Typeable) @@ -193,8 +182,7 @@ getLogout :: YesodAuth master => GHandler Auth master () getLogout = do y <- getYesod clearSession identKey - render <- getUrlRender - redirectToDest RedirectTemporary $ render $ defaultDest y + redirectUltDest RedirectTemporary $ defaultDest y -- | Gets the identifier for a user if available. maybeIdentifier :: RequestReader m => m (Maybe String) @@ -218,47 +206,11 @@ authIdentifier = maybeIdentifier >>= maybe redirectLogin return redirectLogin :: YesodAuth master => GHandler sub master a redirectLogin = do y <- getYesod - let r = case defaultLoginType y of - OpenId -> OpenIdR - Rpxnow -> RpxnowR -- FIXME this doesn't actually show a login page? - redirectSetDest RedirectTemporary $ liftAuthRoute y r - --- | Redirect to the given URL, and set a cookie with the current URL so the --- user will ultimately be sent back here. -redirectSetDest :: RedirectType - -> Routes master - -> GHandler sub master a -redirectSetDest rt dest = do - ur <- getUrlRender - tm <- getRouteToMaster - curr <- getRoute - let curr' = case curr of - Just x -> ur $ tm x - Nothing -> "/" -- should never happen anyway - 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 -> GHandler sub master a -redirectToDest rt def = do - rr <- getRequest - dest <- case cookies rr destCookieName of - [] -> return def - (x:_) -> do - deleteCookie destCookieName - return x - redirectString rt dest + setUltDest' + redirect RedirectTemporary $ defaultLoginRoute y identKey :: String identKey = "IDENTIFIER" displayNameKey :: String displayNameKey = "DISPLAY_NAME" - --- FIXME export DEST stuff as its own module -destCookieTimeout :: Int -destCookieTimeout = 120 - -destCookieName :: String -destCookieName = "DEST" From ad7a3330d540bfbaa0a489d38a195650ec3d8149 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 10 May 2010 20:29:51 +0300 Subject: [PATCH 243/624] Major Auth refactoring --- Yesod/Helpers/Auth.hs | 166 +++++++++++++++++++++++------------------- Yesod/Yesod.hs | 15 ++-- 2 files changed, 100 insertions(+), 81 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1bc0ec75..d7a2888c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -20,66 +20,100 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth - ( maybeIdentifier - , authIdentifier - , displayName - , redirectLogin + ( redirectLogin , Auth (..) , AuthRoutes (..) , siteAuth , YesodAuth (..) , identKey , displayNameKey + , Creds (..) + , maybeCreds + , requireCreds ) where -import Web.Encodings 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 Data.Maybe -import Control.Applicative - -import Data.Typeable (Typeable) -import Control.Exception (Exception) +import Control.Monad class Yesod master => YesodAuth master where + -- | Default destination on successful login or logout, if no other + -- destination exists. defaultDest :: master -> Routes master + -- | Default page to redirect user to for logging in. defaultLoginRoute :: master -> Routes master - onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () - onRpxnowLogin _ = return () + -- | Callback for a successful login. + -- + -- The second parameter can contain various information, depending on login + -- mechanism. + onLogin :: Creds -> [(String, String)] -> GHandler Auth master () + onLogin _ _ = return () data Auth = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String } -$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| +data AuthType = AuthOpenId | AuthRpxnow + deriving (Show, Read, Eq) + +-- | User credentials +data Creds = Creds + { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. + , credsAuthType :: AuthType -- ^ How the user was authenticated + , credsEmail :: Maybe String -- ^ Verified e-mail address. + , credsDisplayName :: Maybe String -- ^ Display name. + } + deriving (Show, Read, Eq) + +credsKey :: String +credsKey = "_CREDS" + +setCreds :: YesodAuth master + => Creds -> [(String, String)] -> GHandler Auth master () +setCreds creds extra = do + setSession credsKey $ show creds + onLogin creds extra + +maybeCreds :: GHandler sub master (Maybe Creds) +maybeCreds = do + mcs <- lookupSession credsKey + return $ mcs >>= readMay + where + readMay x = case reads x of + (y, _):_ -> Just y + _ -> Nothing + +mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET /openid/forward OpenIdForward GET /openid/complete OpenIdComplete GET /login/rpxnow RpxnowR -|]) +|] -data ExpectedSingleParam = ExpectedSingleParam - deriving (Show, Typeable) -instance Exception ExpectedSingleParam +testOpenId :: GHandler Auth master () +testOpenId = do + a <- getYesodSub + unless (authIsOpenIdEnabled a) notFound getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR = do + testOpenId rr <- getRequest case getParams rr "dest" of [] -> return () (x:_) -> setUltDestString x rtom <- getRouteToMaster - let message = cs <$> (listToMaybe $ getParams rr "message") + message <- getMessage applyLayout "Log in via OpenID" (return ()) [$hamlet| $maybe message msg %p.message $msg$ @@ -91,33 +125,35 @@ $maybe message msg getOpenIdForward :: GHandler Auth master () getOpenIdForward = do + testOpenId rr <- getRequest oid <- case getParams rr "openid" of [x] -> return x - _ -> invalidArgs [("openid", show ExpectedSingleParam)] + _ -> invalidArgs [("openid", "Expected single parameter")] render <- getUrlRender toMaster <- getRouteToMaster let complete = render $ toMaster OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt - (\err -> redirectParams RedirectTemporary (toMaster OpenIdR) - [("message", show err)]) + (\err -> do + setMessage $ cs $ show err + redirect RedirectTemporary $ toMaster OpenIdR) (redirectString RedirectTemporary) res getOpenIdComplete :: YesodAuth master => GHandler Auth master () getOpenIdComplete = do + testOpenId rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets' - renderm <- getUrlRender toMaster <- getRouteToMaster - let render = renderm . toMaster - let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err) - let onFailure err = redirectString RedirectTemporary $ errurl err + let onFailure err = do + setMessage $ cs $ show err + redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod - setSession identKey ident + setCreds (Creds ident AuthOpenId Nothing Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res @@ -131,12 +167,15 @@ handleRpxnowR = do rr <- getRequest pp <- postParams rr let token = case getParams rr "token" ++ pp "token" of - [] -> failure MissingToken + [] -> invalidArgs [("token", "Value not supplied")] (x:_) -> x - ident <- liftIO $ Rpxnow.authenticate apiKey token - onRpxnowLogin ident - setSession identKey $ Rpxnow.identifier ident - setSession displayNameKey $ getDisplayName ident + Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token + let creds = Creds + ident + AuthRpxnow + (lookup "verifiedEmail" extra) + (getDisplayName extra) + setCreds creds extra either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ case pp "dest" of (d:_) -> Right d @@ -146,61 +185,39 @@ handleRpxnowR = do (('#':rest):_) -> Right rest (s:_) -> Right s - -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 +-- | Get some form of a display name. +getDisplayName :: [(String, String)] -> Maybe String +getDisplayName extra = helper choices where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] - helper [] = ident - helper (x:xs) = fromMaybe (helper xs) $ lookup x extra + helper [] = Nothing + helper (x:xs) = maybe (helper xs) Just $ lookup x extra getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do - ident <- maybeIdentifier - dn <- displayName - let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn) - applyLayoutJson "Authentication Status" (return ()) arg html json + creds <- maybeCreds + applyLayoutJson "Authentication Status" + (return ()) (html creds) (json creds) where - html (x, y) = [$hamlet| + html creds = [$hamlet| %h1 Authentication Status -%dl - %dt identifier - %dd $x$ - %dt displayName - %dd $y$ +$if isNothing.creds + %p Not logged in +$maybe creds c + %p Logged in as $cs.credsIdent.c$ |] - json (ident, dn) = - jsonMap [ ("ident", jsonScalar ident) - , ("displayName", jsonScalar dn) - ] + json creds = + jsonMap + [ ("ident", jsonScalar $ maybe (cs "") (cs . credsIdent) creds) + , ("displayName", jsonScalar $ cs $ fromMaybe "" + $ creds >>= credsDisplayName) + ] getLogout :: YesodAuth master => GHandler Auth master () getLogout = do y <- getYesod - clearSession identKey + clearSession credsKey redirectUltDest RedirectTemporary $ defaultDest y --- | Gets the identifier for a user if available. -maybeIdentifier :: RequestReader m => m (Maybe String) -maybeIdentifier = do - s <- session - return $ listToMaybe $ s identKey - --- | Gets the display name for a user if available. -displayName :: RequestReader m => m (Maybe String) -displayName = do - s <- session - return $ listToMaybe $ s displayNameKey - --- | Gets the identifier for a user. If user is not logged in, redirects them --- to the login page. -authIdentifier :: YesodAuth master => GHandler sub master String -authIdentifier = maybeIdentifier >>= maybe redirectLogin return - -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie -- appropriately. redirectLogin :: YesodAuth master => GHandler sub master a @@ -209,6 +226,9 @@ redirectLogin = do setUltDest' redirect RedirectTemporary $ defaultLoginRoute y +requireCreds :: YesodAuth master => GHandler sub master Creds +requireCreds = maybeCreds >>= maybe redirectLogin return + identKey :: String identKey = "IDENTIFIER" diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 8ec5587d..4ebc4b46 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -100,18 +100,17 @@ applyLayout t h b = applyLayoutJson :: Yesod master => String -- ^ title -> Hamlet (Routes master) IO () -- ^ head - -> x - -> (x -> Hamlet (Routes master) IO ()) - -> (x -> Json (Routes master) ()) + -> Hamlet (Routes master) IO () -- ^ body + -> Json (Routes master) () -> GHandler sub master RepHtmlJson -applyLayoutJson t h x toH toJ = do - html <- defaultLayout PageContent +applyLayoutJson t h html json = do + html' <- defaultLayout PageContent { pageTitle = cs t , pageHead = h - , pageBody = toH x + , pageBody = html } - json <- jsonToContent $ toJ x - return $ RepHtmlJson html json + json' <- jsonToContent json + return $ RepHtmlJson html' json' applyLayout' :: Yesod master => String -- ^ title From e062033942e727766beb431e78e3506646aa245a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 11 May 2010 21:59:27 +0300 Subject: [PATCH 244/624] Merged EmailAuth into Auth --- Yesod/Helpers/Auth.hs | 246 +++++++++++++++++++++++++++++++++- Yesod/Helpers/EmailAuth.hs | 263 ------------------------------------- yesod.cabal | 1 - 3 files changed, 244 insertions(+), 266 deletions(-) delete mode 100644 Yesod/Helpers/EmailAuth.hs diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d7a2888c..326038fb 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -30,6 +30,8 @@ module Yesod.Helpers.Auth , Creds (..) , maybeCreds , requireCreds + , AuthEmailSettings (..) + , inMemoryEmailSettings ) where import qualified Web.Authenticate.Rpxnow as Rpxnow @@ -40,6 +42,11 @@ import Yesod import Control.Monad.Attempt import Data.Maybe import Control.Monad +import System.Random +import Data.Digest.Pure.MD5 +import Control.Applicative +import Control.Concurrent.MVar +import System.IO class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other @@ -56,20 +63,47 @@ class Yesod master => YesodAuth master where onLogin :: Creds -> [(String, String)] -> GHandler Auth master () onLogin _ _ = return () + -- | Generate a random alphanumeric string. + -- + -- This is used for verify string in email authentication. + randomKey :: master -> IO String + randomKey _ = do + stdgen <- newStdGen + return $ take 10 $ randomRs ('A', 'Z') stdgen + data Auth = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String + , authEmailSettings :: Maybe AuthEmailSettings } -data AuthType = AuthOpenId | AuthRpxnow +data AuthType = AuthOpenId | AuthRpxnow | AuthEmail deriving (Show, Read, Eq) +type Email = String +type VerKey = String +type VerUrl = String +type EmailId = Integer +type SaltedPass = String +type VerStatus = Bool +data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey +data AuthEmailSettings = AuthEmailSettings + { addUnverified :: Email -> VerKey -> IO EmailId + , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () + , getVerifyKey :: EmailId -> IO (Maybe VerKey) + , verifyAccount :: EmailId -> IO () + , setPassword :: EmailId -> String -> IO () + , getEmailCreds :: Email -> IO (Maybe EmailCreds) + , getEmail :: EmailId -> IO (Maybe Email) + } + -- | User credentials data Creds = Creds { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. , credsAuthType :: AuthType -- ^ How the user was authenticated , credsEmail :: Maybe String -- ^ Verified e-mail address. , credsDisplayName :: Maybe String -- ^ Display name. + , credsId :: Maybe Integer -- ^ Numeric ID, if used. } deriving (Show, Read, Eq) @@ -98,6 +132,11 @@ mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| /openid/forward OpenIdForward GET /openid/complete OpenIdComplete GET /login/rpxnow RpxnowR + +/register EmailRegisterR GET POST +/verify/#/$ EmailVerifyR GET +/login EmailLoginR GET POST +/set-password EmailPasswordR GET POST |] testOpenId :: GHandler Auth master () @@ -153,7 +192,7 @@ getOpenIdComplete = do redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod - setCreds (Creds ident AuthOpenId Nothing Nothing) [] + setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res @@ -175,6 +214,7 @@ handleRpxnowR = do AuthRpxnow (lookup "verifiedEmail" extra) (getDisplayName extra) + Nothing setCreds creds extra either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ case pp "dest" of @@ -234,3 +274,205 @@ identKey = "IDENTIFIER" displayNameKey :: String displayNameKey = "DISPLAY_NAME" + +getAuthEmailSettings :: GHandler Auth master AuthEmailSettings +getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings + +getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml +getEmailRegisterR = do + _ae <- getAuthEmailSettings + toMaster <- getRouteToMaster + applyLayout "Register a new account" (return ()) [$hamlet| +%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. +%form!method=post!action=@toMaster.EmailRegisterR@ + %label!for=email E-mail + %input#email!type=email!name=email!width=150 + %input!type=submit!value=Register +|] + +postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml +postEmailRegisterR = do + ae <- getAuthEmailSettings + email <- runFormPost $ checkEmail $ required $ input "email" + y <- getYesod + mecreds <- liftIO $ getEmailCreds ae email + (lid, verKey) <- + case mecreds of + Nothing -> liftIO $ do + key <- randomKey y + lid <- addUnverified ae email key + return (lid, key) + Just (EmailCreds lid _ _ key) -> return (lid, key) + render <- getUrlRender + tm <- getRouteToMaster + let verUrl = render $ tm $ EmailVerifyR lid verKey + liftIO $ sendVerifyEmail ae email verKey verUrl + applyLayout "Confirmation e-mail sent" (return ()) [$hamlet| +%p A confirmation e-mail has been sent to $cs.email$. +|] + +checkEmail :: Form ParamValue -> Form ParamValue +checkEmail = notEmpty -- FIXME + +getEmailVerifyR :: YesodAuth master + => Integer -> String -> GHandler Auth master RepHtml +getEmailVerifyR lid key = do + ae <- getAuthEmailSettings + realKey <- liftIO $ getVerifyKey ae lid + memail <- liftIO $ getEmail ae lid + case (realKey == Just key, memail) of + (True, Just email) -> do + liftIO $ verifyAccount ae lid + setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster EmailPasswordR + _ -> applyLayout "Invalid verification key" (return ()) [$hamlet| +%p I'm sorry, but that was an invalid verification key. + |] + +getEmailLoginR :: Yesod master => GHandler Auth master RepHtml +getEmailLoginR = do + _ae <- getAuthEmailSettings + toMaster <- getRouteToMaster + msg <- getMessage + applyLayout "Login" (return ()) [$hamlet| +$maybe msg ms + %p.message $ms$ +%p Please log in to your account. +%p + %a!href=@toMaster.EmailRegisterR@ I don't have an account +%form!method=post!action=@toMaster.EmailLoginR@ + %table + %tr + %th E-mail + %td + %input!type=email!name=email + %tr + %th Password + %td + %input!type=password!name=password + %tr + %td!colspan=2 + %input!type=submit!value=Login +|] + +postEmailLoginR :: YesodAuth master => GHandler Auth master () +postEmailLoginR = do + ae <- getAuthEmailSettings + (email, pass) <- runFormPost $ (,) + <$> checkEmail (required $ input "email") + <*> required (input "password") + y <- getYesod + mecreds <- liftIO $ getEmailCreds ae email + let mlid = + case mecreds of + Just (EmailCreds lid (Just realpass) True _) -> + if isValidPass pass realpass then Just lid else Nothing + _ -> Nothing + case mlid of + Just lid -> do + setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] + redirectUltDest RedirectTemporary $ defaultDest y + Nothing -> do + setMessage $ cs "Invalid email/password combination" + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster EmailLoginR + +getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml +getEmailPasswordR = do + _ae <- getAuthEmailSettings + toMaster <- getRouteToMaster + mcreds <- maybeCreds + case mcreds of + Just (Creds _ AuthEmail _ _ (Just _)) -> return () + _ -> do + setMessage $ cs "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster EmailLoginR + msg <- getMessage + applyLayout "Set password" (return ()) [$hamlet| +$maybe msg ms + %p.message $ms$ +%h3 Set a new password +%form!method=post!action=@toMaster.EmailPasswordR@ + %table + %tr + %th New password + %td + %input!type=password!name=new + %tr + %th Confirm + %td + %input!type=password!name=confirm + %tr + %td!colspan=2 + %input!type=submit!value=Submit +|] + +postEmailPasswordR :: YesodAuth master => GHandler Auth master () +postEmailPasswordR = do + ae <- getAuthEmailSettings + (new, confirm) <- runFormPost $ (,) + <$> notEmpty (required $ input "new") + <*> notEmpty (required $ input "confirm") + toMaster <- getRouteToMaster + when (new /= confirm) $ do + setMessage $ cs "Passwords did not match, please try again" + redirect RedirectTemporary $ toMaster EmailPasswordR + mcreds <- maybeCreds + lid <- case mcreds of + Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid + _ -> do + setMessage $ cs "You must be logged in to set a password" + redirect RedirectTemporary $ toMaster EmailLoginR + salted <- liftIO $ saltPass new + liftIO $ setPassword ae lid salted + setMessage $ cs "Password updated" + redirect RedirectTemporary $ toMaster EmailLoginR + +saltLength :: Int +saltLength = 5 + +isValidPass :: String -- ^ cleartext password + -> String -- ^ salted password + -> Bool +isValidPass clear salted = + let salt = take saltLength salted + in salted == saltPass' salt clear + +saltPass :: String -> IO String +saltPass pass = do + stdgen <- newStdGen + let salt = take saltLength $ randomRs ('A', 'Z') stdgen + return $ saltPass' salt pass + +saltPass' :: String -> String -> String -- FIXME better salting scheme? +saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) + +inMemoryEmailSettings :: IO AuthEmailSettings +inMemoryEmailSettings = do + mm <- newMVar [] + return $ AuthEmailSettings + { addUnverified = \email verkey -> modifyMVar mm $ \m -> do + let helper (_, EmailCreds x _ _ _) = x + let newId = 1 + maximum (0 : map helper m) + let ec = EmailCreds newId Nothing False verkey + return ((email, ec) : m, newId) + , sendVerifyEmail = \_email _verkey verurl -> + hPutStrLn stderr $ "Please go to: " ++ verurl + , getVerifyKey = \eid -> withMVar mm $ \m -> return $ + lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m + , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid) + , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass) + , getEmailCreds = \email -> withMVar mm $ return . lookup email + , getEmail = \eid -> withMVar mm $ \m -> return $ + case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of + ((email, _):_) -> Just email + _ -> Nothing + } + where + vago eid (email, EmailCreds eid' pass status key) + | eid == eid' = (email, EmailCreds eid pass True key) + | otherwise = (email, EmailCreds eid' pass status key) + spgo eid pass (email, EmailCreds eid' pass' status key) + | eid == eid' = (email, EmailCreds eid (Just pass) status key) + | otherwise = (email, EmailCreds eid' pass' status key) diff --git a/Yesod/Helpers/EmailAuth.hs b/Yesod/Helpers/EmailAuth.hs deleted file mode 100644 index d0ec8825..00000000 --- a/Yesod/Helpers/EmailAuth.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -module Yesod.Helpers.EmailAuth - ( getEmailAuth - , EmailAuth - , siteEmailAuth - , EmailAuthRoutes (..) - , YesodEmailAuth (..) - ) where - -import Yesod -import Yesod.Helpers.Auth -import System.Random -import Data.Maybe -import Control.Applicative -import Control.Monad -import Data.Digest.Pure.MD5 - -class Yesod y => YesodEmailAuth y where - addUnverified :: y - -> String -- ^ email - -> String -- ^ verification key - -> IO Integer -- ^ login_id - sendVerifyEmail :: y - -> String -- ^ email - -> String -- ^ verification key - -> String -- ^ verify URL - -> IO () - getVerifyKey :: y - -> Integer -- ^ login_id - -> IO (Maybe String) - verifyAccount :: y - -> Integer -- ^ login_id - -> IO () - setPassword :: y - -> Integer -- ^ login_id - -> String -- ^ salted password - -> IO () - getCreds :: y - -> String -- ^ email address - -> IO (Maybe (Integer, Maybe String, Bool, String)) -- ^ id, salted pass, is verified, verify key - getEmail :: y -> Integer -> IO (Maybe String) - - randomKey :: y -> IO String - randomKey _ = do - stdgen <- newStdGen - return $ take 10 $ randomRs ('A', 'Z') stdgen - - onSuccessfulLogin :: y -> Routes y - onSuccessfulLogout :: y -> Routes y - - onEmailAuthLogin :: y - -> String -- ^ email - -> Integer -- ^ login_id - -> IO () - -data EmailAuth = EmailAuth - -getEmailAuth :: a -> EmailAuth -getEmailAuth _ = EmailAuth - -mkYesodSub "EmailAuth" [''YesodEmailAuth] [$parseRoutes| -/register RegisterR GET POST -/verify/#/$ VerifyR GET -/login LoginR GET POST -/set-password PasswordR GET POST -/logout LogoutR GET -|] - -getRegisterR :: Yesod master => GHandler EmailAuth master RepHtml -getRegisterR = do - toMaster <- getRouteToMaster - applyLayout "Register a new account" (return ()) [$hamlet| -%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. -%form!method=post!action=@toMaster.RegisterR@ - %label!for=email E-mail - %input#email!type=email!name=email!width=150 - %input!type=submit!value=Register -|] - -postRegisterR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml -postRegisterR = do - email <- runFormPost $ checkEmail $ required $ input "email" - y <- getYesod - creds <- liftIO $ getCreds y email - (lid, verKey) <- - case creds of - Nothing -> liftIO $ do - key <- randomKey y - lid <- addUnverified y email key - return (lid, key) - Just (lid, _, _, key) -> return (lid, key) - render <- getUrlRender - tm <- getRouteToMaster - let verUrl = render $ tm $ VerifyR lid verKey - liftIO $ sendVerifyEmail y email verKey verUrl - applyLayout "Confirmation e-mail sent" (return ()) [$hamlet| -%p A confirmation e-mail has been sent to $cs.email$. -|] - -checkEmail :: Form ParamValue -> Form ParamValue -checkEmail = notEmpty -- FIXME - -getVerifyR :: YesodEmailAuth master - => Integer -> String -> GHandler EmailAuth master RepHtml -getVerifyR lid key = do - y <- getYesod - realKey <- liftIO $ getVerifyKey y lid - memail <- liftIO $ getEmail y lid - case (realKey == Just key, memail) of - (True, Just email) -> do - liftIO $ verifyAccount y lid - setLoginSession email lid - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster PasswordR - _ -> applyLayout "Invalid verification key" (return ()) [$hamlet| -%p I'm sorry, but that was an invalid verification key. - |] - -getLoginR :: Yesod master => GHandler EmailAuth master RepHtml -getLoginR = do - toMaster <- getRouteToMaster - msg <- getMessage - applyLayout "Login" (return ()) [$hamlet| -$maybe msg ms - %p.message $ms$ -%p Please log in to your account. -%p - %a!href=@toMaster.RegisterR@ I don't have an account -%form!method=post!action=@toMaster.LoginR@ - %table - %tr - %th E-mail - %td - %input!type=email!name=email - %tr - %th Password - %td - %input!type=password!name=password - %tr - %td!colspan=2 - %input!type=submit!value=Login -|] - -postLoginR :: YesodEmailAuth master => GHandler EmailAuth master () -postLoginR = do - (email, pass) <- runFormPost $ (,) - <$> checkEmail (required $ input "email") - <*> required (input "password") - y <- getYesod - creds <- liftIO $ getCreds y email - let mlid = - case creds of - Just (lid, Just realpass, True, _) -> - if isValidPass pass realpass then Just lid else Nothing - _ -> Nothing - case mlid of - Just lid -> do - setLoginSession email lid - redirect RedirectTemporary $ onSuccessfulLogin y - Nothing -> do - setMessage $ cs "Invalid email/password combination" - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster LoginR - -getPasswordR :: Yesod master => GHandler EmailAuth master RepHtml -getPasswordR = do - l <- isJust <$> isLoggedIn - toMaster <- getRouteToMaster - unless l $ do - setMessage $ cs "You must be logged in to set a password" - redirect RedirectTemporary $ toMaster LoginR - msg <- getMessage - applyLayout "Set password" (return ()) [$hamlet| -$maybe msg ms - %p.message $ms$ -%h3 Set a new password -%form!method=post!action=@toMaster.PasswordR@ - %table - %tr - %th New password - %td - %input!type=password!name=new - %tr - %th Confirm - %td - %input!type=password!name=confirm - %tr - %td!colspan=2 - %input!type=submit!value=Submit -|] - -postPasswordR :: YesodEmailAuth master => GHandler EmailAuth master () -postPasswordR = do - (new, confirm) <- runFormPost $ (,) - <$> notEmpty (required $ input "new") - <*> notEmpty (required $ input "confirm") - toMaster <- getRouteToMaster - when (new /= confirm) $ do - setMessage $ cs "Passwords did not match, please try again" - redirect RedirectTemporary $ toMaster PasswordR - mlid <- isLoggedIn - lid <- case mlid of - Just lid -> return lid - Nothing -> do - setMessage $ cs "You must be logged in to set a password" - redirect RedirectTemporary $ toMaster LoginR - salted <- liftIO $ saltPass new - y <- getYesod - liftIO $ setPassword y lid salted - setMessage $ cs "Password updated" - redirect RedirectTemporary $ toMaster LoginR - -getLogoutR :: YesodEmailAuth master => GHandler EmailAuth master RepHtml -getLogoutR = do - clearSession identKey - clearSession displayNameKey - clearSession emailAuthIdKey - y <- getYesod - redirect RedirectTemporary $ onSuccessfulLogout y - -saltLength :: Int -saltLength = 5 - -isValidPass :: String -- ^ cleartext password - -> String -- ^ salted password - -> Bool -isValidPass clear salted = - let salt = take saltLength salted - in salted == saltPass' salt clear - -saltPass :: String -> IO String -saltPass pass = do - stdgen <- newStdGen - let salt = take saltLength $ randomRs ('A', 'Z') stdgen - return $ saltPass' salt pass - -saltPass' :: String -> String -> String -- FIXME better salting scheme? -saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) - -emailAuthIdKey :: String -emailAuthIdKey = "EMAIL_AUTH_ID" - -setLoginSession :: YesodEmailAuth master - => String -> Integer -> GHandler sub master () -setLoginSession email lid = do - setSession identKey email - setSession displayNameKey email - setSession emailAuthIdKey $ show lid - y <- getYesod - liftIO $ onEmailAuthLogin y email lid - -isLoggedIn :: GHandler sub master (Maybe Integer) -isLoggedIn = do - s <- session - return $ - if null (s identKey) - then Nothing - else listToMaybe (s emailAuthIdKey) >>= readMay - -readMay :: String -> Maybe Integer -readMay s = case reads s of - [] -> Nothing - ((i, _):_) -> Just i diff --git a/yesod.cabal b/yesod.cabal index eae3bc17..28170733 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,6 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static - Yesod.Helpers.EmailAuth Web.Mime ghc-options: -Wall From d385fc48d154c312f92c3d011b9ad9865577b6ff Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 11 May 2010 23:14:33 +0300 Subject: [PATCH 245/624] Cleaned up helpers + docs --- Yesod/Helpers/AtomFeed.hs | 2 ++ Yesod/Helpers/Auth.hs | 48 +++++++++++++++++++--------------- Yesod/Helpers/Sitemap.hs | 5 ++++ Yesod/Helpers/Static.hs | 55 ++++++++++++++++----------------------- 4 files changed, 57 insertions(+), 53 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 4bcd6b0f..bb5a7574 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -13,6 +13,8 @@ -- --------------------------------------------------------- +-- | Generation of Atom newsfeeds. See +-- <http://en.wikipedia.org/wiki/Atom_(standard)>. module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 326038fb..1f8a4271 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -20,18 +20,19 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth - ( redirectLogin - , Auth (..) + ( -- * Subsite + Auth (..) , AuthRoutes (..) , siteAuth + -- * Settings , YesodAuth (..) - , identKey - , displayNameKey , Creds (..) - , maybeCreds - , requireCreds + , AuthType (..) , AuthEmailSettings (..) , inMemoryEmailSettings + -- * Functions + , maybeCreds + , requireCreds ) where import qualified Web.Authenticate.Rpxnow as Rpxnow @@ -71,12 +72,16 @@ class Yesod master => YesodAuth master where stdgen <- newStdGen return $ take 10 $ randomRs ('A', 'Z') stdgen +-- | Each authentication subsystem (OpenId, Rpxnow, Email) has its own +-- settings. If those settings are not present, then relevant handlers will +-- simply return a 404. data Auth = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String , authEmailSettings :: Maybe AuthEmailSettings } +-- | Which subsystem authenticated the user. data AuthType = AuthOpenId | AuthRpxnow | AuthEmail deriving (Show, Read, Eq) @@ -86,7 +91,12 @@ type VerUrl = String type EmailId = Integer type SaltedPass = String type VerStatus = Bool + +-- | Data stored in a database for each e-mail address. data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey + +-- | For a sample set of settings for a trivial in-memory database, see +-- 'inMemoryEmailSettings'. data AuthEmailSettings = AuthEmailSettings { addUnverified :: Email -> VerKey -> IO EmailId , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () @@ -116,6 +126,7 @@ setCreds creds extra = do setSession credsKey $ show creds onLogin creds extra +-- | Retrieves user credentials, if user is authenticated. maybeCreds :: GHandler sub master (Maybe Creds) maybeCreds = do mcs <- lookupSession credsKey @@ -258,22 +269,17 @@ getLogout = do clearSession credsKey redirectUltDest RedirectTemporary $ defaultDest y --- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie --- appropriately. -redirectLogin :: YesodAuth master => GHandler sub master a -redirectLogin = do - y <- getYesod - setUltDest' - redirect RedirectTemporary $ defaultLoginRoute y - +-- | Retrieve user credentials. If user is not logged in, redirects to the +-- 'defaultLoginRoute'. Sets ultimate destination to current route, so user +-- should be sent back here after authenticating. requireCreds :: YesodAuth master => GHandler sub master Creds -requireCreds = maybeCreds >>= maybe redirectLogin return - -identKey :: String -identKey = "IDENTIFIER" - -displayNameKey :: String -displayNameKey = "DISPLAY_NAME" +requireCreds = + maybeCreds >>= maybe redirectLogin return + where + redirectLogin = do + y <- getYesod + setUltDest' + redirect RedirectTemporary $ defaultLoginRoute y getAuthEmailSettings :: GHandler Auth master AuthEmailSettings getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 3c150abc..9543c733 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -13,6 +13,9 @@ -- --------------------------------------------------------- +-- | Generates XML sitemap files. +-- +-- See <http://www.sitemaps.org/>. module Yesod.Helpers.Sitemap ( sitemap , robots @@ -31,6 +34,7 @@ data SitemapChangeFreq = Always | Monthly | Yearly | Never + showFreq :: SitemapChangeFreq -> String showFreq Always = "always" showFreq Hourly = "hourly" @@ -64,6 +68,7 @@ template urls = [$hamlet| sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml sitemap = fmap RepXml . hamletToContent . template +-- | A basic robots file which just lists the "Sitemap: " line. robots :: Routes sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 1e133f5f..117dc9e6 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -11,20 +11,23 @@ -- Stability : Unstable -- Portability : portable -- --- Serve static files from a Yesod app. + +-- | 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. -- ---------------------------------------------------------- +-- In fact, in an ideal setup you'll serve your static files from a separate +-- domain name to save time on transmitting cookies. In that case, you may wish +-- to use 'urlRenderOverride' to redirect requests to this subsite to a +-- separate domain name. module Yesod.Helpers.Static - ( FileLookup - , fileLookupDir + ( -- * Subsite + Static (..) + , StaticRoutes (..) , siteStatic - , StaticRoutes - , toStaticRoute - , staticArgs - , Static + -- * Lookup files in filesystem + , fileLookupDir ) where import System.Directory (doesFileExist) @@ -32,25 +35,21 @@ import Control.Monad import Yesod import Data.List (intercalate) -import Network.Wai -type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) - -data Static = Static FileLookup - -staticArgs :: FileLookup -> Static -staticArgs = Static +-- | A function for looking up file contents. For serving from the file system, +-- see 'fileLookupDir'. +data Static = Static (FilePath -> IO (Maybe (Either FilePath Content))) $(mkYesodSub "Static" [] [$parseRoutes| /* StaticRoute GET |]) --- | 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. +-- | Lookup files in a specific directory. -- --- If you are just using this in combination with serveStatic, serveStatic --- provides this checking. +-- If you are just using this in combination with the static subsite (you +-- probably are), the handler itself checks that no unsafe paths are being +-- requested. In particular, no path segments may begin with a single period, +-- so hidden files and parent directories are safe. fileLookupDir :: FilePath -> Static fileLookupDir dir = Static $ \fp -> do let fp' = dir ++ '/' : fp @@ -59,11 +58,11 @@ fileLookupDir dir = Static $ \fp -> do then return $ Just $ Left fp' else return Nothing -getStatic :: FileLookup -> [String] -> GHandler sub master [(ContentType, Content)] -getStatic fl fp' = do +getStaticRoute :: [String] + -> GHandler Static master [(ContentType, Content)] +getStaticRoute fp' = do + Static fl <- getYesodSub when (any isUnsafe fp') notFound - wai <- waiRequest - when (requestMethod wai /= GET) badMethod let fp = intercalate "/" fp' content <- liftIO $ fl fp case content of @@ -74,11 +73,3 @@ getStatic fl fp' = do isUnsafe [] = True isUnsafe ('.':_) = True isUnsafe _ = False - -getStaticRoute :: [String] -> GHandler Static master [(ContentType, Content)] -getStaticRoute fp = do - Static fl <- getYesodSub - getStatic fl fp - -toStaticRoute :: [String] -> StaticRoutes -toStaticRoute = StaticRoute From cda45d28374702d3e62c471cab5d78dd1394e5d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 11 May 2010 23:23:07 +0300 Subject: [PATCH 246/624] Removed Web.Mime --- Web/Mime.hs | 122 ---------------------------------------------- Yesod.hs | 6 +-- Yesod/Content.hs | 118 +++++++++++++++++++++++++++++++++++++++++++- Yesod/Dispatch.hs | 1 - Yesod/Handler.hs | 1 - Yesod/Json.hs | 4 +- runtests.hs | 4 +- yesod.cabal | 1 - 8 files changed, 124 insertions(+), 133 deletions(-) delete mode 100644 Web/Mime.hs diff --git a/Web/Mime.hs b/Web/Mime.hs deleted file mode 100644 index d774e32c..00000000 --- a/Web/Mime.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} --- | Generic MIME type module. Could be spun off into its own package. -module Web.Mime - ( -- * Data type and conversions - ContentType (..) - , contentTypeFromString - , contentTypeToString - -- * File extensions - , typeByExt - , ext - -- * Utilities - , simpleContentType -#if TEST - , testSuite -#endif - ) where - -import Data.Function (on) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - --- | Equality is determined by converting to a 'String' via --- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the --- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not* --- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8 --- encoded. See 'contentTypeToString'. -data ContentType = - TypeHtml - | TypePlain - | TypeJson - | TypeXml - | TypeAtom - | TypeJpeg - | TypePng - | TypeGif - | TypeJavascript - | TypeCss - | TypeFlv - | TypeOgv - | TypeOctet - | TypeOther String - deriving (Show) - --- | This is simply a synonym for 'TypeOther'. However, equality works as --- expected; see 'ContentType'. -contentTypeFromString :: String -> ContentType -contentTypeFromString = TypeOther - --- | This works as expected, with one caveat: the builtin textual content types --- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of --- their basic content-type. If another encoding is desired, please use --- 'TypeOther'. -contentTypeToString :: ContentType -> String -contentTypeToString TypeHtml = "text/html; charset=utf-8" -contentTypeToString TypePlain = "text/plain; charset=utf-8" -contentTypeToString TypeJson = "application/json; charset=utf-8" -contentTypeToString TypeXml = "text/xml" -contentTypeToString TypeAtom = "application/atom+xml" -contentTypeToString TypeJpeg = "image/jpeg" -contentTypeToString TypePng = "image/png" -contentTypeToString TypeGif = "image/gif" -contentTypeToString TypeJavascript = "text/javascript; charset=utf-8" -contentTypeToString TypeCss = "text/css; charset=utf-8" -contentTypeToString TypeFlv = "video/x-flv" -contentTypeToString TypeOgv = "video/ogg" -contentTypeToString TypeOctet = "application/octet-stream" -contentTypeToString (TypeOther s) = s - --- | Removes \"extra\" information at the end of a content type string. In --- particular, removes everything after the semicolon, if present. --- --- For example, \"text/html; charset=utf-8\" is commonly used to specify the --- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: String -> String -simpleContentType = fst . span (/= ';') - -instance Eq ContentType where - (==) = (==) `on` contentTypeToString - --- | 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 diff --git a/Yesod.hs b/Yesod.hs index 1e9ecb3e..73e5f2d2 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -8,7 +8,6 @@ module Yesod , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Form - , module Web.Mime , module Yesod.Hamlet , module Yesod.Json , Application @@ -18,14 +17,13 @@ module Yesod ) where #if TEST -import Web.Mime hiding (testSuite) +import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) #else -import Web.Mime +import Yesod.Content import Yesod.Json #endif -import Yesod.Content import Yesod.Request import Yesod.Dispatch import Yesod.Form diff --git a/Yesod/Content.hs b/Yesod/Content.hs index dfafc456..c622db4b 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -4,11 +4,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} module Yesod.Content ( -- * Content Content (..) , toContent + -- * Mime types + -- ** Data type + , ContentType (..) + , contentTypeFromString + , contentTypeToString + -- ** File extensions + , typeByExt + , ext + -- * Utilities + , simpleContentType -- * Representations , ChooseRep , HasReps (..) @@ -19,6 +30,9 @@ module Yesod.Content , RepHtmlJson (..) , RepPlain (..) , RepXml (..) +#if TEST + , testSuite +#endif ) where import Data.Maybe (mapMaybe) @@ -31,7 +45,14 @@ import Data.Convertible.Text import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import Web.Mime +import Data.Function (on) + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit hiding (Test) +#endif -- | There are two different methods available for providing content in the -- response: via files and enumerators. The former allows server to use @@ -129,3 +150,98 @@ instance HasReps RepPlain where newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (TypeXml, c) + +-- | Equality is determined by converting to a 'String' via +-- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the +-- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not* +-- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8 +-- encoded. See 'contentTypeToString'. +data ContentType = + TypeHtml + | TypePlain + | TypeJson + | TypeXml + | TypeAtom + | TypeJpeg + | TypePng + | TypeGif + | TypeJavascript + | TypeCss + | TypeFlv + | TypeOgv + | TypeOctet + | TypeOther String + deriving (Show) + +-- | This is simply a synonym for 'TypeOther'. However, equality works as +-- expected; see 'ContentType'. +contentTypeFromString :: String -> ContentType +contentTypeFromString = TypeOther + +-- | This works as expected, with one caveat: the builtin textual content types +-- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of +-- their basic content-type. If another encoding is desired, please use +-- 'TypeOther'. +contentTypeToString :: ContentType -> String +contentTypeToString TypeHtml = "text/html; charset=utf-8" +contentTypeToString TypePlain = "text/plain; charset=utf-8" +contentTypeToString TypeJson = "application/json; charset=utf-8" +contentTypeToString TypeXml = "text/xml" +contentTypeToString TypeAtom = "application/atom+xml" +contentTypeToString TypeJpeg = "image/jpeg" +contentTypeToString TypePng = "image/png" +contentTypeToString TypeGif = "image/gif" +contentTypeToString TypeJavascript = "text/javascript; charset=utf-8" +contentTypeToString TypeCss = "text/css; charset=utf-8" +contentTypeToString TypeFlv = "video/x-flv" +contentTypeToString TypeOgv = "video/ogg" +contentTypeToString TypeOctet = "application/octet-stream" +contentTypeToString (TypeOther s) = s + +-- | Removes \"extra\" information at the end of a content type string. In +-- particular, removes everything after the semicolon, if present. +-- +-- For example, \"text/html; charset=utf-8\" is commonly used to specify the +-- character encoding for HTML data. This function would return \"text/html\". +simpleContentType :: String -> String +simpleContentType = fst . span (/= ';') + +instance Eq ContentType where + (==) = (==) `on` contentTypeToString + +-- | 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 diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index eaf56ab8..dc0cb422 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -35,7 +35,6 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B import Web.Encodings -import Web.Mime import Data.List (intercalate) import Web.Routes (encodePathInfo, decodePathInfo) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a9fb2325..97a37d49 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -67,7 +67,6 @@ import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal -import Web.Mime import Web.Routes.Quasi (Routes) import Data.List (foldl') import Web.Encodings (encodeUrlPairs) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 44b56fc5..71894f44 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -25,7 +25,6 @@ import Web.Encodings import Yesod.Hamlet import Control.Monad (when) import Yesod.Handler -import Yesod.Content import Web.Routes.Quasi (Routes) #if TEST @@ -33,6 +32,9 @@ import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) import Data.Text.Lazy (unpack) +import Yesod.Content hiding (testSuite) +#else +import Yesod.Content #endif -- | A monad for generating Json output. In truth, it is just a newtype wrapper diff --git a/runtests.hs b/runtests.hs index 94e448e5..59000fc0 100644 --- a/runtests.hs +++ b/runtests.hs @@ -1,10 +1,10 @@ import Test.Framework (defaultMain) -import qualified Web.Mime +import qualified Yesod.Content import qualified Yesod.Json main :: IO () main = defaultMain - [ Web.Mime.testSuite + [ Yesod.Content.testSuite , Yesod.Json.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index 28170733..72b7720c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,6 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static - Web.Mime ghc-options: -Wall executable runtests From 6376157c6445c0e72212a72156408d66fa542573 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 11 May 2010 23:47:05 +0300 Subject: [PATCH 247/624] Various minor changes, better description --- Yesod/Dispatch.hs | 13 +++++++++---- Yesod/Hamlet.hs | 8 +------- Yesod/Request.hs | 39 ++++++++++++++++++++++++++++++++++++++- yesod.cabal | 18 ++++++++++++++++-- 4 files changed, 64 insertions(+), 14 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index dc0cb422..4ad8b123 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -50,7 +50,7 @@ import Web.ClientSession -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. --- Use 'parseRoutes' in generate to create the 'Resource's. +-- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec] @@ -58,8 +58,8 @@ mkYesod name = mkYesodGeneral name [] False -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. --- Use 'parseRoutes' in generate to create the 'Resource's. In general, a --- subsite is not executable by itself, but instead provides functionality to +-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not +-- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype -> [Name] -- ^ a list of classes the master datatype must be an instance of @@ -172,7 +172,12 @@ toWaiApp' y resource env = do ContentEnum e -> Right $ W.buffer $ W.Enumerator e --- | Fully render a route to an absolute URL. +-- | Fully render a route to an absolute URL. Since Yesod does this for you +-- internally, you will rarely need access to this. However, if you need to +-- generate links *outside* of the Handler monad, this may be useful. +-- +-- For example, if you want to generate an e-mail which links to your site, +-- this is the function you would want to use. fullRender :: String -- ^ approot, no trailing slash -> QuasiSite YesodApp arg arg -> Routes arg diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index f11bd3ba..0f8adfbe 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -19,17 +19,11 @@ module Yesod.Hamlet where import Text.Hamlet -import Text.Hamlet.Monad (outputHtml) +import Text.Hamlet.Monad (outputHtml, htmlContentToText) import Yesod.Content import Yesod.Handler import Data.Convertible.Text import Web.Routes.Quasi (Routes) -import Data.Text (Text) -import Web.Encodings (encodeHtml) - -htmlContentToText :: HtmlContent -> Text -htmlContentToText (Encoded t) = t -htmlContentToText (Unencoded t) = encodeHtml t -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 3a96a633..3a7c918c 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -24,11 +24,15 @@ module Yesod.Request , waiRequest , languages -- * Lookup parameters + , lookupGetParam + , lookupPostParam + , lookupCookie + , lookupSession + -- ** Alternate , getParams , postParams , cookies , session - , lookupSession -- * Parameter type synonyms , ParamName , ParamValue @@ -56,6 +60,18 @@ instance RequestReader ((->) Request) where getRequest = id -- | Get the list of supported languages supplied by the user. +-- +-- Languages are determined based on the following three (in descending order +-- of preference: +-- +-- * The _LANG get parameter. +-- +-- * The _LANG cookie. +-- +-- * Accept-Language HTTP header. +-- +-- This is handled by the parseWaiRequest function in Yesod.Dispatch (not +-- exposed). languages :: RequestReader m => m [String] languages = reqLangs `liftM` getRequest @@ -97,18 +113,39 @@ getParams = do rr <- getRequest return $ multiLookup $ reqGetParams rr +-- | Lookup for GET parameters. +lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupGetParam pn = do + rr <- getRequest + return $ lookup pn $ 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 +-- | Lookup for POST parameters. +lookupPostParam :: (MonadIO m, RequestReader m) + => ParamName + -> m (Maybe ParamValue) +lookupPostParam pn = do + rr <- getRequest + (pp, _) <- liftIO $ reqRequestBody rr + return $ lookup pn pp + -- | All cookies with the given name. cookies :: RequestReader m => m (ParamName -> [ParamValue]) cookies = do rr <- getRequest return $ multiLookup $ reqCookies rr +-- | Lookup for cookie data. +lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) +lookupCookie pn = do + rr <- getRequest + return $ lookup pn $ reqCookies rr + -- | All session data with the given name. session :: RequestReader m => m (ParamName -> [ParamValue]) session = do diff --git a/yesod.cabal b/yesod.cabal index 72b7720c..744d1a40 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -4,7 +4,21 @@ 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. +synopsis: Creation of type-safe, RESTful web applications. +description: + Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. + . + The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. + . + As a quick overview, here is a fully-functional Hello World application: + . + > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} + > import Yesod + > data HelloWorld = HelloWorld + > mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] + > instance Yesod HelloWorld where approot _ = "" + > getHome = return $ RepPlain $ cs "Hello World!" + > main = toWaiApp HelloWorld >>= basicHandler 3000 category: Web stability: Stable cabal-version: >= 1.6 @@ -30,7 +44,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.1 && < 0.2, - hamlet >= 0.2.0 && < 0.3, + hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, clientsession >= 0.2 && < 0.3, MonadCatchIO-transformers >= 0.2.2 && < 0.3, From a847b5c02d925ed78a9f4e4501ad1d8f1e941385 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 12 May 2010 00:03:15 +0300 Subject: [PATCH 248/624] setLanguage --- Yesod/Dispatch.hs | 3 --- Yesod/Handler.hs | 5 +++++ Yesod/Internal.hs | 5 +++++ 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4ad8b123..2d24502c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -218,9 +218,6 @@ fixSegs [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs -langKey :: String -langKey = "_LANG" - parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 97a37d49..58a00038 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -47,6 +47,7 @@ module Yesod.Handler , addCookie , deleteCookie , header + , setLanguage -- * Session , setSession , clearSession @@ -363,6 +364,10 @@ addCookie a b = addHeader . AddCookie a b deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie +-- | Set the language header. Will show up in 'languages'. +setLanguage :: String -> GHandler sub master () +setLanguage = addCookie 60 langKey + -- | Set an arbitrary header on the client. header :: String -> String -> GHandler sub master () header a = addHeader . Header a diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 0f89fdda..384f2a07 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -4,6 +4,8 @@ module Yesod.Internal ErrorResponse (..) -- * Header , Header (..) + -- * Cookie names + , langKey ) where -- | Responses to indicate some form of an error occurred. These are different @@ -23,3 +25,6 @@ data Header = | DeleteCookie String | Header String String deriving (Eq, Show) + +langKey :: String +langKey = "_LANG" From 6e639e93337541eb46c1a393f2d64daad14a7279 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 12 May 2010 17:56:06 +0300 Subject: [PATCH 249/624] hlint --- Yesod/Dispatch.hs | 9 ++++----- Yesod/Hamlet.hs | 1 - Yesod/Handler.hs | 9 ++++----- Yesod/Helpers/Auth.hs | 8 ++++---- 4 files changed, 12 insertions(+), 15 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2d24502c..1f6c6efa 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -104,7 +104,7 @@ sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI -- handler. You can use 'basicHandler' if you wish. toWaiApp :: Yesod y => y -> IO W.Application -toWaiApp a = do +toWaiApp a = return $ gzip $ jsonp $ methodOverride @@ -138,10 +138,9 @@ toWaiApp' y resource env = do types = httpAccept env pathSegments = filter (not . null) $ cleanupSegments resource eurl = quasiParse site pathSegments - render u = - case urlRenderOverride y u of - Nothing -> fullRender (approot y) site u - Just s -> s + render u = fromMaybe + (fullRender (approot y) site u) + (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr let ya = case eurl of diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 0f8adfbe..e5f28bf4 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( -- * Hamlet library diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 58a00038..85485d88 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -70,7 +70,7 @@ import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl') -import Web.Encodings (encodeUrlPairs) +import Web.Encodings (encodeUrlPairs, encodeHtml) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -93,7 +93,6 @@ import qualified Network.Wai as W import Data.Convertible.Text (cs) import Text.Hamlet import Data.Text (Text) -import Web.Encodings (encodeHtml) data HandlerData sub master = HandlerData { handlerRequest :: Request @@ -157,9 +156,9 @@ instance C.MonadCatchIO (GHandler sub master) where catch (Handler m) f = Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d) block (Handler m) = - Handler $ \d -> E.block (m d) + Handler $ E.block . m unblock (Handler m) = - Handler $ \d -> E.unblock (m d) + Handler $ E.unblock . m instance Failure ErrorResponse (GHandler sub master) where failure e = Handler $ \_ -> return ([], [], HCError e) instance RequestReader (GHandler sub master) where @@ -320,7 +319,7 @@ setMessage = setSession msgKey . cs . htmlContentToText getMessage :: GHandler sub master (Maybe HtmlContent) getMessage = do clearSession msgKey - (fmap $ fmap $ Encoded . cs) $ lookupSession msgKey + fmap (fmap $ Encoded . cs) $ lookupSession msgKey -- | FIXME move this definition into hamlet htmlContentToText :: HtmlContent -> Text diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1f8a4271..ef11a6ba 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -238,10 +238,10 @@ handleRpxnowR = do -- | Get some form of a display name. getDisplayName :: [(String, String)] -> Maybe String -getDisplayName extra = helper choices where +getDisplayName extra = + foldr (\x -> mplus (lookup x extra)) Nothing choices + where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] - helper [] = Nothing - helper (x:xs) = maybe (helper xs) Just $ lookup x extra getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do @@ -457,7 +457,7 @@ saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) inMemoryEmailSettings :: IO AuthEmailSettings inMemoryEmailSettings = do mm <- newMVar [] - return $ AuthEmailSettings + return AuthEmailSettings { addUnverified = \email verkey -> modifyMVar mm $ \m -> do let helper (_, EmailCreds x _ _ _) = x let newId = 1 + maximum (0 : map helper m) From d20d76f677bb508af5a8e23704fd623c2f83e017 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 13 May 2010 13:43:06 +0300 Subject: [PATCH 250/624] Bumped web-routes-quasi to 0.2 --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 744d1a40..9028f762 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -43,7 +43,7 @@ library convertible-text >= 0.2.0 && < 0.3, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.1 && < 0.2, + web-routes-quasi >= 0.2 && < 0.3, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, clientsession >= 0.2 && < 0.3, From 0d8c024c332cc269e6f6678bf1f807dbf02bec97 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 13 May 2010 20:50:35 +0300 Subject: [PATCH 251/624] Offer split mkYesod --- Yesod/Dispatch.hs | 34 ++++++++++++++++++++++++++++------ Yesod/Yesod.hs | 2 +- 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 1f6c6efa..47cdf534 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -5,6 +5,9 @@ module Yesod.Dispatch parseRoutes , mkYesod , mkYesodSub + -- ** More fine-grained + , mkYesodData + , mkYesodDispatch -- * Convert to WAI , toWaiApp , basicHandler @@ -54,7 +57,7 @@ import Web.ClientSession mkYesod :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec] -mkYesod name = mkYesodGeneral name [] False +mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] False -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. @@ -65,7 +68,26 @@ mkYesodSub :: String -- ^ name of the argument datatype -> [Name] -- ^ a list of classes the master datatype must be an instance of -> [Resource] -> Q [Dec] -mkYesodSub name clazzes = mkYesodGeneral name clazzes True +mkYesodSub name clazzes = + fmap (\(x, y) -> x ++ y) . mkYesodGeneral name clazzes True + +-- | Sometimes, you will want to declare your routes in one file and define +-- your handlers elsewhere. For example, this is the only way to break up a +-- monolithic file into smaller parts. This function, paired with +-- 'mkYesodDispatch', do just that. +mkYesodData :: String -> [Resource] -> Q [Dec] +mkYesodData name res = do + (x, _) <- mkYesodGeneral name [] False res + let rname = mkName $ "resources" ++ name + eres <- liftResources res + let y = [ SigD rname $ ListT `AppT` ConT ''Resource + , FunD rname [Clause [] (NormalB eres) []] + ] + return $ x ++ y + +-- | See 'mkYesodData'. +mkYesodDispatch :: String -> [Resource] -> Q [Dec] +mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False explodeHandler :: HasReps c => GHandler sub master c @@ -79,7 +101,7 @@ explodeHandler :: HasReps c -> YesodApp explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f -mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q [Dec] +mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q ([Dec], [Dec]) mkYesodGeneral name clazzes isSub res = do let name' = mkName name let site = mkName $ "site" ++ name @@ -96,14 +118,14 @@ mkYesodGeneral name clazzes isSub res = do , crSite = site , crMaster = if isSub then Right clazzes else Left (ConT name') } - return $ (if isSub then id else (:) yes) [w, x, y, z] + return ([w, x], (if isSub then id else (:) yes) [y, z]) sessionName :: String sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI -- handler. You can use 'basicHandler' if you wish. -toWaiApp :: Yesod y => y -> IO W.Application +toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp a = return $ gzip $ jsonp @@ -116,7 +138,7 @@ parseSession bs = case reads $ cs bs of [] -> [] ((x, _):_) -> x -toWaiApp' :: Yesod y +toWaiApp' :: (Yesod y, YesodSite y) => y -> [B.ByteString] -> W.Request diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 4ebc4b46..7bb1d9c2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -31,7 +31,7 @@ class YesodSite y where -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. -class YesodSite a => Yesod a where +class Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- From 70144804ce471e102bb37a07f12f624f04725cfd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 13 May 2010 23:25:17 +0300 Subject: [PATCH 252/624] Played around with dependencies --- Yesod/Dispatch.hs | 15 ++++----------- Yesod/Form.hs | 8 ++++---- Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 2 +- Yesod/Yesod.hs | 2 +- yesod.cabal | 14 +++++++------- 6 files changed, 18 insertions(+), 25 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 47cdf534..c5048a4c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,9 +27,7 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W import qualified Network.Wai.Enumerator 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 @@ -38,8 +36,7 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B import Web.Encodings -import Data.List (intercalate) -import Web.Routes (encodePathInfo, decodePathInfo) +import Web.Routes (encodePathInfo) import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -129,7 +126,6 @@ toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp a = return $ gzip $ jsonp - $ methodOverride $ cleanPath $ toWaiApp' a @@ -140,10 +136,10 @@ parseSession bs = case reads $ cs bs of toWaiApp' :: (Yesod y, YesodSite y) => y - -> [B.ByteString] + -> [String] -> W.Request -> IO W.Response -toWaiApp' y resource env = do +toWaiApp' y segments env = do key' <- encryptKey y now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -158,7 +154,7 @@ toWaiApp' y resource env = do site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env - pathSegments = filter (not . null) $ cleanupSegments resource + pathSegments = filter (not . null) segments eurl = quasiParse site pathSegments render u = fromMaybe (fullRender (approot y) site u) @@ -206,9 +202,6 @@ fullRender :: String -- ^ approot, no trailing slash fullRender ar site route = ar ++ '/' : encodePathInfo (fixSegs $ quasiRender site route) -cleanupSegments :: [B.ByteString] -> [String] -cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack - httpAccept :: W.Request -> [ContentType] httpAccept = map (contentTypeFromString . B.unpack) . parseHttpAccept diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4e00384a..9c3922b6 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -25,7 +25,6 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) import Data.Convertible.Text -import Control.Monad.Attempt import Data.Maybe (fromMaybe) #if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class @@ -33,6 +32,7 @@ import "transformers" Control.Monad.IO.Class import "transformers" Control.Monad.Trans #endif import Yesod.Internal +import Control.Monad.Attempt noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)" @@ -56,7 +56,7 @@ instance Applicative Form where type FormError = String -runFormGeneric :: MonadFailure ErrorResponse m +runFormGeneric :: Failure ErrorResponse m => (ParamName -> [ParamValue]) -> Form x -> m x runFormGeneric params (Form f) = case f params of @@ -64,7 +64,7 @@ runFormGeneric params (Form f) = Right (_, x) -> return x -- | Run a form against POST parameters. -runFormPost :: (RequestReader m, MonadFailure ErrorResponse m, MonadIO m) +runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m) => Form x -> m x runFormPost f = do rr <- getRequest @@ -72,7 +72,7 @@ runFormPost f = do runFormGeneric pp f -- | Run a form against GET parameters. -runFormGet :: (RequestReader m, MonadFailure ErrorResponse m) +runFormGet :: (RequestReader m, Failure ErrorResponse m) => Form x -> m x runFormGet f = do rr <- getRequest diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 85485d88..f0119373 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -83,12 +83,12 @@ import "transformers" Control.Monad.Trans #endif import qualified Control.Monad.CatchIO as C import Control.Monad.CatchIO (catch) -import Control.Monad.Attempt import Control.Monad (liftM, ap) import System.IO import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W +import Control.Monad.Attempt import Data.Convertible.Text (cs) import Text.Hamlet diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index ef11a6ba..c9846f2d 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -40,7 +40,6 @@ import qualified Web.Authenticate.OpenId as OpenId import Yesod -import Control.Monad.Attempt import Data.Maybe import Control.Monad import System.Random @@ -48,6 +47,7 @@ import Data.Digest.Pure.MD5 import Control.Applicative import Control.Concurrent.MVar import System.IO +import Control.Monad.Attempt class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7bb1d9c2..f971b09c 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,10 +17,10 @@ import Yesod.Request import Yesod.Hamlet import Yesod.Handler import Data.Convertible.Text -import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W import Yesod.Json import Yesod.Internal +import Web.ClientSession (Word256, getKey, defaultKeyFile) import Web.Routes.Quasi (QuasiSite (..), Routes) diff --git a/yesod.cabal b/yesod.cabal index 9028f762..f2b9ccf3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -33,23 +33,23 @@ library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, wai >= 0.0.1 && < 0.3, - wai-extra >= 0.0.0 && < 0.1, - authenticate >= 0.6 && < 0.7, + wai-extra >= 0.1.0 && < 0.2, + authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.4 && < 0.3, + web-encodings >= 0.2.6 && < 0.3, directory >= 1 && < 1.1, - control-monad-attempt >= 0.2.0 && < 0.3, text >= 0.5 && < 0.8, - convertible-text >= 0.2.0 && < 0.3, + convertible-text >= 0.3.0 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.2 && < 0.3, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, - clientsession >= 0.2 && < 0.3, + clientsession >= 0.2.1 && < 0.3, MonadCatchIO-transformers >= 0.2.2 && < 0.3, pureMD5 >= 1.0.0.3 && < 1.1, - random >= 1.0.0.2 && < 1.1 + random >= 1.0.0.2 && < 1.1, + control-monad-attempt >= 0.3 && < 0.4 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 692522ef8bcfe987f8a5da4d7545d6e6569989bf Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 14 May 2010 10:00:14 +0300 Subject: [PATCH 253/624] pureMD5 bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index f2b9ccf3..aec485ed 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -47,7 +47,7 @@ library transformers >= 0.1 && < 0.3, clientsession >= 0.2.1 && < 0.3, MonadCatchIO-transformers >= 0.2.2 && < 0.3, - pureMD5 >= 1.0.0.3 && < 1.1, + pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4 exposed-modules: Yesod From f116b0659b9034fdee3bee0b7d017b956fe8a3ac Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 15 May 2010 23:08:34 +0300 Subject: [PATCH 254/624] clientsession 0.3.0 --- Yesod/Dispatch.hs | 108 +++++++++++++++++++++++++++++++++------------- Yesod/Yesod.hs | 5 ++- runtests.hs | 2 + yesod.cabal | 5 ++- 4 files changed, 87 insertions(+), 33 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c5048a4c..45c298ee 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -13,10 +14,12 @@ module Yesod.Dispatch , basicHandler -- * Utilities , fullRender +#if TEST + , testSuite +#endif ) where import Yesod.Handler -import Yesod.Content import Yesod.Yesod import Yesod.Request import Yesod.Internal @@ -48,6 +51,17 @@ import Control.Monad import Data.Maybe import Web.ClientSession +import Data.Serialize + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import System.IO.Unsafe +import Yesod.Content hiding (testSuite) +#else +import Yesod.Content +#endif + -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. @@ -129,11 +143,6 @@ toWaiApp a = $ cleanPath $ toWaiApp' a -parseSession :: B.ByteString -> [(String, String)] -parseSession bs = case reads $ cs bs of - [] -> [] - ((x, _):_) -> x - toWaiApp' :: (Yesod y, YesodSite y) => y -> [String] @@ -145,13 +154,11 @@ toWaiApp' y segments env = do let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y let host = W.remoteHost env - let session' = do - (_, raw) <- filter (\(x, _) -> x == W.Cookie) $ W.requestHeaders env - (name, val) <- parseCookies raw - guard $ name == B.pack sessionName - decoded <- maybeToList $ decodeCookie key' now host val - parseSession decoded - site = getSite + let session' = fromMaybe [] $ do + raw <- lookup W.Cookie $ W.requestHeaders env + val <- lookup (B.pack sessionName) $ parseCookies raw + decodeSession key' now host val + let site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments @@ -179,9 +186,9 @@ toWaiApp' y segments env = do let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types - let sessionVal = encrypt key' $ B.pack $ show $ ACookie exp' host $ B.pack - $ show sessionFinal - let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal : hs + sessionVal <- encodeSession key' exp' host sessionFinal + let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal + : hs hs'' = map (headerToPair getExpires) hs' hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs'' return $ W.Response s hs''' $ case c of @@ -281,21 +288,64 @@ headerToPair _ (DeleteCookie key) = key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value) -decodeCookie :: Word256 -- ^ key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe B.ByteString -decodeCookie key now rhost encrypted = do +encodeSession :: B.ByteString -- ^ key + -> UTCTime -- ^ expire time + -> B.ByteString -- ^ remote host + -> [(String, String)] -- ^ session + -> IO String -- ^ cookie value +encodeSession key expire rhost session' = + encrypt key $ cs $ encode $ SessionCookie expire rhost session' + +decodeSession :: B.ByteString -- ^ key + -> UTCTime -- ^ current time + -> B.ByteString -- ^ remote host field + -> B.ByteString -- ^ cookie value + -> Maybe [(String, String)] +decodeSession key now rhost encrypted = do decrypted <- decrypt key $ B.unpack encrypted - (ACookie expire rhost' val) <- - case reads $ B.unpack decrypted of - [] -> Nothing - ((x, _):_) -> Just x + SessionCookie expire rhost' session' <- + either (const Nothing) Just $ decode + $ cs decrypted guard $ expire > now guard $ rhost' == rhost - guard $ not $ B.null val - return val + return session' -data ACookie = ACookie UTCTime B.ByteString B.ByteString +data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)] deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = putTime a >> put b >> put c + get = do + a <- getTime + b <- get + c <- get + return $ SessionCookie a b c + +putTime :: Putter UTCTime +putTime (UTCTime d t) = do + put $ toModifiedJulianDay d + put $ fromEnum t + +getTime :: Get UTCTime +getTime = do + d <- get + t <- get + return $ UTCTime (ModifiedJulianDay d) (toEnum t) + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Dispatch" + [ testProperty "encode/decode session" propEncDecSession + ] + +propEncDecSession :: [(String, String)] -> Bool +propEncDecSession session' = unsafePerformIO $ do + key <- getDefaultKey + now <- getCurrentTime + let expire = addUTCTime 1 now + let rhost = B.pack "some host" + val <- encodeSession key expire rhost session' + return $ Just session' == + decodeSession key now rhost (B.pack val) + +#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f971b09c..f8753be2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -20,7 +20,8 @@ import Data.Convertible.Text import qualified Network.Wai as W import Yesod.Json import Yesod.Internal -import Web.ClientSession (Word256, getKey, defaultKeyFile) +import Web.ClientSession (getKey, defaultKeyFile) +import Data.ByteString (ByteString) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -45,7 +46,7 @@ class Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Word256 + encryptKey :: a -> IO ByteString encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to diff --git a/runtests.hs b/runtests.hs index 59000fc0..de7ac4e1 100644 --- a/runtests.hs +++ b/runtests.hs @@ -2,9 +2,11 @@ import Test.Framework (defaultMain) import qualified Yesod.Content import qualified Yesod.Json +import qualified Yesod.Dispatch main :: IO () main = defaultMain [ Yesod.Content.testSuite , Yesod.Json.testSuite + , Yesod.Dispatch.testSuite ] diff --git a/yesod.cabal b/yesod.cabal index aec485ed..525fd4f3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,11 +45,12 @@ library web-routes-quasi >= 0.2 && < 0.3, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, - clientsession >= 0.2.1 && < 0.3, + clientsession >= 0.3.0 && < 0.4, MonadCatchIO-transformers >= 0.2.2 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, - control-monad-attempt >= 0.3 && < 0.4 + control-monad-attempt >= 0.3 && < 0.4, + cereal >= 0.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 51f816cb27843cca90df812b88d85d367e209bd5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 16 May 2010 06:56:04 +0300 Subject: [PATCH 255/624] staticFiles --- Yesod.hs | 3 +- Yesod/Helpers/Static.hs | 66 +++++++++++++++++++++++++++++++++++++++-- runtests.hs | 2 ++ test/.ignored | 0 test/bar/baz | 0 test/foo | 0 yesod.cabal | 2 +- 7 files changed, 69 insertions(+), 4 deletions(-) create mode 100644 test/.ignored create mode 100644 test/bar/baz create mode 100644 test/foo diff --git a/Yesod.hs b/Yesod.hs index 73e5f2d2..0bbf0572 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,13 +19,14 @@ module Yesod #if TEST import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) +import Yesod.Dispatch hiding (testSuite) #else import Yesod.Content import Yesod.Json +import Yesod.Dispatch #endif import Yesod.Request -import Yesod.Dispatch import Yesod.Form import Yesod.Yesod import Yesod.Handler hiding (runHandler) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 117dc9e6..b588dc98 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static @@ -28,20 +29,31 @@ module Yesod.Helpers.Static , siteStatic -- * Lookup files in filesystem , fileLookupDir + , staticFiles +#if TEST + , testSuite +#endif ) where -import System.Directory (doesFileExist) +import System.Directory import Control.Monad import Yesod import Data.List (intercalate) +import Language.Haskell.TH.Syntax + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif -- | A function for looking up file contents. For serving from the file system, -- see 'fileLookupDir'. data Static = Static (FilePath -> IO (Maybe (Either FilePath Content))) $(mkYesodSub "Static" [] [$parseRoutes| -/* StaticRoute GET +* StaticRoute GET |]) -- | Lookup files in a specific directory. @@ -73,3 +85,53 @@ getStaticRoute fp' = do isUnsafe [] = True isUnsafe ('.':_) = True isUnsafe _ = False + +notHidden :: FilePath -> Bool +notHidden ('.':_) = False +notHidden _ = True + +getFileList :: FilePath -> IO [[String]] +getFileList = flip go id + where + go :: String -> ([String] -> [String]) -> IO [[String]] + go fp front = do + allContents <- filter notHidden `fmap` getDirectoryContents fp + let fullPath :: String -> String + fullPath f = fp ++ '/' : f + files <- filterM (doesFileExist . fullPath) allContents + let files' = map (front . return) files + dirs <- filterM (doesDirectoryExist . fullPath) allContents + dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs + return $ concat $ files' : dirs' + +staticFiles :: FilePath -> Q [Dec] +staticFiles fp = do + fs <- qRunIO $ getFileList fp + concat `fmap` mapM go fs + where + replace '.' = '_' + replace c = c + go f = do + let name = mkName $ intercalate "/" $ map (map replace) f + f' <- lift f + let sr = ConE $ mkName "StaticRoute" + return + [ SigD name $ ConT ''StaticRoutes + , FunD name + [ Clause [] (NormalB $ sr `AppE` f') [] + ] + ] + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Helpers.Static" + [ testCase "get file list" caseGetFileList + ] + +caseGetFileList :: Assertion +caseGetFileList = do + x <- getFileList "test" + x @?= [["foo"], ["bar", "baz"]] + +#endif diff --git a/runtests.hs b/runtests.hs index de7ac4e1..208e38fe 100644 --- a/runtests.hs +++ b/runtests.hs @@ -3,10 +3,12 @@ import Test.Framework (defaultMain) import qualified Yesod.Content import qualified Yesod.Json import qualified Yesod.Dispatch +import qualified Yesod.Helpers.Static main :: IO () main = defaultMain [ Yesod.Content.testSuite , Yesod.Json.testSuite , Yesod.Dispatch.testSuite + , Yesod.Helpers.Static.testSuite ] diff --git a/test/.ignored b/test/.ignored new file mode 100644 index 00000000..e69de29b diff --git a/test/bar/baz b/test/bar/baz new file mode 100644 index 00000000..e69de29b diff --git a/test/foo b/test/foo new file mode 100644 index 00000000..e69de29b diff --git a/yesod.cabal b/yesod.cabal index 525fd4f3..d3f240e1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -33,7 +33,7 @@ library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, wai >= 0.0.1 && < 0.3, - wai-extra >= 0.1.0 && < 0.2, + wai-extra >= 0.1.1 && < 0.2, authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, web-encodings >= 0.2.6 && < 0.3, From 022ead8b316ed6be939dd9712c080ab678bdec53 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 16 May 2010 10:15:29 +0300 Subject: [PATCH 256/624] clientsession 0.4 --- Yesod/Dispatch.hs | 8 ++++---- Yesod/Yesod.hs | 5 ++--- yesod.cabal | 2 +- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 45c298ee..b2dbf7ee 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -186,7 +186,7 @@ toWaiApp' y segments env = do let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types - sessionVal <- encodeSession key' exp' host sessionFinal + let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal : hs hs'' = map (headerToPair getExpires) hs' @@ -288,15 +288,15 @@ headerToPair _ (DeleteCookie key) = key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value) -encodeSession :: B.ByteString -- ^ key +encodeSession :: Key -> UTCTime -- ^ expire time -> B.ByteString -- ^ remote host -> [(String, String)] -- ^ session - -> IO String -- ^ cookie value + -> String -- ^ cookie value encodeSession key expire rhost session' = encrypt key $ cs $ encode $ SessionCookie expire rhost session' -decodeSession :: B.ByteString -- ^ key +decodeSession :: Key -> UTCTime -- ^ current time -> B.ByteString -- ^ remote host field -> B.ByteString -- ^ cookie value diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f8753be2..78fc216c 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -20,8 +20,7 @@ import Data.Convertible.Text import qualified Network.Wai as W import Yesod.Json import Yesod.Internal -import Web.ClientSession (getKey, defaultKeyFile) -import Data.ByteString (ByteString) +import Web.ClientSession (getKey, defaultKeyFile, Key) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -46,7 +45,7 @@ class Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO ByteString + encryptKey :: a -> IO Key encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to diff --git a/yesod.cabal b/yesod.cabal index d3f240e1..952e884e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,7 +45,7 @@ library web-routes-quasi >= 0.2 && < 0.3, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, - clientsession >= 0.3.0 && < 0.4, + clientsession >= 0.4.0 && < 0.5, MonadCatchIO-transformers >= 0.2.2 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, From 0c9e2f94c0731db171a553cf554d6451c35e12ee Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 16 May 2010 11:23:45 +0300 Subject: [PATCH 257/624] Better getTime + putTime, added test --- Yesod/Dispatch.hs | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index b2dbf7ee..6e771f65 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -56,8 +56,11 @@ import Data.Serialize #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck import System.IO.Unsafe import Yesod.Content hiding (testSuite) +import Data.Serialize.Get +import Data.Serialize.Put #else import Yesod.Content #endif @@ -321,21 +324,23 @@ instance Serialize SessionCookie where return $ SessionCookie a b c putTime :: Putter UTCTime -putTime (UTCTime d t) = do +putTime t@(UTCTime d _) = do put $ toModifiedJulianDay d - put $ fromEnum t + let ndt = diffUTCTime t $ UTCTime d 0 + put $ toRational ndt getTime :: Get UTCTime getTime = do d <- get - t <- get - return $ UTCTime (ModifiedJulianDay d) (toEnum t) + ndt <- get + return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 #if TEST testSuite :: Test testSuite = testGroup "Yesod.Dispatch" [ testProperty "encode/decode session" propEncDecSession + , testProperty "get/put time" propGetPutTime ] propEncDecSession :: [(String, String)] -> Bool @@ -344,8 +349,18 @@ propEncDecSession session' = unsafePerformIO $ do now <- getCurrentTime let expire = addUTCTime 1 now let rhost = B.pack "some host" - val <- encodeSession key expire rhost session' + let val = encodeSession key expire rhost session' return $ Just session' == decodeSession key now rhost (B.pack val) +propGetPutTime :: UTCTime -> Bool +propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) + +instance Arbitrary UTCTime where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ addUTCTime (fromRational b) + $ UTCTime (ModifiedJulianDay a) 0 + #endif From 7d1b88f55afe6e8c3bf797fd470af0a4758527b0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 16 May 2010 15:34:54 +0300 Subject: [PATCH 258/624] Changed some types --- Yesod/Dispatch.hs | 11 ++++++----- Yesod/Helpers/Auth.hs | 3 ++- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 6e771f65..46cbc443 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -14,6 +14,7 @@ module Yesod.Dispatch , basicHandler -- * Utilities , fullRender + , quasiRender #if TEST , testSuite #endif @@ -167,7 +168,7 @@ toWaiApp' y segments env = do pathSegments = filter (not . null) segments eurl = quasiParse site pathSegments render u = fromMaybe - (fullRender (approot y) site u) + (fullRender (approot y) (quasiRender site) u) (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr @@ -206,11 +207,11 @@ toWaiApp' y segments env = do -- For example, if you want to generate an e-mail which links to your site, -- this is the function you would want to use. fullRender :: String -- ^ approot, no trailing slash - -> QuasiSite YesodApp arg arg - -> Routes arg + -> (url -> [String]) + -> url -> String -fullRender ar site route = - ar ++ '/' : encodePathInfo (fixSegs $ quasiRender site route) +fullRender ar render route = + ar ++ '/' : encodePathInfo (fixSegs $ render route) httpAccept :: W.Request -> [ContentType] httpAccept = map (contentTypeFromString . B.unpack) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c9846f2d..00f71fb0 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -27,6 +27,7 @@ module Yesod.Helpers.Auth -- * Settings , YesodAuth (..) , Creds (..) + , EmailCreds (..) , AuthType (..) , AuthEmailSettings (..) , inMemoryEmailSettings @@ -127,7 +128,7 @@ setCreds creds extra = do onLogin creds extra -- | Retrieves user credentials, if user is authenticated. -maybeCreds :: GHandler sub master (Maybe Creds) +maybeCreds :: RequestReader r => r (Maybe Creds) maybeCreds = do mcs <- lookupSession credsKey return $ mcs >>= readMay From 8dc59bf113959eaaaad18cc4c28c3557f62cc403 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 16 May 2010 21:06:31 +0300 Subject: [PATCH 259/624] Fixed atom feeds --- Yesod/Helpers/AtomFeed.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index bb5a7574..10231b2f 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -26,6 +26,7 @@ import Yesod import Data.Time.Clock (UTCTime) import Web.Encodings (formatW3) import Text.Hamlet.Monad +import Text.Hamlet.Quasi newtype RepAtom = RepAtom Content instance HasReps RepAtom where @@ -53,7 +54,8 @@ xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url IO () -template arg = [$hamlet| +template arg = [$xhamlet| +<?xml version="1.0" encoding="utf-8"?> %feed!xmlns=$xmlns.arg$ %title $cs.atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ @@ -65,7 +67,7 @@ template arg = [$hamlet| |] entryTemplate :: AtomFeedEntry url -> Hamlet url IO () -entryTemplate arg = [$hamlet| +entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@ From aa770f7622b6578e7b53de6f0983d85dc68128a3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 20 May 2010 14:51:22 +0300 Subject: [PATCH 260/624] Fix slash to underscore for static --- Yesod/Helpers/Static.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index b588dc98..e08815dc 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -112,7 +112,7 @@ staticFiles fp = do replace '.' = '_' replace c = c go f = do - let name = mkName $ intercalate "/" $ map (map replace) f + let name = mkName $ intercalate "_" $ map (map replace) f f' <- lift f let sr = ConE $ mkName "StaticRoute" return From 712110a2ef837e7392b33b030efb8e6db6ee2caa Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 20 May 2010 22:21:26 +0300 Subject: [PATCH 261/624] Removed web-encodings dependency --- Yesod/Content.hs | 8 ++++++++ Yesod/Dispatch.hs | 4 ++-- Yesod/Handler.hs | 32 ++++++++++++++++++++++++-------- Yesod/Helpers/AtomFeed.hs | 1 - Yesod/Helpers/Sitemap.hs | 1 - Yesod/Json.hs | 21 ++++++++++++++++++++- Yesod/Request.hs | 8 ++++++-- yesod.cabal | 4 ++-- 8 files changed, 62 insertions(+), 17 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index c622db4b..09fcb028 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -30,6 +30,8 @@ module Yesod.Content , RepHtmlJson (..) , RepPlain (..) , RepXml (..) + -- * Utilities + , formatW3 #if TEST , testSuite #endif @@ -46,6 +48,8 @@ import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE import Data.Function (on) +import Data.Time +import System.Locale #if TEST import Test.Framework (testGroup, Test) @@ -245,3 +249,7 @@ caseTypeByExt = do TypeJavascript @=? typeByExt (ext "foo.js") TypeHtml @=? typeByExt (ext "foo.html") #endif + +-- | Format a 'UTCTime' in W3 format; useful for setting cookies. +formatW3 :: UTCTime -> String +formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 46cbc443..0f61cd6f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -39,7 +39,6 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B -import Web.Encodings import Web.Routes (encodePathInfo) import Control.Concurrent.MVar @@ -53,6 +52,7 @@ import Data.Maybe import Web.ClientSession import Data.Serialize +import Network.Wai.Parse #if TEST import Test.Framework (testGroup, Test) @@ -247,7 +247,7 @@ parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do - let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env + let gets' = map (cs *** cs) $ parseQueryString $ 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 diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f0119373..b3b87588 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -69,8 +69,8 @@ import Yesod.Request import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) -import Data.List (foldl') -import Web.Encodings (encodeUrlPairs, encodeHtml) +import Data.List (foldl', intercalate) +import Text.Hamlet.Monad (htmlContentToText) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -92,7 +92,8 @@ import Control.Monad.Attempt import Data.Convertible.Text (cs) import Text.Hamlet -import Data.Text (Text) +import Numeric (showIntAtBase) +import Data.Char (ord, chr) data HandlerData sub master = HandlerData { handlerRequest :: Request @@ -260,6 +261,26 @@ redirectParams :: RedirectType -> Routes master -> [(String, String)] redirectParams rt url params = do r <- getUrlRender redirectString rt $ r url ++ '?' : encodeUrlPairs params + where + encodeUrlPairs = intercalate "&" . map encodeUrlPair + encodeUrlPair (x, []) = escape x + encodeUrlPair (x, y) = escape x ++ '=' : escape y + escape = concatMap escape' + escape' c + | 'A' < c && c < 'Z' = [c] + | 'a' < c && c < 'a' = [c] + | '0' < c && c < '9' = [c] + | c `elem` ".-~_" = [c] + | c == ' ' = "+" + | otherwise = '%' : myShowHex (ord c) "" + myShowHex :: Int -> ShowS + myShowHex n r = case showIntAtBase 16 (toChrHex) n r of + [] -> "00" + [c] -> ['0',c] + s -> s + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d) + | otherwise = chr (ord 'A' + fromIntegral (d - 10)) -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a @@ -321,11 +342,6 @@ getMessage = do clearSession msgKey fmap (fmap $ Encoded . cs) $ lookupSession msgKey --- | FIXME move this definition into hamlet -htmlContentToText :: HtmlContent -> Text -htmlContentToText (Encoded t) = t -htmlContentToText (Unencoded t) = encodeHtml t - -- | Bypass remaining handler code and output the given file. -- -- For some backends, this is more efficient than reading in the file to diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 10231b2f..ded93117 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -24,7 +24,6 @@ module Yesod.Helpers.AtomFeed import Yesod import Data.Time.Clock (UTCTime) -import Web.Encodings (formatW3) import Text.Hamlet.Monad import Text.Hamlet.Quasi diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 9543c733..443209b3 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -24,7 +24,6 @@ module Yesod.Helpers.Sitemap ) where import Yesod -import Web.Encodings (formatW3) import Data.Time (UTCTime) data SitemapChangeFreq = Always diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 71894f44..5683f4a8 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -21,11 +21,13 @@ module Yesod.Json import Text.Hamlet.Monad import Control.Applicative import Data.Text (pack) -import Web.Encodings +import qualified Data.Text as T +import Data.Char (isControl) import Yesod.Hamlet import Control.Monad (when) import Yesod.Handler import Web.Routes.Quasi (Routes) +import Numeric (showHex) #if TEST import Test.Framework (testGroup, Test) @@ -69,6 +71,23 @@ jsonScalar s = Json $ do outputString "\"" output $ encodeJson $ htmlContentToText s outputString "\"" + where + encodeJson = T.concatMap (T.pack . encodeJsonChar) + + encodeJsonChar '\b' = "\\b" + encodeJsonChar '\f' = "\\f" + encodeJsonChar '\n' = "\\n" + encodeJsonChar '\r' = "\\r" + encodeJsonChar '\t' = "\\t" + encodeJsonChar '"' = "\\\"" + encodeJsonChar '\\' = "\\\\" + encodeJsonChar c + | not $ isControl c = [c] + | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs + | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs + | c < '\x1000' = '\\' : 'u' : '0' : hexxs + where hexxs = showHex (fromEnum c) "" -- FIXME + encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. jsonList :: [Json url ()] -> Json url () diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 3a7c918c..423488af 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -20,6 +20,7 @@ module Yesod.Request RequestBodyContents , Request (..) , RequestReader (..) + , FileInfo (..) -- * Convenience functions , waiRequest , languages @@ -40,7 +41,6 @@ module Yesod.Request ) where import qualified Network.Wai as W -import Web.Encodings import qualified Data.ByteString.Lazy as BL #if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class @@ -48,6 +48,7 @@ import "transformers" Control.Monad.IO.Class import "transformers" Control.Monad.Trans #endif import Control.Monad (liftM) +import Network.Wai.Parse type ParamName = String type ParamValue = String @@ -58,6 +59,9 @@ class Monad m => RequestReader m where getRequest :: m Request instance RequestReader ((->) Request) where getRequest = id +instance Monad ((->) Request) where -- FIXME what's happening here? + return = const + f >>= g = \r -> g (f r) r -- | Get the list of supported languages supplied by the user. -- @@ -82,7 +86,7 @@ waiRequest = reqWaiRequest `liftM` getRequest -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo String BL.ByteString)] + , [(ParamName, FileInfo BL.ByteString)] ) -- | The parsed request information. diff --git a/yesod.cabal b/yesod.cabal index 952e884e..3ac49169 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -36,7 +36,6 @@ library wai-extra >= 0.1.1 && < 0.2, authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, - web-encodings >= 0.2.6 && < 0.3, directory >= 1 && < 1.1, text >= 0.5 && < 0.8, convertible-text >= 0.3.0 && < 0.4, @@ -50,7 +49,8 @@ library pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, - cereal >= 0.2 && < 0.3 + cereal >= 0.2 && < 0.3, + old-locale >= 1.0.0.2 && < 1.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 7762559c86d1e7d9c98a9203aadd7136f149953c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 21 May 2010 08:00:54 +0300 Subject: [PATCH 262/624] Monad instance import, wai(-extra) version --- Yesod/Request.hs | 4 +--- yesod.cabal | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 423488af..5dcddc80 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -49,6 +49,7 @@ import "transformers" Control.Monad.Trans #endif import Control.Monad (liftM) import Network.Wai.Parse +import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r type ParamName = String type ParamValue = String @@ -59,9 +60,6 @@ class Monad m => RequestReader m where getRequest :: m Request instance RequestReader ((->) Request) where getRequest = id -instance Monad ((->) Request) where -- FIXME what's happening here? - return = const - f >>= g = \r -> g (f r) r -- | Get the list of supported languages supplied by the user. -- diff --git a/yesod.cabal b/yesod.cabal index 3ac49169..a7d64dd6 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,8 +32,8 @@ flag buildtests library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, - wai >= 0.0.1 && < 0.3, - wai-extra >= 0.1.1 && < 0.2, + wai >= 0.1.0 && < 0.2, + wai-extra >= 0.1.2 && < 0.2, authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, From ae43848001beefbcc81b74c91c0f256457d9997d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 21 May 2010 09:41:33 +0300 Subject: [PATCH 263/624] clientsession changes --- Yesod/Dispatch.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0f61cd6f..1c6f7a02 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -191,7 +191,8 @@ toWaiApp' y segments env = do let eh er = runHandler (errorHandler y er) render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal - let hs' = AddCookie (clientSessionDuration y) sessionName sessionVal + let hs' = AddCookie (clientSessionDuration y) sessionName + (cs sessionVal) : hs hs'' = map (headerToPair getExpires) hs' hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs'' @@ -296,9 +297,9 @@ encodeSession :: Key -> UTCTime -- ^ expire time -> B.ByteString -- ^ remote host -> [(String, String)] -- ^ session - -> String -- ^ cookie value + -> B.ByteString -- ^ cookie value encodeSession key expire rhost session' = - encrypt key $ cs $ encode $ SessionCookie expire rhost session' + encrypt key $ encode $ SessionCookie expire rhost session' decodeSession :: Key -> UTCTime -- ^ current time @@ -306,10 +307,9 @@ decodeSession :: Key -> B.ByteString -- ^ cookie value -> Maybe [(String, String)] decodeSession key now rhost encrypted = do - decrypted <- decrypt key $ B.unpack encrypted + decrypted <- decrypt key encrypted SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode - $ cs decrypted + either (const Nothing) Just $ decode decrypted guard $ expire > now guard $ rhost' == rhost return session' From 30e1739bf8bedef064f0457142bb9ada5af2db7b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 21 May 2010 13:46:53 +0300 Subject: [PATCH 264/624] web-routes-quasi 0.3 --- Yesod/Dispatch.hs | 4 ++++ Yesod/Helpers/Auth.hs | 20 ++++++++++---------- Yesod/Helpers/Static.hs | 2 +- yesod.cabal | 2 +- 4 files changed, 16 insertions(+), 12 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 1c6f7a02..4e24c049 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -9,6 +9,10 @@ module Yesod.Dispatch -- ** More fine-grained , mkYesodData , mkYesodDispatch + -- ** Path pieces + , SinglePiece (..) + , MultiPiece (..) + , Strings -- * Convert to WAI , toWaiApp , basicHandler diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 00f71fb0..0829bd7f 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -138,17 +138,17 @@ maybeCreds = do _ -> Nothing mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| -/check Check GET -/logout Logout GET -/openid OpenIdR GET -/openid/forward OpenIdForward GET -/openid/complete OpenIdComplete GET -/login/rpxnow RpxnowR +/check Check GET +/logout Logout GET +/openid OpenIdR GET +/openid/forward OpenIdForward GET +/openid/complete OpenIdComplete GET +/login/rpxnow RpxnowR -/register EmailRegisterR GET POST -/verify/#/$ EmailVerifyR GET -/login EmailLoginR GET POST -/set-password EmailPasswordR GET POST +/register EmailRegisterR GET POST +/verify/#EmailId/#String EmailVerifyR GET +/login EmailLoginR GET POST +/set-password EmailPasswordR GET POST |] testOpenId :: GHandler Auth master () diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index e08815dc..86951052 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -53,7 +53,7 @@ import Test.HUnit hiding (Test) data Static = Static (FilePath -> IO (Maybe (Either FilePath Content))) $(mkYesodSub "Static" [] [$parseRoutes| -* StaticRoute GET +*Strings StaticRoute GET |]) -- | Lookup files in a specific directory. diff --git a/yesod.cabal b/yesod.cabal index a7d64dd6..8590ad14 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -41,7 +41,7 @@ library convertible-text >= 0.3.0 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.2 && < 0.3, + web-routes-quasi >= 0.3 && < 0.4, hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, clientsession >= 0.4.0 && < 0.5, From 4163ffd4423b2c77fcb02b71abde6216fe5c3eb3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 May 2010 13:21:25 +0300 Subject: [PATCH 265/624] Relaxed MonadCatchIO-transformers dependency --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 8590ad14..14a6d347 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,7 +45,7 @@ library hamlet >= 0.2.2 && < 0.3, transformers >= 0.1 && < 0.3, clientsession >= 0.4.0 && < 0.5, - MonadCatchIO-transformers >= 0.2.2 && < 0.3, + MonadCatchIO-transformers >= 0.1 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, From 3ba6be616f8f56c1ec188cab597cb676c55f788f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 24 May 2010 14:35:38 +0300 Subject: [PATCH 266/624] Removed some FIXMEs --- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Json.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 0829bd7f..39c3371c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -319,7 +319,7 @@ postEmailRegisterR = do |] checkEmail :: Form ParamValue -> Form ParamValue -checkEmail = notEmpty -- FIXME +checkEmail = notEmpty -- FIXME consider including e-mail validation getEmailVerifyR :: YesodAuth master => Integer -> String -> GHandler Auth master RepHtml @@ -452,7 +452,7 @@ saltPass pass = do let salt = take saltLength $ randomRs ('A', 'Z') stdgen return $ saltPass' salt pass -saltPass' :: String -> String -> String -- FIXME better salting scheme? +saltPass' :: String -> String -> String saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) inMemoryEmailSettings :: IO AuthEmailSettings diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 5683f4a8..80bbebcd 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -86,7 +86,7 @@ jsonScalar s = Json $ do | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs | c < '\x1000' = '\\' : 'u' : '0' : hexxs - where hexxs = showHex (fromEnum c) "" -- FIXME + where hexxs = showHex (fromEnum c) "" encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. From 56ac2602075cd703ed2e5ac9a9a40f908ea485f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 5 Jun 2010 21:25:32 +0300 Subject: [PATCH 267/624] isAuthorized --- Yesod/Dispatch.hs | 28 ++++++++++++++++++++-------- Yesod/Handler.hs | 4 ++-- Yesod/Internal.hs | 2 +- Yesod/Yesod.hs | 14 ++++++++++++-- yesod.cabal | 2 +- 5 files changed, 36 insertions(+), 14 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4e24c049..0056203a 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -176,14 +176,18 @@ toWaiApp' y segments env = do (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr - let ya = case eurl of - Left _ -> runHandler (errorHandler y NotFound) - render - Nothing - id - y - id - Right url -> quasiDispatch site + ya <- + case eurl of + Left _ -> return $ runHandler (errorHandler y NotFound) + render + Nothing + id + y + id + Right url -> do + auth <- isAuthorized y url + case auth of + Nothing -> return $ quasiDispatch site render url id @@ -191,6 +195,14 @@ toWaiApp' y segments env = do id (badMethodApp method) method + Just msg -> + return $ runHandler + (errorHandler y $ PermissionDenied msg) + render + (Just url) + id + y + id let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b3b87588..559ecb77 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -361,7 +361,7 @@ badMethod = do -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a -permissionDenied = failure PermissionDenied +permissionDenied = failure $ PermissionDenied "Permission denied" -- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a @@ -408,7 +408,7 @@ getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 getStatus (InternalError _) = W.Status500 getStatus (InvalidArgs _) = W.Status400 -getStatus PermissionDenied = W.Status403 +getStatus (PermissionDenied _) = W.Status403 getStatus (BadMethod _) = W.Status405 getRedirectStatus :: RedirectType -> W.Status diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 384f2a07..b741fc6f 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -14,7 +14,7 @@ data ErrorResponse = NotFound | InternalError String | InvalidArgs [(String, String)] - | PermissionDenied + | PermissionDenied String | BadMethod String deriving (Show, Eq) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 78fc216c..a8cff093 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -82,6 +82,14 @@ class Yesod a where urlRenderOverride :: a -> Routes a -> Maybe String urlRenderOverride _ _ = Nothing + -- | Determine is a request is authorized or not. + -- + -- Return 'Nothing' is the request is authorized, 'Just' a message if + -- unauthorized. If authentication is required, you should use a redirect; + -- the Auth helper provides this functionality automatically. + isAuthorized :: a -> Routes a -> IO (Maybe String) + isAuthorized _ _ = return Nothing + -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title @@ -130,9 +138,11 @@ defaultErrorHandler NotFound = do |] where pathInfo = W.pathInfo -defaultErrorHandler PermissionDenied = +defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" $ [$hamlet| -%h1 Permission denied|] +%h1 Permission denied +%p $cs.msg$ +|] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments diff --git a/yesod.cabal b/yesod.cabal index 14a6d347..3d4d0e34 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.2.0 +version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 31fffcf5d4ca5d7c335df5950042aa9a9bb1d4b6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 6 Jun 2010 01:53:55 +0300 Subject: [PATCH 268/624] Migration to hamlet 3 --- Yesod/Hamlet.hs | 26 +++++-------- Yesod/Handler.hs | 4 +- Yesod/Helpers/AtomFeed.hs | 4 +- Yesod/Helpers/Auth.hs | 16 ++++---- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Json.hs | 81 ++++++++++++++++++--------------------- Yesod/Yesod.hs | 15 ++++---- yesod.cabal | 4 +- 8 files changed, 70 insertions(+), 82 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e5f28bf4..34222a33 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -8,7 +8,7 @@ module Yesod.Hamlet Hamlet , hamlet , HtmlContent (..) - , htmlContentToText + , htmlContentToByteString -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -18,7 +18,8 @@ module Yesod.Hamlet where import Text.Hamlet -import Text.Hamlet.Monad (outputHtml, htmlContentToText) +import Text.Hamlet.Monad ( outputHtml, hamletToByteString + , htmlContentToByteString) import Yesod.Content import Yesod.Handler import Data.Convertible.Text @@ -27,32 +28,25 @@ import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- --- > PageContent url -> Hamlet url IO () +-- > PageContent url -> Hamlet url data PageContent url = PageContent { pageTitle :: HtmlContent - , pageHead :: Hamlet url IO () - , pageBody :: Hamlet url IO () + , pageHead :: Hamlet url + , pageBody :: Hamlet url } -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content +hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender - return $ ContentEnum $ go render - where - go render iter seed = do - res <- runHamlet h render seed $ iter' iter - case res of - Left x -> return $ Left x - Right ((), x) -> return $ Right x - iter' iter seed text = iter seed $ cs text + return $ toContent $ hamletToByteString render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml +hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent -instance Monad m => ConvertSuccess String (Hamlet url m ()) where +instance ConvertSuccess String (Hamlet url) where convertSuccess = outputHtml . Unencoded . cs instance ConvertSuccess String HtmlContent where convertSuccess = Unencoded . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 559ecb77..f4c8a0db 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -70,7 +70,7 @@ import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) -import Text.Hamlet.Monad (htmlContentToText) +import Text.Hamlet.Monad (htmlContentToByteString) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -331,7 +331,7 @@ msgKey = "_MSG" -- -- See 'getMessage'. setMessage :: HtmlContent -> GHandler sub master () -setMessage = setSession msgKey . cs . htmlContentToText +setMessage = setSession msgKey . cs . htmlContentToByteString -- | Gets the message in the user's session, if available, and then clears the -- variable. diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index ded93117..85cd0bbc 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -52,7 +52,7 @@ data AtomFeedEntry url = AtomFeedEntry xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" -template :: AtomFeed url -> Hamlet url IO () +template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?> %feed!xmlns=$xmlns.arg$ @@ -65,7 +65,7 @@ template arg = [$xhamlet| ^entryTemplate.entry^ |] -entryTemplate :: AtomFeedEntry url -> Hamlet url IO () +entryTemplate :: AtomFeedEntry url -> Hamlet url entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 39c3371c..0cef2369 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,6 +49,7 @@ import Control.Applicative import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt +import Data.Monoid (mempty) class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other @@ -165,7 +166,7 @@ getOpenIdR = do (x:_) -> setUltDestString x rtom <- getRouteToMaster message <- getMessage - applyLayout "Log in via OpenID" (return ()) [$hamlet| + applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@ @@ -247,8 +248,7 @@ getDisplayName extra = getCheck :: Yesod master => GHandler Auth master RepHtmlJson getCheck = do creds <- maybeCreds - applyLayoutJson "Authentication Status" - (return ()) (html creds) (json creds) + applyLayoutJson "Authentication Status" mempty (html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status @@ -289,7 +289,7 @@ getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster - applyLayout "Register a new account" (return ()) [$hamlet| + applyLayout "Register a new account" mempty [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.EmailRegisterR@ %label!for=email E-mail @@ -314,7 +314,7 @@ postEmailRegisterR = do tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl - applyLayout "Confirmation e-mail sent" (return ()) [$hamlet| + applyLayout "Confirmation e-mail sent" mempty [$hamlet| %p A confirmation e-mail has been sent to $cs.email$. |] @@ -333,7 +333,7 @@ getEmailVerifyR lid key = do setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> applyLayout "Invalid verification key" (return ()) [$hamlet| + _ -> applyLayout "Invalid verification key" mempty [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -342,7 +342,7 @@ getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster msg <- getMessage - applyLayout "Login" (return ()) [$hamlet| + applyLayout "Login" mempty [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account. @@ -396,7 +396,7 @@ getEmailPasswordR = do setMessage $ cs "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage - applyLayout "Set password" (return ()) [$hamlet| + applyLayout "Set password" mempty [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 443209b3..077d038b 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -53,7 +53,7 @@ data SitemapUrl url = SitemapUrl sitemapNS :: HtmlContent sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" -template :: [SitemapUrl url] -> Hamlet url IO () +template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet| %urlset!xmlns=$sitemapNS$ $forall urls url diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 80bbebcd..4f63fd28 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -9,9 +9,7 @@ module Yesod.Json -- * Generate Json output , jsonScalar , jsonList - , jsonList' , jsonMap - , jsonMap' #if TEST , testSuite #endif @@ -19,15 +17,14 @@ module Yesod.Json where import Text.Hamlet.Monad -import Control.Applicative -import Data.Text (pack) -import qualified Data.Text as T +import qualified Data.ByteString.Char8 as S8 import Data.Char (isControl) import Yesod.Hamlet -import Control.Monad (when) import Yesod.Handler import Web.Routes.Quasi (Routes) import Numeric (showHex) +import Data.Monoid (Monoid (..)) +import Data.Convertible.Text (cs) #if TEST import Test.Framework (testGroup, Test) @@ -46,17 +43,17 @@ import Yesod.Content -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json url a = Json { unJson :: Hamlet url IO a } - deriving (Functor, Applicative, Monad) +newtype Json url = Json { unJson :: Hamlet url } + deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json (Routes master) () -> GHandler sub master Content +jsonToContent :: Json (Routes master) -> GHandler sub master Content jsonToContent = hamletToContent . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson +jsonToRepJson :: Json (Routes master) -> GHandler sub master RepJson jsonToRepJson = fmap RepJson . jsonToContent -- | Outputs a single scalar. This function essentially: @@ -66,13 +63,14 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: HtmlContent -> Json url () -jsonScalar s = Json $ do - outputString "\"" - output $ encodeJson $ htmlContentToText s - outputString "\"" +jsonScalar :: HtmlContent -> Json url +jsonScalar s = Json $ mconcat + [ outputString "\"" + , output $ encodeJson $ htmlContentToByteString s + , outputString "\"" + ] where - encodeJson = T.concatMap (T.pack . encodeJsonChar) + encodeJson = S8.concatMap (S8.pack . encodeJsonChar) encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f" @@ -90,38 +88,33 @@ jsonScalar s = Json $ do encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json url ()] -> Json url () -jsonList = jsonList' . fromList - --- | Same as 'jsonList', but uses an 'Enumerator' for input. -jsonList' :: Enumerator (Json url ()) (Json url) -> Json url () -jsonList' (Enumerator enum) = do - Json $ outputString "[" - _ <- enum go False - Json $ outputString "]" +jsonList :: [Json url] -> Json url +jsonList [] = Json $ outputOctets "[]" +jsonList (x:xs) = mconcat + [ Json $ outputOctets "[" + , x + , mconcat $ map go xs + , Json $ outputOctets "]" + ] where - go putComma j = do - when putComma $ Json $ outputString "," - () <- j - return $ Right True + go j = mappend (Json $ outputOctets ",") j -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json url ())] -> Json url () -jsonMap = jsonMap' . fromList - --- | Same as 'jsonMap', but uses an 'Enumerator' for input. -jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url () -jsonMap' (Enumerator enum) = do - Json $ outputString "{" - _ <- enum go False - Json $ outputString "}" +jsonMap :: [(String, Json url)] -> Json url +jsonMap [] = Json $ outputOctets "{}" +jsonMap (x:xs) = mconcat + [ Json $ outputOctets "{" + , go x + , mconcat $ map go' xs + , Json $ outputOctets "}" + ] where - go putComma (k, v) = do - when putComma $ Json $ outputString "," - jsonScalar $ Unencoded $ pack k - Json $ outputString ":" - () <- v - return $ Right True + go' y = mappend (Json $ outputOctets ",") $ go y + go (k, v) = mconcat + [ jsonScalar $ Unencoded $ cs k + , Json $ outputOctets ":" + , v + ] #if TEST diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8cff093..be3679ee 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -21,6 +21,7 @@ import qualified Network.Wai as W import Yesod.Json import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile, Key) +import Data.Monoid (mempty) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -93,8 +94,8 @@ class Yesod a where -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ head - -> Hamlet (Routes master) IO () -- ^ body + -> Hamlet (Routes master) -- ^ head + -> Hamlet (Routes master) -- ^ body -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent @@ -107,9 +108,9 @@ applyLayout t h b = -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ head - -> Hamlet (Routes master) IO () -- ^ body - -> Json (Routes master) () + -> Hamlet (Routes master) -- ^ head + -> Hamlet (Routes master) -- ^ body + -> Json (Routes master) -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do html' <- defaultLayout PageContent @@ -122,9 +123,9 @@ applyLayoutJson t h html json = do applyLayout' :: Yesod master => String -- ^ title - -> Hamlet (Routes master) IO () -- ^ body + -> Hamlet (Routes master) -- ^ body -> GHandler sub master ChooseRep -applyLayout' s = fmap chooseRep . applyLayout s (return ()) +applyLayout' s = fmap chooseRep . applyLayout s mempty -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y diff --git a/yesod.cabal b/yesod.cabal index 3d4d0e34..493ae705 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -42,7 +42,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.3 && < 0.4, - hamlet >= 0.2.2 && < 0.3, + hamlet >= 0.3.0 && < 0.4, transformers >= 0.1 && < 0.3, clientsession >= 0.4.0 && < 0.5, MonadCatchIO-transformers >= 0.1 && < 0.3, From 7262c30c74ac0f17560f61f6fdc3051bbd343c82 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 6 Jun 2010 21:50:27 +0300 Subject: [PATCH 269/624] More sophisticated subsite support --- Yesod.hs | 4 ---- Yesod/Dispatch.hs | 42 ++++++++++++++++++++++++++++++++---------- Yesod/Form.hs | 4 ---- Yesod/Handler.hs | 8 ++------ Yesod/Request.hs | 4 ---- yesod.cabal | 2 +- 6 files changed, 35 insertions(+), 29 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 0bbf0572..95e68086 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -33,9 +33,5 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import Data.Convertible.Text (cs) -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class (liftIO) -#else -import "transformers" Control.Monad.Trans (liftIO) -#endif import Web.Routes.Quasi (Routes) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0056203a..800231f8 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -31,6 +31,7 @@ import Yesod.Internal import Web.Routes.Quasi import Language.Haskell.TH.Syntax +import Data.List (nub) import qualified Network.Wai as W import qualified Network.Wai.Enumerator as W @@ -46,7 +47,7 @@ import qualified Data.ByteString.Char8 as B import Web.Routes (encodePathInfo) import Control.Concurrent.MVar -import Control.Arrow ((***)) +import Control.Arrow ((***), first) import Data.Convertible.Text (cs) import Data.Time @@ -76,7 +77,7 @@ import Yesod.Content mkYesod :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec] -mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] False +mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] [] False -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. @@ -84,11 +85,13 @@ mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] False -- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype - -> [Name] -- ^ a list of classes the master datatype must be an instance of + -> [(String, [Name])] -> [Resource] -> Q [Dec] mkYesodSub name clazzes = - fmap (\(x, y) -> x ++ y) . mkYesodGeneral name clazzes True + fmap (\(x, y) -> x ++ y) . mkYesodGeneral name' rest clazzes True + where + (name':rest) = words name -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a @@ -96,7 +99,7 @@ mkYesodSub name clazzes = -- 'mkYesodDispatch', do just that. mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do - (x, _) <- mkYesodGeneral name [] False res + (x, _) <- mkYesodGeneral name [] [] False res let rname = mkName $ "resources" ++ name eres <- liftResources res let y = [ SigD rname $ ListT `AppT` ConT ''Resource @@ -106,7 +109,7 @@ mkYesodData name res = do -- | See 'mkYesodData'. mkYesodDispatch :: String -> [Resource] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False +mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False explodeHandler :: HasReps c => GHandler sub master c @@ -120,25 +123,44 @@ explodeHandler :: HasReps c -> YesodApp explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f -mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q ([Dec], [Dec]) -mkYesodGeneral name clazzes isSub res = do +mkYesodGeneral :: String -- ^ argument name + -> [String] -- ^ parameters for site argument + -> [(String, [Name])] -- ^ classes + -> Bool -- ^ is subsite? + -> [Resource] + -> Q ([Dec], [Dec]) +mkYesodGeneral name args clazzes isSub res = do let name' = mkName name + args' = map mkName args + arg = foldl AppT (ConT $ name') $ map VarT args' let site = mkName $ "site" ++ name let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] + let clazzes' = compact + $ map (\x -> (x, [])) ("master" : args) ++ + clazzes explode <- [|explodeHandler|] QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp - , crArgument = ConT $ mkName name + , crArgument = arg , crExplode = explode , crResources = res , crSite = site - , crMaster = if isSub then Right clazzes else Left (ConT name') + , crMaster = if isSub + then Right clazzes' + else Left (ConT name') } return ([w, x], (if isSub then id else (:) yes) [y, z]) +compact :: [(String, [a])] -> [(String, [a])] +compact [] = [] +compact ((x, x'):rest) = + let ys = filter (\(y, _) -> y == x) rest + zs = filter (\(z, _) -> z /= x) rest + in (x, x' ++ concatMap snd ys) : compact zs + sessionName :: String sessionName = "_SESSION" diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 9c3922b6..acacbb86 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -26,11 +26,7 @@ import Control.Applicative hiding (optional) import Data.Time (Day) import Data.Convertible.Text import Data.Maybe (fromMaybe) -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class -#else -import "transformers" Control.Monad.Trans -#endif import Yesod.Internal import Control.Monad.Attempt diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f4c8a0db..d79a99dd 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -76,13 +76,9 @@ import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E import Control.Applicative -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class -#else -import "transformers" Control.Monad.Trans -#endif -import qualified Control.Monad.CatchIO as C -import Control.Monad.CatchIO (catch) +import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C +import "MonadCatchIO-transformers" Control.Monad.CatchIO (catch) import Control.Monad (liftM, ap) import System.IO diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5dcddc80..10c9ef10 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -42,11 +42,7 @@ module Yesod.Request import qualified Network.Wai as W import qualified Data.ByteString.Lazy as BL -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class -#else -import "transformers" Control.Monad.Trans -#endif import Control.Monad (liftM) import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r diff --git a/yesod.cabal b/yesod.cabal index 493ae705..c164a0ec 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -41,7 +41,7 @@ library convertible-text >= 0.3.0 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.3 && < 0.4, + web-routes-quasi >= 0.4 && < 0.5, hamlet >= 0.3.0 && < 0.4, transformers >= 0.1 && < 0.3, clientsession >= 0.4.0 && < 0.5, From 2947c3b4b6c8618706f09c8709138520deb24d3c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 6 Jun 2010 21:55:48 +0300 Subject: [PATCH 270/624] Initial inclusion of persistent support --- Yesod/Contrib.hs | 9 ++ Yesod/Contrib/Crud.hs | 172 ++++++++++++++++++++++++++++++++++++++ Yesod/Contrib/Formable.hs | 114 +++++++++++++++++++++++++ Yesod/Contrib/Persist.hs | 8 ++ Yesod/Helpers/Auth.hs | 2 +- yesod.cabal | 9 +- 6 files changed, 312 insertions(+), 2 deletions(-) create mode 100644 Yesod/Contrib.hs create mode 100644 Yesod/Contrib/Crud.hs create mode 100644 Yesod/Contrib/Formable.hs create mode 100644 Yesod/Contrib/Persist.hs diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs new file mode 100644 index 00000000..bfbca604 --- /dev/null +++ b/Yesod/Contrib.hs @@ -0,0 +1,9 @@ +module Yesod.Contrib + ( module Yesod.Contrib.Formable + , module Yesod.Contrib.Crud + , module Yesod.Contrib.Persist + ) where + +import Yesod.Contrib.Formable +import Yesod.Contrib.Crud +import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs new file mode 100644 index 00000000..2d1cb1dd --- /dev/null +++ b/Yesod/Contrib/Crud.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +module Yesod.Contrib.Crud where + +import Yesod hiding (Form) +import Database.Persist +import Control.Applicative.Error +import Yesod.Contrib.Formable +import Yesod.Contrib.Persist +import Text.Formlets +import Control.Arrow (second) +import Data.Monoid (mempty) + +runForm :: Form xml (GHandler sub y) a -> GHandler sub y (Failing a, xml) +runForm f = do + req <- getRequest + (pp, _) <- liftIO $ reqRequestBody req + let env = map (second Left) pp + let (a, b, _) = runFormState env f + a' <- a + return (a', b) + +class Formable a => Item a where + itemTitle :: a -> String + +data Crud master item = Crud + { crudSelect :: GHandler (Crud master item) master [(Key item, item)] + , crudReplace :: Key item -> item -> GHandler (Crud master item) master () + , crudInsert :: item -> GHandler (Crud master item) master (Key item) + , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) + , crudDelete :: Key item -> GHandler (Crud master item) master () + } + +mkYesodSub "Crud master item" + [ ("master", [''Yesod]) + , ("item", [''Item]) + , ("Key item", [''SinglePiece]) + ] [$parseRoutes| +/ CrudListR GET +/add CrudAddR GET POST +/edit/#String CrudEditR GET POST +/delete/#String CrudDeleteR GET POST +|] + +getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +getCrudListR = do + items <- getYesodSub >>= crudSelect + toMaster <- getRouteToMaster + applyLayout "Items" mempty [$hamlet| +%h1 Items +%ul + $forall items item + %li + %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ + $cs.itemTitle.snd.item$ +%p + %a!href=@toMaster.CrudAddR@ Add new item +|] + +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +getCrudAddR = crudHelper + "Add new" + (Nothing :: Maybe (Key item, item)) + False + +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) + => GHandler (Crud master item) master RepHtml +postCrudAddR = crudHelper + "Add new" + (Nothing :: Maybe (Key item, item)) + True + +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +getCrudEditR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + crudHelper + "Edit item" + (Just (itemId, item)) + False + +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +postCrudEditR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + crudHelper + "Edit item" + (Just (itemId, item)) + False + +getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +getCrudDeleteR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + item <- crudGet crud itemId >>= maybe notFound return + toMaster <- getRouteToMaster + applyLayout "Confirm delete" mempty [$hamlet| +%form!method=post!action=@toMaster.CrudDeleteR.s@ + %h1 Really delete? + %p + %input!type=submit!value=Yes + \ + %a!href=@toMaster.CrudListR@ No +|] + +postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) + => String -> GHandler (Crud master item) master RepHtml +postCrudDeleteR s = do + itemId <- maybe notFound return $ itemReadId s + crud <- getYesodSub + toMaster <- getRouteToMaster + crudDelete crud itemId + redirect RedirectTemporary $ toMaster CrudListR + +itemReadId :: SinglePiece x => String -> Maybe x +itemReadId = either (const Nothing) Just . fromSinglePiece + +crudHelper + :: (Item a, Yesod master, SinglePiece (Key a)) + => String -> Maybe (Key a, a) -> Bool + -> GHandler (Crud master a) master RepHtml +crudHelper title me isPost = do + crud <- getYesodSub + (errs, form) <- runForm $ formable $ fmap snd me + toMaster <- getRouteToMaster + errs' <- case (isPost, errs) of + (True, Success a) -> do + eid <- case me of + Just (eid, _) -> do + crudReplace crud eid a + return eid + Nothing -> crudInsert crud a + redirect RedirectTemporary $ toMaster $ CrudEditR + $ toSinglePiece eid + (True, Failure e) -> return $ Just e + (False, _) -> return Nothing + applyLayout title mempty [$hamlet| +%p + %a!href=@toMaster.CrudListR@ Return to list +%h1 $cs.title$ +$maybe errs' es + %ul + $forall es e + %li $cs.e$ +%form!method=post + %table + ^form^ + %tr + %td!colspan=2 + %input!type=submit + $maybe me e + \ + %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete +|] + +defaultCrud :: (Persist i (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) + => a -> Crud a i +defaultCrud = const $ Crud + { crudSelect = runDB $ select [] [] + , crudReplace = \a -> runDB . replace a + , crudInsert = runDB . insert + , crudGet = runDB . get + , crudDelete = runDB . delete + } diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs new file mode 100644 index 00000000..5e2f0264 --- /dev/null +++ b/Yesod/Contrib/Formable.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Contrib.Formable where + +import Text.Formlets +import Text.Hamlet +import Text.Hamlet.Monad (htmlContentToByteString) +import Data.Time (Day) +import Control.Applicative +import Control.Applicative.Error +import Web.Routes.Quasi (SinglePiece) +import Database.Persist (Persistable) +import Data.Char (isAlphaNum) +import Language.Haskell.TH.Syntax +import Database.Persist (Table (..)) +import Database.Persist.Helper (upperFirst) +import Data.Convertible.Text (cs) + +class Formable a where + formable :: (Functor m, Applicative m, Monad m) + => Formlet (Hamlet url) m a + +class Fieldable a where + fieldable :: (Functor m, Applicative m, Monad m) + => String -> Formlet (Hamlet url) m a + +pack' :: String -> HtmlContent +pack' = Unencoded . cs + +instance Fieldable [Char] where + fieldable label = input' go + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=text!name=$pack'.name$!value=$pack'.val$ +|] + +instance Fieldable HtmlContent where + fieldable label = + fmap (Encoded . cs) + . input' go + . fmap (cs . htmlContentToByteString) + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %textarea!name=$pack'.name$ + $pack'.val$ +|] + +instance Fieldable Day where + fieldable label x = input' go (fmap show x) `check` asDay + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=date!name=$pack'.name$!value=$pack'.val$ +|] + asDay s = maybeRead' s "Invalid day" + +newtype Slug = Slug { unSlug :: String } + deriving (Read, Eq, Show, SinglePiece, Persistable) + +instance Fieldable Slug where + fieldable label x = input' go (fmap unSlug x) `check` asSlug + where + go name val = [$hamlet| +%tr + %th $pack'.label$ + %td + %input!type=text!name=$pack'.name$!value=$pack'.val$ +|] + asSlug [] = Failure ["Slug must be non-empty"] + asSlug x' + | all (\c -> c `elem` "-_" || isAlphaNum c) x' = + Success $ Slug x' + | otherwise = Failure ["Slug must be alphanumeric, - and _"] + +share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] +share2 f g a = do + f' <- f a + g' <- g a + return $ f' ++ g' + +deriveFormable :: [Table] -> Q [Dec] +deriveFormable = mapM derive + where + derive :: Table -> Q Dec + derive t = do + let cols = map (upperFirst . fst) $ tableColumns t + ap <- [|(<*>)|] + just <- [|pure|] + nothing <- [|Nothing|] + let just' = just `AppE` ConE (mkName $ tableName t) + let c1 = Clause [ConP (mkName "Nothing") []] + (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + [] + xs <- mapM (const $ newName "x") cols + let xs' = map (AppE just . VarE) xs + let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t) + $ map VarP xs]] + (NormalB $ go ap just' $ zip cols xs') + [] + return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) + [FunD (mkName "formable") [c1, c2]] + go ap just' = foldl (ap' ap) just' . map go' + go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex + ap' ap x y = InfixE (Just x) ap (Just y) diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs new file mode 100644 index 00000000..a009ff5a --- /dev/null +++ b/Yesod/Contrib/Persist.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +module Yesod.Contrib.Persist where + +import Yesod + +class YesodPersist y where + type YesodDB y :: (* -> *) -> * -> * + runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 0cef2369..72f628ab 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -138,7 +138,7 @@ maybeCreds = do (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| +mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET diff --git a/yesod.cabal b/yesod.cabal index c164a0ec..d475db1b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,10 @@ library random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, - old-locale >= 1.0.0.2 && < 1.1 + old-locale >= 1.0.0.2 && < 1.1, + formlets >= 0.7.1 && < 0.8, + applicative-extras >= 0.1.6 && < 0.2, + persistent >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch @@ -65,6 +68,10 @@ library Yesod.Helpers.Auth Yesod.Helpers.Sitemap Yesod.Helpers.Static + Yesod.Contrib + Yesod.Contrib.Crud + Yesod.Contrib.Formable + Yesod.Contrib.Persist ghc-options: -Wall executable runtests From 46b6dda08428ec6775ce31bf9f264ce9f03ec4db Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Jun 2010 19:55:35 +0300 Subject: [PATCH 271/624] Added delete confirmation line for crud --- Yesod/Contrib/Crud.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index 2d1cb1dd..0dea88d0 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -105,6 +105,7 @@ getCrudDeleteR s = do applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? + %p Do you really want to delete $cs.itemTitle.item$? %p %input!type=submit!value=Yes \ From a2d2192b9c188174d1bda7fc7a5374bd96347685 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Jun 2010 21:51:55 +0300 Subject: [PATCH 272/624] Compile with newest Hamlet --- Yesod/Contrib/Formable.hs | 29 ++++++++++++-------------- Yesod/Hamlet.hs | 17 ++++++--------- Yesod/Handler.hs | 9 ++++---- Yesod/Helpers/AtomFeed.hs | 6 ++---- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Json.hs | 44 +++++++++++++++++++-------------------- Yesod/Yesod.hs | 4 ++-- 7 files changed, 50 insertions(+), 61 deletions(-) diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 5e2f0264..8e0dbeea 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -2,11 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} module Yesod.Contrib.Formable where import Text.Formlets import Text.Hamlet -import Text.Hamlet.Monad (htmlContentToByteString) import Data.Time (Day) import Control.Applicative import Control.Applicative.Error @@ -26,31 +26,28 @@ class Fieldable a where fieldable :: (Functor m, Applicative m, Monad m) => String -> Formlet (Hamlet url) m a -pack' :: String -> HtmlContent -pack' = Unencoded . cs - instance Fieldable [Char] where fieldable label = input' go where go name val = [$hamlet| %tr - %th $pack'.label$ + %th $string.label$ %td - %input!type=text!name=$pack'.name$!value=$pack'.val$ + %input!type=text!name=$string.name$!value=$string.val$ |] -instance Fieldable HtmlContent where +instance Fieldable Html where fieldable label = - fmap (Encoded . cs) + fmap preEscapedString . input' go - . fmap (cs . htmlContentToByteString) + . fmap (cs . renderHtml) where go name val = [$hamlet| %tr - %th $pack'.label$ + %th $string.label$ %td - %textarea!name=$pack'.name$ - $pack'.val$ + %textarea!name=$string.name$ + $string.val$ |] instance Fieldable Day where @@ -58,9 +55,9 @@ instance Fieldable Day where where go name val = [$hamlet| %tr - %th $pack'.label$ + %th $string.label$ %td - %input!type=date!name=$pack'.name$!value=$pack'.val$ + %input!type=date!name=$string.name$!value=$string.val$ |] asDay s = maybeRead' s "Invalid day" @@ -72,9 +69,9 @@ instance Fieldable Slug where where go name val = [$hamlet| %tr - %th $pack'.label$ + %th $string.label$ %td - %input!type=text!name=$pack'.name$!value=$pack'.val$ + %input!type=text!name=$string.name$!value=$string.val$ |] asSlug [] = Failure ["Slug must be non-empty"] asSlug x' diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 34222a33..e2c7f971 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -5,10 +5,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( -- * Hamlet library - Hamlet - , hamlet - , HtmlContent (..) - , htmlContentToByteString + module Text.Hamlet -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -18,8 +15,6 @@ module Yesod.Hamlet where import Text.Hamlet -import Text.Hamlet.Monad ( outputHtml, hamletToByteString - , htmlContentToByteString) import Yesod.Content import Yesod.Handler import Data.Convertible.Text @@ -30,7 +25,7 @@ import Web.Routes.Quasi (Routes) -- -- > PageContent url -> Hamlet url data PageContent url = PageContent - { pageTitle :: HtmlContent + { pageTitle :: Html , pageHead :: Hamlet url , pageBody :: Hamlet url } @@ -40,13 +35,13 @@ data PageContent url = PageContent hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender - return $ toContent $ hamletToByteString render h + return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent instance ConvertSuccess String (Hamlet url) where - convertSuccess = outputHtml . Unencoded . cs -instance ConvertSuccess String HtmlContent where - convertSuccess = Unencoded . cs + convertSuccess = const . string +instance ConvertSuccess String Html where + convertSuccess = string diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d79a99dd..5a09a08c 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -70,7 +70,6 @@ import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) -import Text.Hamlet.Monad (htmlContentToByteString) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -326,17 +325,17 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: HtmlContent -> GHandler sub master () -setMessage = setSession msgKey . cs . htmlContentToByteString +setMessage :: Html -> GHandler sub master () +setMessage = setSession msgKey . cs . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe HtmlContent) +getMessage :: GHandler sub master (Maybe Html) getMessage = do clearSession msgKey - fmap (fmap $ Encoded . cs) $ lookupSession msgKey + fmap (fmap $ preEscapedString . cs) $ lookupSession msgKey -- | Bypass remaining handler code and output the given file. -- diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 85cd0bbc..2eb8514a 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -24,8 +24,6 @@ module Yesod.Helpers.AtomFeed import Yesod import Data.Time.Clock (UTCTime) -import Text.Hamlet.Monad -import Text.Hamlet.Quasi newtype RepAtom = RepAtom Content instance HasReps RepAtom where @@ -46,10 +44,10 @@ data AtomFeedEntry url = AtomFeedEntry { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String - , atomEntryContent :: HtmlContent + , atomEntryContent :: Html } -xmlns :: AtomFeed url -> HtmlContent +xmlns :: AtomFeed url -> Html xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 077d038b..89890e32 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -50,7 +50,7 @@ data SitemapUrl url = SitemapUrl , priority :: Double } -sitemapNS :: HtmlContent +sitemapNS :: Html sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" template :: [SitemapUrl url] -> Hamlet url diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 4f63fd28..51716943 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -16,7 +16,6 @@ module Yesod.Json ) where -import Text.Hamlet.Monad import qualified Data.ByteString.Char8 as S8 import Data.Char (isControl) import Yesod.Hamlet @@ -25,6 +24,7 @@ import Web.Routes.Quasi (Routes) import Numeric (showHex) import Data.Monoid (Monoid (..)) import Data.Convertible.Text (cs) +import Text.Hamlet #if TEST import Test.Framework (testGroup, Test) @@ -43,17 +43,17 @@ import Yesod.Content -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json url = Json { unJson :: Hamlet url } +newtype Json = Json { unJson :: Html } deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json (Routes master) -> GHandler sub master Content -jsonToContent = hamletToContent . unJson +jsonToContent :: Json -> GHandler sub master Content +jsonToContent = return . toContent . renderHtml . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json (Routes master) -> GHandler sub master RepJson +jsonToRepJson :: Json -> GHandler sub master RepJson jsonToRepJson = fmap RepJson . jsonToContent -- | Outputs a single scalar. This function essentially: @@ -63,14 +63,14 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: HtmlContent -> Json url +jsonScalar :: Html -> Json jsonScalar s = Json $ mconcat - [ outputString "\"" - , output $ encodeJson $ htmlContentToByteString s - , outputString "\"" + [ preEscapedString "\"" + , preEscapedString $ encodeJson $ cs $ renderHtml s + , preEscapedString "\"" ] where - encodeJson = S8.concatMap (S8.pack . encodeJsonChar) + encodeJson = concatMap encodeJsonChar encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f" @@ -88,31 +88,31 @@ jsonScalar s = Json $ mconcat encodeJsonChar c = [c] -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json url] -> Json url -jsonList [] = Json $ outputOctets "[]" +jsonList :: [Json] -> Json +jsonList [] = Json $ preEscapedString "[]" jsonList (x:xs) = mconcat - [ Json $ outputOctets "[" + [ Json $ preEscapedString "[" , x , mconcat $ map go xs - , Json $ outputOctets "]" + , Json $ preEscapedString "]" ] where - go j = mappend (Json $ outputOctets ",") j + go j = mappend (Json $ preEscapedString ",") j -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json url)] -> Json url -jsonMap [] = Json $ outputOctets "{}" +jsonMap :: [(String, Json)] -> Json +jsonMap [] = Json $ preEscapedString "{}" jsonMap (x:xs) = mconcat - [ Json $ outputOctets "{" + [ Json $ preEscapedString "{" , go x , mconcat $ map go' xs - , Json $ outputOctets "}" + , Json $ preEscapedString "}" ] where - go' y = mappend (Json $ outputOctets ",") $ go y + go' y = mappend (Json $ preEscapedString ",") $ go y go (k, v) = mconcat - [ jsonScalar $ Unencoded $ cs k - , Json $ outputOctets ":" + [ jsonScalar $ string k + , Json $ preEscapedString ":" , v ] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index be3679ee..6afa19fc 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -110,7 +110,7 @@ applyLayoutJson :: Yesod master => String -- ^ title -> Hamlet (Routes master) -- ^ head -> Hamlet (Routes master) -- ^ body - -> Json (Routes master) + -> Json -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do html' <- defaultLayout PageContent @@ -135,7 +135,7 @@ defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $Unencoded.cs.pathInfo.r$ +%p $string.cs.pathInfo.r$ |] where pathInfo = W.pathInfo From 1236bbeb407746606421c2afc262922db2bc30fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Jun 2010 22:43:51 +0300 Subject: [PATCH 273/624] Local formlet implementation with inline error messages --- Yesod/Contrib.hs | 2 +- Yesod/Contrib/Crud.hs | 38 +++++------- Yesod/Contrib/Formable.hs | 124 +++++++++++++++++++++++++++++++++----- 3 files changed, 126 insertions(+), 38 deletions(-) diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs index bfbca604..a14027c0 100644 --- a/Yesod/Contrib.hs +++ b/Yesod/Contrib.hs @@ -4,6 +4,6 @@ module Yesod.Contrib , module Yesod.Contrib.Persist ) where -import Yesod.Contrib.Formable +import Yesod.Contrib.Formable hiding (runForm) import Yesod.Contrib.Crud import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index 0dea88d0..e9007167 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -6,20 +6,17 @@ module Yesod.Contrib.Crud where import Yesod hiding (Form) import Database.Persist import Control.Applicative.Error -import Yesod.Contrib.Formable +import Yesod.Contrib.Formable hiding (runForm) import Yesod.Contrib.Persist -import Text.Formlets import Control.Arrow (second) import Data.Monoid (mempty) -runForm :: Form xml (GHandler sub y) a -> GHandler sub y (Failing a, xml) +runForm :: SealedForm (Routes y) a + -> GHandler sub y (Maybe a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req - let env = map (second Left) pp - let (a, b, _) = runFormState env f - a' <- a - return (a', b) + return $ fst $ runIncr (runSealedForm f pp) 1 class Formable a => Item a where itemTitle :: a -> String @@ -100,7 +97,7 @@ getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudDeleteR s = do itemId <- maybe notFound return $ itemReadId s crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return + item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists toMaster <- getRouteToMaster applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ @@ -132,25 +129,20 @@ crudHelper title me isPost = do crud <- getYesodSub (errs, form) <- runForm $ formable $ fmap snd me toMaster <- getRouteToMaster - errs' <- case (isPost, errs) of - (True, Success a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - (True, Failure e) -> return $ Just e - (False, _) -> return Nothing + case (isPost, errs) of + (True, Just a) -> do + eid <- case me of + Just (eid, _) -> do + crudReplace crud eid a + return eid + Nothing -> crudInsert crud a + redirect RedirectTemporary $ toMaster $ CrudEditR + $ toSinglePiece eid + _ -> return () applyLayout title mempty [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $cs.title$ -$maybe errs' es - %ul - $forall es e - %li $cs.e$ %form!method=post %table ^form^ diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 8e0dbeea..b28a61df 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -5,7 +5,6 @@ {-# LANGUAGE TypeSynonymInstances #-} module Yesod.Contrib.Formable where -import Text.Formlets import Text.Hamlet import Data.Time (Day) import Control.Applicative @@ -17,23 +16,101 @@ import Language.Haskell.TH.Syntax import Database.Persist (Table (..)) import Database.Persist.Helper (upperFirst) import Data.Convertible.Text (cs) +import Control.Monad (liftM) +import Control.Arrow (first) +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, mappend) + +type Env = [(String, String)] + +newtype Incr a = Incr { runIncr :: Int -> (a, Int) } +incr :: Incr Int +incr = Incr $ \i -> (i + 1, i + 1) +instance Monad Incr where + return a = Incr $ \i -> (a, i) + Incr x >>= f = Incr $ \i -> + let (x', i') = x i + in runIncr (f x') i' + +data FormResult a = FormMissing + | FormFailure [String] + | FormSuccess a +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a + +newtype Form url a = Form + { runForm :: Env -> Incr (FormResult a, [String] -> Hamlet url) + } +type Formlet url a = Maybe a -> Form url a + +newtype SealedForm url a = SealedForm + { runSealedForm :: Env -> Incr (Maybe a, Hamlet url) + } +type SealedFormlet url a = Maybe a -> SealedForm url a +instance Functor (SealedForm url) where + fmap f (SealedForm g) = SealedForm + $ \env -> liftM (first $ fmap f) (g env) +instance Applicative (SealedForm url) where + pure a = SealedForm $ const $ return (Just a, mempty) + (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do + (f1, f2) <- f env + (g1, g2) <- g env + return (f1 <*> g1, f2 `mappend` g2) + +sealForm :: Form url a -> SealedForm url a +sealForm (Form form) = SealedForm $ \env -> liftM go (form env) + where + go (FormSuccess a, xml) = (Just a, xml []) + go (FormFailure errs, xml) = (Nothing, xml errs) + go (FormMissing, xml) = (Nothing, xml []) + +sealFormlet :: Formlet url a -> SealedFormlet url a +sealFormlet formlet initVal = sealForm $ formlet initVal + +instance Functor (Form url) where + fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) + +input' :: (String -> String -> [String] -> Hamlet url) + -> Maybe String + -> Form url String +input' mkXml val = Form $ \env -> do + i <- incr + let i' = show i + let param = lookup i' env + let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param + return (maybe FormMissing FormSuccess param, xml) + +check :: Form url a -> (a -> Either [String] b) -> Form url b +check (Form form) f = Form $ \env -> liftM (first go) (form env) + where + go FormMissing = FormMissing + go (FormFailure x) = FormFailure x + go (FormSuccess a) = + case f a of + Left errs -> FormFailure errs + Right b -> FormSuccess b class Formable a where - formable :: (Functor m, Applicative m, Monad m) - => Formlet (Hamlet url) m a + formable :: SealedFormlet url a class Fieldable a where - fieldable :: (Functor m, Applicative m, Monad m) - => String -> Formlet (Hamlet url) m a + fieldable :: String -> Formlet url a instance Fieldable [Char] where fieldable label = input' go where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=text!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] instance Fieldable Html where @@ -42,24 +119,36 @@ instance Fieldable Html where . input' go . fmap (cs . renderHtml) where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %textarea!name=$string.name$ $string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] instance Fieldable Day where fieldable label x = input' go (fmap show x) `check` asDay where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=date!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] - asDay s = maybeRead' s "Invalid day" + asDay s = case reads s of + (x, _):_ -> Right x + [] -> Left ["Invalid day"] newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) @@ -67,17 +156,22 @@ newtype Slug = Slug { unSlug :: String } instance Fieldable Slug where fieldable label x = input' go (fmap unSlug x) `check` asSlug where - go name val = [$hamlet| + go name val errs = [$hamlet| %tr %th $string.label$ %td %input!type=text!name=$string.name$!value=$string.val$ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ |] - asSlug [] = Failure ["Slug must be non-empty"] + asSlug [] = Left ["Slug must be non-empty"] asSlug x' | all (\c -> c `elem` "-_" || isAlphaNum c) x' = - Success $ Slug x' - | otherwise = Failure ["Slug must be alphanumeric, - and _"] + Right $ Slug x' + | otherwise = Left ["Slug must be alphanumeric, - and _"] share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do @@ -107,5 +201,7 @@ deriveFormable = mapM derive return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) [FunD (mkName "formable") [c1, c2]] go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = VarE (mkName "fieldable") `AppE` LitE (StringL label) `AppE` ex + go' (label, ex) = VarE (mkName "sealForm") `AppE` + (VarE (mkName "fieldable") + `AppE` LitE (StringL label) `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) From 3708445f7ae693d6cc4e30f3ba924025e04c5856 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Jun 2010 23:26:35 +0300 Subject: [PATCH 274/624] Cleaned up formlet interface slightly --- Yesod/Contrib/Formable.hs | 105 +++++++++++++++++--------------------- 1 file changed, 46 insertions(+), 59 deletions(-) diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index b28a61df..2c0ad1a6 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -8,7 +8,6 @@ module Yesod.Contrib.Formable where import Text.Hamlet import Data.Time (Day) import Control.Applicative -import Control.Applicative.Error import Web.Routes.Quasi (SinglePiece) import Database.Persist (Persistable) import Data.Char (isAlphaNum) @@ -41,7 +40,7 @@ instance Functor FormResult where fmap f (FormSuccess a) = FormSuccess $ f a newtype Form url a = Form - { runForm :: Env -> Incr (FormResult a, [String] -> Hamlet url) + { runForm :: Env -> Incr (FormResult a, Hamlet url) } type Formlet url a = Maybe a -> Form url a @@ -59,20 +58,22 @@ instance Applicative (SealedForm url) where (g1, g2) <- g env return (f1 <*> g1, f2 `mappend` g2) -sealForm :: Form url a -> SealedForm url a -sealForm (Form form) = SealedForm $ \env -> liftM go (form env) +sealForm :: ([String] -> Hamlet url -> Hamlet url) + -> Form url a -> SealedForm url a +sealForm wrapper (Form form) = SealedForm $ \env -> liftM go (form env) where - go (FormSuccess a, xml) = (Just a, xml []) - go (FormFailure errs, xml) = (Nothing, xml errs) - go (FormMissing, xml) = (Nothing, xml []) + go (FormSuccess a, xml) = (Just a, wrapper [] xml) + go (FormFailure errs, xml) = (Nothing, wrapper errs xml) + go (FormMissing, xml) = (Nothing, wrapper [] xml) -sealFormlet :: Formlet url a -> SealedFormlet url a -sealFormlet formlet initVal = sealForm $ formlet initVal +sealFormlet :: ([String] -> Hamlet url -> Hamlet url) + -> Formlet url a -> SealedFormlet url a +sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal instance Functor (Form url) where fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) -input' :: (String -> String -> [String] -> Hamlet url) +input' :: (String -> String -> Hamlet url) -> Maybe String -> Form url String input' mkXml val = Form $ \env -> do @@ -96,16 +97,13 @@ class Formable a where formable :: SealedFormlet url a class Fieldable a where - fieldable :: String -> Formlet url a + fieldable :: Formlet url a -instance Fieldable [Char] where - fieldable label = input' go - where - go name val errs = [$hamlet| +wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url +wrapperRow label errs control = [$hamlet| %tr %th $string.label$ - %td - %input!type=text!name=$string.name$!value=$string.val$ + %td ^control^ $if not.null.errs %td.errors %ul @@ -113,59 +111,36 @@ instance Fieldable [Char] where %li $string.err$ |] +instance Fieldable [Char] where + fieldable = input' go + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + instance Fieldable Html where - fieldable label = - fmap preEscapedString - . input' go - . fmap (cs . renderHtml) + fieldable = fmap preEscapedString . input' go . fmap (cs . renderHtml) where - go name val errs = [$hamlet| -%tr - %th $string.label$ - %td - %textarea!name=$string.name$ - $string.val$ - $if not.null.errs - %td.errors - %ul - $forall errs err - %li $string.err$ -|] + go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] instance Fieldable Day where - fieldable label x = input' go (fmap show x) `check` asDay + fieldable x = input' go (fmap show x) `check` asDay where - go name val errs = [$hamlet| -%tr - %th $string.label$ - %td - %input!type=date!name=$string.name$!value=$string.val$ - $if not.null.errs - %td.errors - %ul - $forall errs err - %li $string.err$ + go name val = [$hamlet| +%input!type=date!name=$string.name$!value=$string.val$ |] asDay s = case reads s of - (x, _):_ -> Right x + (y, _):_ -> Right y [] -> Left ["Invalid day"] newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) instance Fieldable Slug where - fieldable label x = input' go (fmap unSlug x) `check` asSlug + fieldable x = input' go (fmap unSlug x) `check` asSlug where - go name val errs = [$hamlet| -%tr - %th $string.label$ - %td - %input!type=text!name=$string.name$!value=$string.val$ - $if not.null.errs - %td.errors - %ul - $forall errs err - %li $string.err$ + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ |] asSlug [] = Left ["Slug must be non-empty"] asSlug x' @@ -173,6 +148,17 @@ instance Fieldable Slug where Right $ Slug x' | otherwise = Left ["Slug must be alphanumeric, - and _"] +newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } + deriving (Read, Eq, Show, SinglePiece, Persistable) +instance Fieldable NonEmptyString where + fieldable x = input' go (fmap unNonEmptyString x) `check` notEmpty + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + notEmpty "" = Left ["Must be non-empty"] + notEmpty x = Right $ NonEmptyString x + share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do f' <- f a @@ -201,7 +187,8 @@ deriveFormable = mapM derive return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) [FunD (mkName "formable") [c1, c2]] go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = VarE (mkName "sealForm") `AppE` - (VarE (mkName "fieldable") - `AppE` LitE (StringL label) `AppE` ex) + go' (label, ex) = + VarE (mkName "sealForm") `AppE` + (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` + (VarE (mkName "fieldable") `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) From 2ba7dc6780333cea429c84b5b5008154bb232a22 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 8 Jun 2010 23:32:24 +0300 Subject: [PATCH 275/624] SealedForm keeps list of errors --- Yesod/Contrib/Crud.hs | 4 ++-- Yesod/Contrib/Formable.hs | 17 +++++++++++------ 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index e9007167..e2a9e791 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -12,7 +12,7 @@ import Control.Arrow (second) import Data.Monoid (mempty) runForm :: SealedForm (Routes y) a - -> GHandler sub y (Maybe a, Hamlet (Routes y)) + -> GHandler sub y (Either [String] a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req @@ -130,7 +130,7 @@ crudHelper title me isPost = do (errs, form) <- runForm $ formable $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of - (True, Just a) -> do + (True, Right a) -> do eid <- case me of Just (eid, _) -> do crudReplace crud eid a diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 2c0ad1a6..4046a976 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -45,26 +45,31 @@ newtype Form url a = Form type Formlet url a = Maybe a -> Form url a newtype SealedForm url a = SealedForm - { runSealedForm :: Env -> Incr (Maybe a, Hamlet url) + { runSealedForm :: Env -> Incr (Either [String] a, Hamlet url) } type SealedFormlet url a = Maybe a -> SealedForm url a instance Functor (SealedForm url) where fmap f (SealedForm g) = SealedForm $ \env -> liftM (first $ fmap f) (g env) instance Applicative (SealedForm url) where - pure a = SealedForm $ const $ return (Just a, mempty) + pure a = SealedForm $ const $ return (Right a, mempty) (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do (f1, f2) <- f env (g1, g2) <- g env - return (f1 <*> g1, f2 `mappend` g2) + return (f1 `apE` g1, f2 `mappend` g2) + where + apE (Left x) (Left y) = Left $ x ++ y + apE (Left x) _ = Left x + apE _ (Left y) = Left y + apE (Right x) (Right y) = Right $ x y sealForm :: ([String] -> Hamlet url -> Hamlet url) -> Form url a -> SealedForm url a sealForm wrapper (Form form) = SealedForm $ \env -> liftM go (form env) where - go (FormSuccess a, xml) = (Just a, wrapper [] xml) - go (FormFailure errs, xml) = (Nothing, wrapper errs xml) - go (FormMissing, xml) = (Nothing, wrapper [] xml) + go (FormSuccess a, xml) = (Right a, wrapper [] xml) + go (FormFailure errs, xml) = (Left errs, wrapper errs xml) + go (FormMissing, xml) = (Left [], wrapper [] xml) sealFormlet :: ([String] -> Hamlet url -> Hamlet url) -> Formlet url a -> SealedFormlet url a From 8a20a416bacafcba3d0726aa2c766cd9dd536ca6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 09:21:47 +0300 Subject: [PATCH 276/624] ContentType is a String --- Yesod/Content.hs | 142 +++++++++++++++++++------------------- Yesod/Dispatch.hs | 4 +- Yesod/Handler.hs | 4 +- Yesod/Helpers/AtomFeed.hs | 2 +- 4 files changed, 77 insertions(+), 75 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 09fcb028..8e2f6278 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -12,9 +12,20 @@ module Yesod.Content , toContent -- * Mime types -- ** Data type - , ContentType (..) - , contentTypeFromString - , contentTypeToString + , ContentType + , typeHtml + , typePlain + , typeJson + , typeXml + , typeAtom + , typeJpeg + , typePng + , typeGif + , typeJavascript + , typeCss + , typeFlv + , typeOgv + , typeOctet -- ** File extensions , typeByExt , ext @@ -124,7 +135,7 @@ instance HasReps ChooseRep where chooseRep = id instance HasReps () where - chooseRep = defChooseRep [(TypePlain, const $ return $ cs "")] + chooseRep = defChooseRep [(typePlain, const $ return $ cs "")] instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ @@ -134,73 +145,67 @@ instance HasReps [(ContentType, Content)] where (x:_) -> x _ -> error "chooseRep [(ContentType, Content)] of empty" where - go = simpleContentType . contentTypeToString + go = simpleContentType newtype RepHtml = RepHtml Content instance HasReps RepHtml where - chooseRep (RepHtml c) _ = return (TypeHtml, c) + chooseRep (RepHtml c) _ = return (typeHtml, c) newtype RepJson = RepJson Content instance HasReps RepJson where - chooseRep (RepJson c) _ = return (TypeJson, c) + chooseRep (RepJson c) _ = return (typeJson, c) data RepHtmlJson = RepHtmlJson Content Content instance HasReps RepHtmlJson where chooseRep (RepHtmlJson html json) = chooseRep - [ (TypeHtml, html) - , (TypeJson, json) + [ (typeHtml, html) + , (typeJson, json) ] newtype RepPlain = RepPlain Content instance HasReps RepPlain where - chooseRep (RepPlain c) _ = return (TypePlain, c) + chooseRep (RepPlain c) _ = return (typePlain, c) newtype RepXml = RepXml Content instance HasReps RepXml where - chooseRep (RepXml c) _ = return (TypeXml, c) + chooseRep (RepXml c) _ = return (typeXml, c) --- | Equality is determined by converting to a 'String' via --- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the --- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not* --- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8 --- encoded. See 'contentTypeToString'. -data ContentType = - TypeHtml - | TypePlain - | TypeJson - | TypeXml - | TypeAtom - | TypeJpeg - | TypePng - | TypeGif - | TypeJavascript - | TypeCss - | TypeFlv - | TypeOgv - | TypeOctet - | TypeOther String - deriving (Show) +type ContentType = String --- | This is simply a synonym for 'TypeOther'. However, equality works as --- expected; see 'ContentType'. -contentTypeFromString :: String -> ContentType -contentTypeFromString = TypeOther +typeHtml :: ContentType +typeHtml = "text/html; charset=utf-8" --- | This works as expected, with one caveat: the builtin textual content types --- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of --- their basic content-type. If another encoding is desired, please use --- 'TypeOther'. -contentTypeToString :: ContentType -> String -contentTypeToString TypeHtml = "text/html; charset=utf-8" -contentTypeToString TypePlain = "text/plain; charset=utf-8" -contentTypeToString TypeJson = "application/json; charset=utf-8" -contentTypeToString TypeXml = "text/xml" -contentTypeToString TypeAtom = "application/atom+xml" -contentTypeToString TypeJpeg = "image/jpeg" -contentTypeToString TypePng = "image/png" -contentTypeToString TypeGif = "image/gif" -contentTypeToString TypeJavascript = "text/javascript; charset=utf-8" -contentTypeToString TypeCss = "text/css; charset=utf-8" -contentTypeToString TypeFlv = "video/x-flv" -contentTypeToString TypeOgv = "video/ogg" -contentTypeToString TypeOctet = "application/octet-stream" -contentTypeToString (TypeOther s) = s +typePlain :: ContentType +typePlain = "text/plain; charset=utf-8" + +typeJson :: ContentType +typeJson = "application/json; charset=utf-8" + +typeXml :: ContentType +typeXml = "text/xml" + +typeAtom :: ContentType +typeAtom = "application/atom+xml" + +typeJpeg :: ContentType +typeJpeg = "image/jpeg" + +typePng :: ContentType +typePng = "image/png" + +typeGif :: ContentType +typeGif = "image/gif" + +typeJavascript :: ContentType +typeJavascript = "text/javascript; charset=utf-8" + +typeCss :: ContentType +typeCss = "text/css; charset=utf-8" + +typeFlv :: ContentType +typeFlv = "video/x-flv" + +typeOgv :: ContentType +typeOgv = "video/ogg" + +typeOctet :: ContentType +typeOctet = "application/octet-stream" -- | Removes \"extra\" information at the end of a content type string. In -- particular, removes everything after the semicolon, if present. @@ -210,22 +215,19 @@ contentTypeToString (TypeOther s) = s simpleContentType :: String -> String simpleContentType = fst . span (/= ';') -instance Eq ContentType where - (==) = (==) `on` contentTypeToString - -- | 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 +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 @@ -247,7 +249,7 @@ propExt s = caseTypeByExt :: Assertion caseTypeByExt = do TypeJavascript @=? typeByExt (ext "foo.js") - TypeHtml @=? typeByExt (ext "foo.html") + typeHtml @=? typeByExt (ext "foo.html") #endif -- | Format a 'UTCTime' in W3 format; useful for setting cookies. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 800231f8..df92d5f5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -233,7 +233,7 @@ toWaiApp' y segments env = do (cs sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs'' + hs''' = (W.ContentType, cs ct) : hs'' return $ W.Response s hs''' $ case c of ContentFile fp -> Left fp ContentEnum e -> Right $ W.buffer @@ -253,7 +253,7 @@ fullRender ar render route = ar ++ '/' : encodePathInfo (fixSegs $ render route) httpAccept :: W.Request -> [ContentType] -httpAccept = map (contentTypeFromString . B.unpack) +httpAccept = map B.unpack . parseHttpAccept . fromMaybe B.empty . lookup W.Accept diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 5a09a08c..40112214 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -234,7 +234,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers - return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession) + return (getRedirectStatus rt, hs, typePlain, cs "", finalSession) HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) @@ -242,7 +242,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.Status500, [], TypePlain, cs "Internal Server Error", []) + return (W.Status500, [], typePlain, cs "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 2eb8514a..eabc96c1 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -27,7 +27,7 @@ import Data.Time.Clock (UTCTime) newtype RepAtom = RepAtom Content instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (TypeAtom, c) + chooseRep (RepAtom c) _ = return (typeAtom, c) atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template From 7568bec3c44449f4d31711cff29b3aeb12582d1a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 09:28:26 +0300 Subject: [PATCH 277/624] ToContent typeclass --- Yesod/Content.hs | 37 ++++++++++++++++++++----------------- Yesod/Handler.hs | 10 +++++----- 2 files changed, 25 insertions(+), 22 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 8e2f6278..7b32e414 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -9,7 +9,8 @@ module Yesod.Content ( -- * Content Content (..) - , toContent + , emptyContent + , ToContent (..) -- * Mime types -- ** Data type , ContentType @@ -82,22 +83,24 @@ data Content = ContentFile FilePath -> 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 (IO Text) Content where - convertSuccess = swapEnum . WE.fromLBS' . fmap cs +emptyContent :: Content +emptyContent = ContentEnum $ \_ -> return . Right --- | A synonym for 'convertSuccess' to make the desired output type explicit. -toContent :: ConvertSuccess x Content => x -> Content -toContent = cs +class ToContent a where + toContent :: a -> Content + +instance ToContent B.ByteString where + toContent bs = ContentEnum $ \f a -> f a bs +instance ToContent L.ByteString where + toContent = swapEnum . WE.fromLBS +instance ToContent T.Text where + toContent t = toContent (cs t :: B.ByteString) +instance ToContent Text where + toContent lt = toContent (cs lt :: L.ByteString) +instance ToContent String where + toContent s = toContent (cs s :: L.ByteString) +instance ToContent (IO Text) where + toContent = swapEnum . WE.fromLBS' . fmap cs -- | A function which gives targetted representations of content based on the -- content-types the user accepts. @@ -135,7 +138,7 @@ instance HasReps ChooseRep where chooseRep = id instance HasReps () where - chooseRep = defChooseRep [(typePlain, const $ return $ cs "")] + chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 40112214..5364398e 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -224,9 +224,8 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs return (getStatus e, hs', ct, c, sess) - let sendFile' ct fp = do - c <- BL.readFile fp - return (W.Status200, headers, ct, cs c, finalSession) + let sendFile' ct fp = + return (W.Status200, headers, ct, ContentFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts @@ -234,7 +233,8 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers - return (getRedirectStatus rt, hs, typePlain, cs "", finalSession) + return (getRedirectStatus rt, hs, typePlain, emptyContent, + finalSession) HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) @@ -242,7 +242,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.Status500, [], typePlain, cs "Internal Server Error", []) + return (W.Status500, [], typePlain, toContent "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a From d57dc789832bbfb67d5c989b18aea96190ed0308 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 09:48:21 +0300 Subject: [PATCH 278/624] Removed convertible-text --- Yesod.hs | 2 -- Yesod/Content.hs | 15 ++++++++------- Yesod/Contrib/Crud.hs | 6 +++--- Yesod/Contrib/Formable.hs | 6 ++++-- Yesod/Dispatch.hs | 31 +++++++++++++++++++------------ Yesod/Form.hs | 7 +++++-- Yesod/Hamlet.hs | 6 ------ Yesod/Handler.hs | 9 +++++---- Yesod/Helpers/AtomFeed.hs | 10 +++++----- Yesod/Helpers/Auth.hs | 29 +++++++++++++++-------------- Yesod/Helpers/Sitemap.hs | 8 ++++---- Yesod/Helpers/Static.hs | 2 +- Yesod/Json.hs | 8 ++++---- Yesod/Yesod.hs | 18 +++++++++--------- yesod.cabal | 2 +- 15 files changed, 83 insertions(+), 76 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 95e68086..82afafb1 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -11,7 +11,6 @@ module Yesod , module Yesod.Hamlet , module Yesod.Json , Application - , cs , liftIO , Routes ) where @@ -32,6 +31,5 @@ import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet -import Data.Convertible.Text (cs) import "transformers" Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi (Routes) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 7b32e414..d388d6a7 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -54,7 +54,6 @@ 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.Convertible.Text import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE @@ -63,6 +62,10 @@ import Data.Function (on) import Data.Time import System.Locale +import qualified Data.Text.Encoding +import qualified Data.Text.Lazy.Encoding +import qualified Data.ByteString.Lazy.UTF8 + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit @@ -94,13 +97,11 @@ instance ToContent B.ByteString where instance ToContent L.ByteString where toContent = swapEnum . WE.fromLBS instance ToContent T.Text where - toContent t = toContent (cs t :: B.ByteString) + toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent lt = toContent (cs lt :: L.ByteString) + toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent s = toContent (cs s :: L.ByteString) -instance ToContent (IO Text) where - toContent = swapEnum . WE.fromLBS' . fmap cs + toContent = toContent . Data.ByteString.Lazy.UTF8.fromString -- | A function which gives targetted representations of content based on the -- content-types the user accepts. @@ -251,7 +252,7 @@ propExt s = caseTypeByExt :: Assertion caseTypeByExt = do - TypeJavascript @=? typeByExt (ext "foo.js") + typeJavascript @=? typeByExt (ext "foo.js") typeHtml @=? typeByExt (ext "foo.html") #endif diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index e2a9e791..0e3fd23b 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -51,7 +51,7 @@ getCrudListR = do $forall items item %li %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ - $cs.itemTitle.snd.item$ + $string.itemTitle.snd.item$ %p %a!href=@toMaster.CrudAddR@ Add new item |] @@ -102,7 +102,7 @@ getCrudDeleteR s = do applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? - %p Do you really want to delete $cs.itemTitle.item$? + %p Do you really want to delete $string.itemTitle.item$? %p %input!type=submit!value=Yes \ @@ -142,7 +142,7 @@ crudHelper title me isPost = do applyLayout title mempty [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list -%h1 $cs.title$ +%h1 $string.title$ %form!method=post %table ^form^ diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 4046a976..6bef2340 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -14,11 +14,11 @@ import Data.Char (isAlphaNum) import Language.Haskell.TH.Syntax import Database.Persist (Table (..)) import Database.Persist.Helper (upperFirst) -import Data.Convertible.Text (cs) import Control.Monad (liftM) import Control.Arrow (first) import Data.Maybe (fromMaybe) import Data.Monoid (mempty, mappend) +import qualified Data.ByteString.Lazy.UTF8 type Env = [(String, String)] @@ -124,7 +124,9 @@ instance Fieldable [Char] where |] instance Fieldable Html where - fieldable = fmap preEscapedString . input' go . fmap (cs . renderHtml) + fieldable = fmap preEscapedString + . input' go + . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index df92d5f5..2704e60c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -46,9 +46,11 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B import Web.Routes (encodePathInfo) +import qualified Data.ByteString.UTF8 as S +import qualified Data.ByteString.Lazy.UTF8 as L + import Control.Concurrent.MVar import Control.Arrow ((***), first) -import Data.Convertible.Text (cs) import Data.Time @@ -230,10 +232,10 @@ toWaiApp' y segments env = do (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName - (cs sessionVal) + (S.toString sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = (W.ContentType, cs ct) : hs'' + hs''' = (W.ContentType, S.fromString ct) : hs'' return $ W.Response s hs''' $ case c of ContentFile fp -> Left fp ContentEnum e -> Right $ W.buffer @@ -286,11 +288,13 @@ parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do - let gets' = map (cs *** cs) $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env - cookies' = map (cs *** cs) $ parseCookies reqCookie + let gets' = map (S.toString *** S.toString) + $ parseQueryString $ W.queryString env + let reqCookie = fromMaybe B.empty $ lookup W.Cookie + $ W.requestHeaders env + cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env - langs = map cs $ maybe [] parseHttpAccept acceptLang + langs = map S.toString $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey cookies' of Nothing -> langs Just x -> x : langs @@ -302,8 +306,9 @@ parseWaiRequest env session' = do 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) + fix1 = map (S.toString *** S.toString) + fix2 (x, FileInfo a b c) = + (S.toString x, FileInfo a b c) -- | 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 @@ -324,12 +329,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes - in (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires=" + in (W.SetCookie, S.fromString + $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) = - (W.SetCookie, cs $ + (W.SetCookie, S.fromString $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value) +headerToPair _ (Header key value) = + (W.responseHeaderFromBS $ S.fromString key, S.fromString value) encodeSession :: Key -> UTCTime -- ^ expire time diff --git a/Yesod/Form.hs b/Yesod/Form.hs index acacbb86..03f9c0fc 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -24,7 +24,6 @@ import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) -import Data.Convertible.Text import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Yesod.Internal @@ -107,7 +106,11 @@ notEmpty = applyForm $ \pv -> else Right pv checkDay :: Form ParamValue -> Form Day -checkDay = applyForm $ attempt (const (Left "Invalid day")) Right . ca +checkDay = applyForm $ maybe (Left "Invalid day") Right . readMay + where + readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing checkBool :: Form [ParamValue] -> Form Bool checkBool = applyForm $ \pv -> Right $ case pv of diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e2c7f971..41efd060 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -17,7 +17,6 @@ module Yesod.Hamlet import Text.Hamlet import Yesod.Content import Yesod.Handler -import Data.Convertible.Text import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create @@ -40,8 +39,3 @@ hamletToContent h = do -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent - -instance ConvertSuccess String (Hamlet url) where - convertSuccess = const . string -instance ConvertSuccess String Html where - convertSuccess = string diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 5364398e..2bd5efff 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -84,8 +84,9 @@ import System.IO import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W import Control.Monad.Attempt +import Data.ByteString.UTF8 (toString) +import qualified Data.ByteString.Lazy.UTF8 as L -import Data.Convertible.Text (cs) import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr) @@ -326,7 +327,7 @@ msgKey = "_MSG" -- -- See 'getMessage'. setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . cs . renderHtml +setMessage = setSession msgKey . L.toString . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. @@ -335,7 +336,7 @@ setMessage = setSession msgKey . cs . renderHtml getMessage :: GHandler sub master (Maybe Html) getMessage = do clearSession msgKey - fmap (fmap $ preEscapedString . cs) $ lookupSession msgKey + fmap (fmap preEscapedString) $ lookupSession msgKey -- | Bypass remaining handler code and output the given file. -- @@ -352,7 +353,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w + failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index eabc96c1..f108eaba 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -48,16 +48,16 @@ data AtomFeedEntry url = AtomFeedEntry } xmlns :: AtomFeed url -> Html -xmlns _ = cs "http://www.w3.org/2005/Atom" +xmlns _ = preEscapedString "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?> %feed!xmlns=$xmlns.arg$ - %title $cs.atomTitle.arg$ + %title $string.atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ %link!href=@atomLinkHome.arg@ - %updated $cs.formatW3.atomUpdated.arg$ + %updated $string.formatW3.atomUpdated.arg$ %id @atomLinkHome.arg@ $forall atomEntries.arg entry ^entryTemplate.entry^ @@ -68,7 +68,7 @@ entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@ - %updated $cs.formatW3.atomEntryUpdated.arg$ - %title $cs.atomEntryTitle.arg$ + %updated $string.formatW3.atomEntryUpdated.arg$ + %title $string.atomEntryTitle.arg$ %content!type=html $cdata.atomEntryContent.arg$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 72f628ab..c52da2d8 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -50,6 +50,7 @@ import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt import Data.Monoid (mempty) +import Data.ByteString.Lazy.UTF8 (fromString) class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other @@ -131,8 +132,8 @@ setCreds creds extra = do -- | Retrieves user credentials, if user is authenticated. maybeCreds :: RequestReader r => r (Maybe Creds) maybeCreds = do - mcs <- lookupSession credsKey - return $ mcs >>= readMay + mstring <- lookupSession credsKey + return $ mstring >>= readMay where readMay x = case reads x of (y, _):_ -> Just y @@ -188,7 +189,7 @@ getOpenIdForward = do res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> do - setMessage $ cs $ show err + setMessage $ string $ show err redirect RedirectTemporary $ toMaster OpenIdR) (redirectString RedirectTemporary) res @@ -201,7 +202,7 @@ getOpenIdComplete = do res <- runAttemptT $ OpenId.authenticate gets' toMaster <- getRouteToMaster let onFailure err = do - setMessage $ cs $ show err + setMessage $ string $ show err redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod @@ -255,12 +256,12 @@ getCheck = do $if isNothing.creds %p Not logged in $maybe creds c - %p Logged in as $cs.credsIdent.c$ + %p Logged in as $string.credsIdent.c$ |] json creds = jsonMap - [ ("ident", jsonScalar $ maybe (cs "") (cs . credsIdent) creds) - , ("displayName", jsonScalar $ cs $ fromMaybe "" + [ ("ident", jsonScalar $ maybe (string "") (string . credsIdent) creds) + , ("displayName", jsonScalar $ string $ fromMaybe "" $ creds >>= credsDisplayName) ] @@ -315,7 +316,7 @@ postEmailRegisterR = do let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl applyLayout "Confirmation e-mail sent" mempty [$hamlet| -%p A confirmation e-mail has been sent to $cs.email$. +%p A confirmation e-mail has been sent to $string.email$. |] checkEmail :: Form ParamValue -> Form ParamValue @@ -381,7 +382,7 @@ postEmailLoginR = do setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do - setMessage $ cs "Invalid email/password combination" + setMessage $ string "Invalid email/password combination" toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailLoginR @@ -393,7 +394,7 @@ getEmailPasswordR = do case mcreds of Just (Creds _ AuthEmail _ _ (Just _)) -> return () _ -> do - setMessage $ cs "You must be logged in to set a password" + setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage applyLayout "Set password" mempty [$hamlet| @@ -423,17 +424,17 @@ postEmailPasswordR = do <*> notEmpty (required $ input "confirm") toMaster <- getRouteToMaster when (new /= confirm) $ do - setMessage $ cs "Passwords did not match, please try again" + setMessage $ string "Passwords did not match, please try again" redirect RedirectTemporary $ toMaster EmailPasswordR mcreds <- maybeCreds lid <- case mcreds of Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid _ -> do - setMessage $ cs "You must be logged in to set a password" + setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR salted <- liftIO $ saltPass new liftIO $ setPassword ae lid salted - setMessage $ cs "Password updated" + setMessage $ string "Password updated" redirect RedirectTemporary $ toMaster EmailLoginR saltLength :: Int @@ -453,7 +454,7 @@ saltPass pass = do return $ saltPass' salt pass saltPass' :: String -> String -> String -saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass) +saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) inMemoryEmailSettings :: IO AuthEmailSettings inMemoryEmailSettings = do diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 89890e32..7ac9256b 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -51,7 +51,7 @@ data SitemapUrl url = SitemapUrl } sitemapNS :: Html -sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" +sitemapNS = string "http://www.sitemaps.org/schemas/sitemap/0.9" template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet| @@ -59,9 +59,9 @@ template urls = [$hamlet| $forall urls url %url %loc @sitemapLoc.url@ - %lastmod $cs.formatW3.sitemapLastMod.url$ - %changefreq $cs.showFreq.sitemapChangeFreq.url$ - %priority $cs.show.priority.url$ + %lastmod $string.formatW3.sitemapLastMod.url$ + %changefreq $string.showFreq.sitemapChangeFreq.url$ + %priority $string.show.priority.url$ |] sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 86951052..7157b358 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -80,7 +80,7 @@ getStaticRoute fp' = do case content of Nothing -> notFound Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp'' - Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)] + Just (Right bs) -> return [(typeByExt $ ext fp, bs)] where isUnsafe [] = True isUnsafe ('.':_) = True diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 51716943..0629f122 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -16,14 +16,14 @@ module Yesod.Json ) where -import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl) import Yesod.Hamlet import Yesod.Handler import Web.Routes.Quasi (Routes) import Numeric (showHex) import Data.Monoid (Monoid (..)) -import Data.Convertible.Text (cs) import Text.Hamlet #if TEST @@ -66,11 +66,11 @@ jsonToRepJson = fmap RepJson . jsonToContent jsonScalar :: Html -> Json jsonScalar s = Json $ mconcat [ preEscapedString "\"" - , preEscapedString $ encodeJson $ cs $ renderHtml s + , unsafeBytestring $ S.concat $ L.toChunks $ encodeJson $ renderHtml s , preEscapedString "\"" ] where - encodeJson = concatMap encodeJsonChar + encodeJson = L.concatMap (L.pack . encodeJsonChar) encodeJsonChar '\b' = "\\b" encodeJsonChar '\f' = "\\f" diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6afa19fc..b75eee0d 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -16,12 +16,12 @@ import Yesod.Content import Yesod.Request import Yesod.Hamlet import Yesod.Handler -import Data.Convertible.Text import qualified Network.Wai as W import Yesod.Json import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile, Key) import Data.Monoid (mempty) +import Data.ByteString.UTF8 (toString) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -99,7 +99,7 @@ applyLayout :: Yesod master -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent - { pageTitle = cs t + { pageTitle = string t , pageHead = h , pageBody = b } @@ -114,7 +114,7 @@ applyLayoutJson :: Yesod master -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do html' <- defaultLayout PageContent - { pageTitle = cs t + { pageTitle = string t , pageHead = h , pageBody = html } @@ -135,30 +135,30 @@ defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $string.cs.pathInfo.r$ +%p $string.toString.pathInfo.r$ |] where pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied -%p $cs.msg$ +%p $string.msg$ |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %dl $forall ia pair - %dt $cs.fst.pair$ - %dd $cs.snd.pair$ + %dt $string.fst.pair$ + %dd $string.snd.pair$ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error -%p $cs.e$ +%p $string.e$ |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported -%p Method "$cs.m$" not supported +%p Method "$string.m$" not supported |] diff --git a/yesod.cabal b/yesod.cabal index d475db1b..182222f5 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -38,7 +38,7 @@ library bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, text >= 0.5 && < 0.8, - convertible-text >= 0.3.0 && < 0.4, + utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.4 && < 0.5, From f99852fd0f7f010bf3ce620a89abc0363cc5f507 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 09:50:30 +0300 Subject: [PATCH 279/624] Tests running again --- Yesod/Dispatch.hs | 3 +-- Yesod/Json.hs | 9 ++++----- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2704e60c..6472b912 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -396,8 +396,7 @@ propEncDecSession session' = unsafePerformIO $ do let expire = addUTCTime 1 now let rhost = B.pack "some host" let val = encodeSession key expire rhost session' - return $ Just session' == - decodeSession key now rhost (B.pack val) + return $ Just session' == decodeSession key now rhost val propGetPutTime :: UTCTime -> Bool propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 0629f122..4341634e 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -30,7 +30,7 @@ import Text.Hamlet import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) -import Data.Text.Lazy (unpack) +import Data.ByteString.Lazy.Char8 (unpack) import Yesod.Content hiding (testSuite) #else import Yesod.Content @@ -128,11 +128,10 @@ caseSimpleOutput = do let j = do jsonMap [ ("foo" , jsonList - [ jsonScalar $ Encoded $ pack "bar" - , jsonScalar $ Encoded $ pack "baz" + [ jsonScalar $ preEscapedString "bar" + , jsonScalar $ preEscapedString "baz" ]) ] - t <- hamletToText id $ unJson j - "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack t + "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (renderHtml $ unJson j) #endif From f76d5a64428b18b965bc0d95274505771beff605 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 10:11:13 +0300 Subject: [PATCH 280/624] Integrate Contrib --- Yesod.hs | 4 +++- Yesod/Contrib/Crud.hs | 9 ++++++++- Yesod/Contrib/Persist.hs | 9 +++++++-- Yesod/Helpers/Auth.hs | 7 ++----- 4 files changed, 20 insertions(+), 9 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 82afafb1..56f5b623 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -10,6 +10,7 @@ module Yesod , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json + , module Yesod.Contrib , Application , liftIO , Routes @@ -26,10 +27,11 @@ import Yesod.Dispatch #endif import Yesod.Request -import Yesod.Form +import Yesod.Form hiding (Form) import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi (Routes) +import Yesod.Contrib diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index 0e3fd23b..ab573c8d 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -3,7 +3,14 @@ {-# LANGUAGE Rank2Types #-} module Yesod.Contrib.Crud where -import Yesod hiding (Form) +import Yesod.Yesod +import Yesod.Dispatch +import Yesod.Content +import Yesod.Handler +import Yesod.Request +import Text.Hamlet +import Control.Monad.IO.Class (liftIO) +import Web.Routes.Quasi import Database.Persist import Control.Applicative.Error import Yesod.Contrib.Formable hiding (runForm) diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs index a009ff5a..51b6f74b 100644 --- a/Yesod/Contrib/Persist.hs +++ b/Yesod/Contrib/Persist.hs @@ -1,7 +1,12 @@ {-# LANGUAGE TypeFamilies #-} -module Yesod.Contrib.Persist where +module Yesod.Contrib.Persist + ( YesodPersist (..) + , Persist (..) + ) where -import Yesod +import Yesod.Handler +import Yesod.Yesod +import Database.Persist class YesodPersist y where type YesodDB y :: (* -> *) -> * -> * diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c52da2d8..f920bb3c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -301,7 +301,7 @@ getEmailRegisterR = do postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings - email <- runFormPost $ checkEmail $ required $ input "email" + email <- runFormPost $ notEmpty $ required $ input "email" -- FIXME checkEmail y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <- @@ -319,9 +319,6 @@ postEmailRegisterR = do %p A confirmation e-mail has been sent to $string.email$. |] -checkEmail :: Form ParamValue -> Form ParamValue -checkEmail = notEmpty -- FIXME consider including e-mail validation - getEmailVerifyR :: YesodAuth master => Integer -> String -> GHandler Auth master RepHtml getEmailVerifyR lid key = do @@ -368,7 +365,7 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost $ (,) - <$> checkEmail (required $ input "email") + <$> notEmpty (required $ input "email") -- FIXME valid e-mail? <*> required (input "password") y <- getYesod mecreds <- liftIO $ getEmailCreds ae email From 59c56c125628072cd234dd9eda0a03663b617445 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 10:14:17 +0300 Subject: [PATCH 281/624] Cleaned up warnings --- Yesod/Content.hs | 1 - Yesod/Contrib/Crud.hs | 2 -- Yesod/Contrib/Formable.hs | 2 +- Yesod/Contrib/Persist.hs | 1 - Yesod/Dispatch.hs | 4 +--- Yesod/Handler.hs | 1 - Yesod/Helpers/Static.hs | 6 +++--- Yesod/Json.hs | 2 -- 8 files changed, 5 insertions(+), 14 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index d388d6a7..bbd6ac5f 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -58,7 +58,6 @@ import qualified Data.Text as T import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import Data.Function (on) import Data.Time import System.Locale diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Contrib/Crud.hs index ab573c8d..6da09ded 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Contrib/Crud.hs @@ -12,10 +12,8 @@ import Text.Hamlet import Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi import Database.Persist -import Control.Applicative.Error import Yesod.Contrib.Formable hiding (runForm) import Yesod.Contrib.Persist -import Control.Arrow (second) import Data.Monoid (mempty) runForm :: SealedForm (Routes y) a diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Contrib/Formable.hs index 6bef2340..5af2ca48 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Contrib/Formable.hs @@ -164,7 +164,7 @@ instance Fieldable NonEmptyString where %input!type=text!name=$string.name$!value=$string.val$ |] notEmpty "" = Left ["Must be non-empty"] - notEmpty x = Right $ NonEmptyString x + notEmpty y = Right $ NonEmptyString y share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs index 51b6f74b..fdb36318 100644 --- a/Yesod/Contrib/Persist.hs +++ b/Yesod/Contrib/Persist.hs @@ -5,7 +5,6 @@ module Yesod.Contrib.Persist ) where import Yesod.Handler -import Yesod.Yesod import Database.Persist class YesodPersist y where diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 6472b912..719198f1 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -31,7 +31,6 @@ import Yesod.Internal import Web.Routes.Quasi import Language.Haskell.TH.Syntax -import Data.List (nub) import qualified Network.Wai as W import qualified Network.Wai.Enumerator as W @@ -47,10 +46,9 @@ import qualified Data.ByteString.Char8 as B import Web.Routes (encodePathInfo) import qualified Data.ByteString.UTF8 as S -import qualified Data.ByteString.Lazy.UTF8 as L import Control.Concurrent.MVar -import Control.Arrow ((***), first) +import Control.Arrow ((***)) import Data.Time diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2bd5efff..c93234cc 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -81,7 +81,6 @@ import "MonadCatchIO-transformers" Control.Monad.CatchIO (catch) import Control.Monad (liftM, ap) import System.IO -import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W import Control.Monad.Attempt import Data.ByteString.UTF8 (toString) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 7157b358..74ff1ad0 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -109,10 +109,10 @@ staticFiles fp = do fs <- qRunIO $ getFileList fp concat `fmap` mapM go fs where - replace '.' = '_' - replace c = c + replace' '.' = '_' + replace' c = c go f = do - let name = mkName $ intercalate "_" $ map (map replace) f + let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute" return diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 4341634e..026819d2 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -21,10 +21,8 @@ import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl) import Yesod.Hamlet import Yesod.Handler -import Web.Routes.Quasi (Routes) import Numeric (showHex) import Data.Monoid (Monoid (..)) -import Text.Hamlet #if TEST import Test.Framework (testGroup, Test) From 93ad24f969a3982fc5434492cd270ed0874cce8f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 10:26:54 +0300 Subject: [PATCH 282/624] Sorted Contrib stuff into regular hierarchy --- Yesod.hs | 4 ++-- Yesod/Contrib.hs | 9 --------- Yesod/Contrib/Persist.hs | 12 ------------ Yesod/Dispatch.hs | 14 ++++++++------ Yesod/{Contrib => }/Formable.hs | 31 +++++++++++++++++++++++++----- Yesod/{Contrib => Helpers}/Crud.hs | 21 +++++++------------- Yesod/Yesod.hs | 14 ++++++++++++-- yesod.cabal | 8 +++----- 8 files changed, 58 insertions(+), 55 deletions(-) delete mode 100644 Yesod/Contrib.hs delete mode 100644 Yesod/Contrib/Persist.hs rename Yesod/{Contrib => }/Formable.hs (91%) rename Yesod/{Contrib => Helpers}/Crud.hs (92%) diff --git a/Yesod.hs b/Yesod.hs index 56f5b623..90fa85bd 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -10,7 +10,7 @@ module Yesod , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json - , module Yesod.Contrib + , module Yesod.Formable , Application , liftIO , Routes @@ -28,10 +28,10 @@ import Yesod.Dispatch import Yesod.Request import Yesod.Form hiding (Form) +import Yesod.Formable import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi (Routes) -import Yesod.Contrib diff --git a/Yesod/Contrib.hs b/Yesod/Contrib.hs deleted file mode 100644 index a14027c0..00000000 --- a/Yesod/Contrib.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Yesod.Contrib - ( module Yesod.Contrib.Formable - , module Yesod.Contrib.Crud - , module Yesod.Contrib.Persist - ) where - -import Yesod.Contrib.Formable hiding (runForm) -import Yesod.Contrib.Crud -import Yesod.Contrib.Persist diff --git a/Yesod/Contrib/Persist.hs b/Yesod/Contrib/Persist.hs deleted file mode 100644 index fdb36318..00000000 --- a/Yesod/Contrib/Persist.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Yesod.Contrib.Persist - ( YesodPersist (..) - , Persist (..) - ) where - -import Yesod.Handler -import Database.Persist - -class YesodPersist y where - type YesodDB y :: (* -> *) -> * -> * - runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 719198f1..0b26ba5c 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -55,8 +55,10 @@ import Data.Time import Control.Monad import Data.Maybe import Web.ClientSession +import qualified Web.ClientSession as CS import Data.Serialize +import qualified Data.Serialize as Ser import Network.Wai.Parse #if TEST @@ -336,7 +338,7 @@ headerToPair _ (DeleteCookie key) = headerToPair _ (Header key value) = (W.responseHeaderFromBS $ S.fromString key, S.fromString value) -encodeSession :: Key +encodeSession :: CS.Key -> UTCTime -- ^ expire time -> B.ByteString -- ^ remote host -> [(String, String)] -- ^ session @@ -344,7 +346,7 @@ encodeSession :: Key encodeSession key expire rhost session' = encrypt key $ encode $ SessionCookie expire rhost session' -decodeSession :: Key +decodeSession :: CS.Key -> UTCTime -- ^ current time -> B.ByteString -- ^ remote host field -> B.ByteString -- ^ cookie value @@ -363,8 +365,8 @@ instance Serialize SessionCookie where put (SessionCookie a b c) = putTime a >> put b >> put c get = do a <- getTime - b <- get - c <- get + b <- Ser.get + c <- Ser.get return $ SessionCookie a b c putTime :: Putter UTCTime @@ -375,8 +377,8 @@ putTime t@(UTCTime d _) = do getTime :: Get UTCTime getTime = do - d <- get - ndt <- get + d <- Ser.get + ndt <- Ser.get return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 #if TEST diff --git a/Yesod/Contrib/Formable.hs b/Yesod/Formable.hs similarity index 91% rename from Yesod/Contrib/Formable.hs rename to Yesod/Formable.hs index 5af2ca48..3a31a9cd 100644 --- a/Yesod/Contrib/Formable.hs +++ b/Yesod/Formable.hs @@ -3,12 +3,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Contrib.Formable where +module Yesod.Formable + ( Form (..) + , Formlet + , SealedForm (..) + , SealedFormlet + , runForm + , runIncr + , Formable (..) + , Fieldable (..) + , deriveFormable + , share2 + , wrapperRow + , sealFormlet + ) where import Text.Hamlet import Data.Time (Day) import Control.Applicative -import Web.Routes.Quasi (SinglePiece) import Database.Persist (Persistable) import Data.Char (isAlphaNum) import Language.Haskell.TH.Syntax @@ -19,6 +31,17 @@ import Control.Arrow (first) import Data.Maybe (fromMaybe) import Data.Monoid (mempty, mappend) import qualified Data.ByteString.Lazy.UTF8 +import Yesod.Request +import Yesod.Handler +import Control.Monad.IO.Class (liftIO) +import Web.Routes.Quasi + +runForm :: SealedForm (Routes y) a + -> GHandler sub y (Either [String] a, Hamlet (Routes y)) +runForm f = do + req <- getRequest + (pp, _) <- liftIO $ reqRequestBody req + return $ fst $ runIncr (runSealedForm f pp) 1 type Env = [(String, String)] @@ -39,9 +62,7 @@ instance Functor FormResult where fmap _ (FormFailure errs) = FormFailure errs fmap f (FormSuccess a) = FormSuccess $ f a -newtype Form url a = Form - { runForm :: Env -> Incr (FormResult a, Hamlet url) - } +newtype Form url a = Form (Env -> Incr (FormResult a, Hamlet url)) type Formlet url a = Maybe a -> Form url a newtype SealedForm url a = SealedForm diff --git a/Yesod/Contrib/Crud.hs b/Yesod/Helpers/Crud.hs similarity index 92% rename from Yesod/Contrib/Crud.hs rename to Yesod/Helpers/Crud.hs index 6da09ded..24ba65ca 100644 --- a/Yesod/Contrib/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -1,28 +1,21 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} -module Yesod.Contrib.Crud where +module Yesod.Helpers.Crud + ( Item (..) + , Crud (..) + , defaultCrud + , siteCrud + ) where import Yesod.Yesod import Yesod.Dispatch import Yesod.Content import Yesod.Handler -import Yesod.Request import Text.Hamlet -import Control.Monad.IO.Class (liftIO) -import Web.Routes.Quasi -import Database.Persist -import Yesod.Contrib.Formable hiding (runForm) -import Yesod.Contrib.Persist +import Yesod.Formable import Data.Monoid (mempty) -runForm :: SealedForm (Routes y) a - -> GHandler sub y (Either [String] a, Hamlet (Routes y)) -runForm f = do - req <- getRequest - (pp, _) <- liftIO $ reqRequestBody req - return $ fst $ runIncr (runSealedForm f pp) 1 - class Formable a => Item a where itemTitle :: a -> String diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b75eee0d..3cf87abe 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,10 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes Yesod (..) , YesodSite (..) + -- ** Persistence + , YesodPersist (..) + , Persist (..) -- * Convenience functions , applyLayout , applyLayoutJson @@ -19,9 +23,11 @@ import Yesod.Handler import qualified Network.Wai as W import Yesod.Json import Yesod.Internal -import Web.ClientSession (getKey, defaultKeyFile, Key) +import Web.ClientSession (getKey, defaultKeyFile) +import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) +import Database.Persist (Persist (..)) import Web.Routes.Quasi (QuasiSite (..), Routes) @@ -46,7 +52,7 @@ class Yesod a where approot :: a -> String -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Key + encryptKey :: a -> IO CS.Key encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to @@ -162,3 +168,7 @@ defaultErrorHandler (BadMethod m) = %h1 Method Not Supported %p Method "$string.m$" not supported |] + +class YesodPersist y where + type YesodDB y :: (* -> *) -> * -> * + runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a diff --git a/yesod.cabal b/yesod.cabal index 182222f5..f321c799 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -58,6 +58,7 @@ library Yesod.Content Yesod.Dispatch Yesod.Form + Yesod.Formable Yesod.Hamlet Yesod.Handler Yesod.Internal @@ -66,13 +67,10 @@ library Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth + Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - Yesod.Contrib - Yesod.Contrib.Crud - Yesod.Contrib.Formable - Yesod.Contrib.Persist - ghc-options: -Wall + ghc-options: -Wall -Werror executable runtests if flag(buildtests) From 91da0ff1e5c94fdf180c00a855953d5c51f82a35 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 10:34:58 +0300 Subject: [PATCH 283/624] Removed SealedForm(let) --- Yesod/Formable.hs | 98 ++++++++++++++++++++----------------------- Yesod/Helpers/Crud.hs | 2 +- 2 files changed, 46 insertions(+), 54 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 3a31a9cd..be462ecb 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -6,12 +6,10 @@ module Yesod.Formable ( Form (..) , Formlet - , SealedForm (..) - , SealedFormlet + , FormResult (..) , runForm , runIncr , Formable (..) - , Fieldable (..) , deriveFormable , share2 , wrapperRow @@ -36,12 +34,12 @@ import Yesod.Handler import Control.Monad.IO.Class (liftIO) import Web.Routes.Quasi -runForm :: SealedForm (Routes y) a - -> GHandler sub y (Either [String] a, Hamlet (Routes y)) +runForm :: Form (Routes y) a + -> GHandler sub y (FormResult a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req - return $ fst $ runIncr (runSealedForm f pp) 1 + return $ fst $ runIncr (deform f pp) 1 type Env = [(String, String)] @@ -61,44 +59,41 @@ instance Functor FormResult where fmap _ FormMissing = FormMissing fmap _ (FormFailure errs) = FormFailure errs fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing -newtype Form url a = Form (Env -> Incr (FormResult a, Hamlet url)) -type Formlet url a = Maybe a -> Form url a - -newtype SealedForm url a = SealedForm - { runSealedForm :: Env -> Incr (Either [String] a, Hamlet url) +newtype Form url a = Form + { deform :: Env -> Incr (FormResult a, Hamlet url) } -type SealedFormlet url a = Maybe a -> SealedForm url a -instance Functor (SealedForm url) where - fmap f (SealedForm g) = SealedForm - $ \env -> liftM (first $ fmap f) (g env) -instance Applicative (SealedForm url) where - pure a = SealedForm $ const $ return (Right a, mempty) - (SealedForm f) <*> (SealedForm g) = SealedForm $ \env -> do - (f1, f2) <- f env - (g1, g2) <- g env - return (f1 `apE` g1, f2 `mappend` g2) - where - apE (Left x) (Left y) = Left $ x ++ y - apE (Left x) _ = Left x - apE _ (Left y) = Left y - apE (Right x) (Right y) = Right $ x y - -sealForm :: ([String] -> Hamlet url -> Hamlet url) - -> Form url a -> SealedForm url a -sealForm wrapper (Form form) = SealedForm $ \env -> liftM go (form env) - where - go (FormSuccess a, xml) = (Right a, wrapper [] xml) - go (FormFailure errs, xml) = (Left errs, wrapper errs xml) - go (FormMissing, xml) = (Left [], wrapper [] xml) - -sealFormlet :: ([String] -> Hamlet url -> Hamlet url) - -> Formlet url a -> SealedFormlet url a -sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal +type Formlet url a = Maybe a -> Form url a instance Functor (Form url) where fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) +instance Applicative (Form url) where + pure a = Form $ const $ return (pure a, mempty) + (Form f) <*> (Form g) = Form $ \env -> do + (f1, f2) <- f env + (g1, g2) <- g env + return (f1 <*> g1, f2 `mappend` g2) + +sealForm :: ([String] -> Hamlet url -> Hamlet url) + -> Form url a -> Form url a +sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) + where + go (res, xml) = (res, wrapper (toList res) xml) + toList (FormFailure errs) = errs + toList _ = [] + +sealFormlet :: ([String] -> Hamlet url -> Hamlet url) + -> Formlet url a -> Formlet url a +sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal + input' :: (String -> String -> Hamlet url) -> Maybe String -> Form url String @@ -120,10 +115,7 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env) Right b -> FormSuccess b class Formable a where - formable :: SealedFormlet url a - -class Fieldable a where - fieldable :: Formlet url a + formable :: Formlet url a wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url wrapperRow label errs control = [$hamlet| @@ -137,22 +129,22 @@ wrapperRow label errs control = [$hamlet| %li $string.err$ |] -instance Fieldable [Char] where - fieldable = input' go +instance Formable [Char] where + formable = input' go where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ |] -instance Fieldable Html where - fieldable = fmap preEscapedString +instance Formable Html where + formable = fmap preEscapedString . input' go . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] -instance Fieldable Day where - fieldable x = input' go (fmap show x) `check` asDay +instance Formable Day where + formable x = input' go (fmap show x) `check` asDay where go name val = [$hamlet| %input!type=date!name=$string.name$!value=$string.val$ @@ -164,8 +156,8 @@ instance Fieldable Day where newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Fieldable Slug where - fieldable x = input' go (fmap unSlug x) `check` asSlug +instance Formable Slug where + formable x = input' go (fmap unSlug x) `check` asSlug where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -178,8 +170,8 @@ instance Fieldable Slug where newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Fieldable NonEmptyString where - fieldable x = input' go (fmap unNonEmptyString x) `check` notEmpty +instance Formable NonEmptyString where + formable x = input' go (fmap unNonEmptyString x) `check` notEmpty where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -218,5 +210,5 @@ deriveFormable = mapM derive go' (label, ex) = VarE (mkName "sealForm") `AppE` (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "fieldable") `AppE` ex) + (VarE (mkName "formable") `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 24ba65ca..2c3e4947 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -128,7 +128,7 @@ crudHelper title me isPost = do (errs, form) <- runForm $ formable $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of - (True, Right a) -> do + (True, FormSuccess a) -> do eid <- case me of Just (eid, _) -> do crudReplace crud eid a From 758b647de618dc4b0afc4380231d625c77a09912 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 13:56:26 +0300 Subject: [PATCH 284/624] More power Forms (getting ugly...) --- Yesod/Formable.hs | 143 +++++++++++++++++++++++++++--------------- Yesod/Helpers/Crud.hs | 1 + 2 files changed, 94 insertions(+), 50 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index be462ecb..d22be498 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -3,54 +3,59 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Yesod.Formable ( Form (..) , Formlet , FormResult (..) , runForm - , runIncr + , incr , Formable (..) , deriveFormable , share2 , wrapperRow , sealFormlet + , sealForm + , NonEmptyString (..) + , Slug (..) ) where import Text.Hamlet import Data.Time (Day) import Control.Applicative import Database.Persist (Persistable) -import Data.Char (isAlphaNum) +import Data.Char (isAlphaNum, toUpper, isUpper) import Language.Haskell.TH.Syntax import Database.Persist (Table (..)) -import Database.Persist.Helper (upperFirst) import Control.Monad (liftM) import Control.Arrow (first) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mempty, mappend) import qualified Data.ByteString.Lazy.UTF8 import Yesod.Request import Yesod.Handler import Control.Monad.IO.Class (liftIO) -import Web.Routes.Quasi +import Control.Monad.Trans.State +import Web.Routes.Quasi (Routes, SinglePiece) -runForm :: Form (Routes y) a +runForm :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runForm f = do req <- getRequest (pp, _) <- liftIO $ reqRequestBody req - return $ fst $ runIncr (deform f pp) 1 + evalStateT (deform f pp) 1 type Env = [(String, String)] -newtype Incr a = Incr { runIncr :: Int -> (a, Int) } -incr :: Incr Int -incr = Incr $ \i -> (i + 1, i + 1) -instance Monad Incr where - return a = Incr $ \i -> (a, i) - Incr x >>= f = Incr $ \i -> - let (x', i') = x i - in runIncr (f x') i' +type Incr = StateT Int + +incr :: Monad m => Incr m Int +incr = do + i <- get + let i' = i + 1 + put i' + return i' data FormResult a = FormMissing | FormFailure [String] @@ -67,36 +72,36 @@ instance Applicative FormResult where _ <*> (FormFailure y) = FormFailure y _ <*> _ = FormMissing -newtype Form url a = Form - { deform :: Env -> Incr (FormResult a, Hamlet url) +newtype Form sub y a = Form + { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) } -type Formlet url a = Maybe a -> Form url a +type Formlet sub y a = Maybe a -> Form sub y a -instance Functor (Form url) where +instance Functor (Form sub url) where fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) -instance Applicative (Form url) where +instance Applicative (Form sub url) where pure a = Form $ const $ return (pure a, mempty) (Form f) <*> (Form g) = Form $ \env -> do (f1, f2) <- f env (g1, g2) <- g env return (f1 <*> g1, f2 `mappend` g2) -sealForm :: ([String] -> Hamlet url -> Hamlet url) - -> Form url a -> Form url a +sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) + -> Form sub y a -> Form sub y a sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) where go (res, xml) = (res, wrapper (toList res) xml) toList (FormFailure errs) = errs toList _ = [] -sealFormlet :: ([String] -> Hamlet url -> Hamlet url) - -> Formlet url a -> Formlet url a +sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) + -> Formlet sub y a -> Formlet sub y a sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal -input' :: (String -> String -> Hamlet url) +input' :: (String -> String -> Hamlet (Routes y)) -> Maybe String - -> Form url String + -> Form sub y String input' mkXml val = Form $ \env -> do i <- incr let i' = show i @@ -104,7 +109,7 @@ input' mkXml val = Form $ \env -> do let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param return (maybe FormMissing FormSuccess param, xml) -check :: Form url a -> (a -> Either [String] b) -> Form url b +check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b check (Form form) f = Form $ \env -> liftM (first go) (form env) where go FormMissing = FormMissing @@ -114,8 +119,8 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env) Left errs -> FormFailure errs Right b -> FormSuccess b -class Formable a where - formable :: Formlet url a +class Formable y param a where + formable :: param -> Formlet y y a wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url wrapperRow label errs control = [$hamlet| @@ -129,22 +134,22 @@ wrapperRow label errs control = [$hamlet| %li $string.err$ |] -instance Formable [Char] where - formable = input' go +instance Formable y param [Char] where + formable _ = input' go where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ |] -instance Formable Html where - formable = fmap preEscapedString +instance Formable y param Html where + formable _ = fmap preEscapedString . input' go . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] -instance Formable Day where - formable x = input' go (fmap show x) `check` asDay +instance Formable y param Day where + formable _ x = input' go (fmap show x) `check` asDay where go name val = [$hamlet| %input!type=date!name=$string.name$!value=$string.val$ @@ -153,11 +158,33 @@ instance Formable Day where (y, _):_ -> Right y [] -> Left ["Invalid day"] +instance Formable y param Bool where + formable _ x = Form $ \env -> do + i <- incr + let i' = show i + let param = lookup i' env + let def = if null env then fromMaybe False x else isJust param + return (FormSuccess $ isJust param, go i' def) + where + go name val = [$hamlet| +%input!type=checkbox!name=$string.name$!:val:checked +|] + +instance Formable y param Int where + formable _ x = input' go (fmap show x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid integer"] + newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Formable Slug where - formable x = input' go (fmap unSlug x) `check` asSlug +instance Formable y param Slug where + formable _ x = input' go (fmap unSlug x) `check` asSlug where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -170,8 +197,8 @@ instance Formable Slug where newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Formable NonEmptyString where - formable x = input' go (fmap unNonEmptyString x) `check` notEmpty +instance Formable y param NonEmptyString where + formable _ x = input' go (fmap unNonEmptyString x) `check` notEmpty where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -185,30 +212,46 @@ share2 f g a = do g' <- g a return $ f' ++ g' -deriveFormable :: [Table] -> Q [Dec] -deriveFormable = mapM derive +deriveFormable :: String -> String -> [Table] -> Q [Dec] +deriveFormable yesod param = mapM derive where derive :: Table -> Q Dec derive t = do - let cols = map (upperFirst . fst) $ tableColumns t + let cols = map (toLabel . fst) $ tableColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ tableName t) - let c1 = Clause [ConP (mkName "Nothing") []] - (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + param' <- newName "param" + let c1 = Clause [ VarP param' + , ConP (mkName "Nothing") [] + ] + (NormalB $ go param' ap just' $ zip cols $ map (const nothing) cols) [] xs <- mapM (const $ newName "x") cols let xs' = map (AppE just . VarE) xs - let c2 = Clause [ConP (mkName "Just") [ConP (mkName $ tableName t) + let c2 = Clause [ VarP param' + , ConP (mkName "Just") [ConP (mkName $ tableName t) $ map VarP xs]] - (NormalB $ go ap just' $ zip cols xs') + (NormalB $ go param' ap just' $ zip cols xs') [] - return $ InstanceD [] (ConT ''Formable `AppT` ConT (mkName $ tableName t)) + return $ InstanceD [] (ConT ''Formable + `AppT` ConT (mkName yesod) + `AppT` ConT (mkName param) + `AppT` ConT (mkName $ tableName t)) [FunD (mkName "formable") [c1, c2]] - go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = + go param' ap just' = foldl (ap' ap) just' . map (go' param') + go' param' (label, ex) = VarE (mkName "sealForm") `AppE` (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "formable") `AppE` ex) + (VarE (mkName "formable") `AppE` VarE param' `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) + +toLabel :: String -> String +toLabel "" = "" +toLabel (x:rest) = toUpper x : go rest + where + go "" = "" + go (c:cs) + | isUpper c = ' ' : c : go cs + | otherwise = c : go cs diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 2c3e4947..505f0bc2 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -4,6 +4,7 @@ module Yesod.Helpers.Crud ( Item (..) , Crud (..) + , CrudRoutes (..) , defaultCrud , siteCrud ) where From f8c157bb42a921d8462d6de4d4d8937812e0d98a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 9 Jun 2010 16:39:16 +0300 Subject: [PATCH 285/624] Simplified Formable type class again --- Yesod/Formable.hs | 55 +++++++++++++++++++++-------------------------- 1 file changed, 25 insertions(+), 30 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index d22be498..d44b9ebd 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -119,8 +119,8 @@ check (Form form) f = Form $ \env -> liftM (first go) (form env) Left errs -> FormFailure errs Right b -> FormSuccess b -class Formable y param a where - formable :: param -> Formlet y y a +class Formable a where + formable :: Formlet sub master a wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url wrapperRow label errs control = [$hamlet| @@ -134,22 +134,22 @@ wrapperRow label errs control = [$hamlet| %li $string.err$ |] -instance Formable y param [Char] where - formable _ = input' go +instance Formable [Char] where + formable = input' go where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ |] -instance Formable y param Html where - formable _ = fmap preEscapedString +instance Formable Html where + formable = fmap preEscapedString . input' go . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] -instance Formable y param Day where - formable _ x = input' go (fmap show x) `check` asDay +instance Formable Day where + formable x = input' go (fmap show x) `check` asDay where go name val = [$hamlet| %input!type=date!name=$string.name$!value=$string.val$ @@ -158,8 +158,8 @@ instance Formable y param Day where (y, _):_ -> Right y [] -> Left ["Invalid day"] -instance Formable y param Bool where - formable _ x = Form $ \env -> do +instance Formable Bool where + formable x = Form $ \env -> do i <- incr let i' = show i let param = lookup i' env @@ -170,8 +170,8 @@ instance Formable y param Bool where %input!type=checkbox!name=$string.name$!:val:checked |] -instance Formable y param Int where - formable _ x = input' go (fmap show x) `check` asInt +instance Formable Int where + formable x = input' go (fmap show x) `check` asInt where go name val = [$hamlet| %input!type=number!name=$string.name$!value=$string.val$ @@ -183,8 +183,8 @@ instance Formable y param Int where newtype Slug = Slug { unSlug :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Formable y param Slug where - formable _ x = input' go (fmap unSlug x) `check` asSlug +instance Formable Slug where + formable x = input' go (fmap unSlug x) `check` asSlug where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -197,8 +197,8 @@ instance Formable y param Slug where newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Formable y param NonEmptyString where - formable _ x = input' go (fmap unNonEmptyString x) `check` notEmpty +instance Formable NonEmptyString where + formable x = input' go (fmap unNonEmptyString x) `check` notEmpty where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ @@ -212,8 +212,8 @@ share2 f g a = do g' <- g a return $ f' ++ g' -deriveFormable :: String -> String -> [Table] -> Q [Dec] -deriveFormable yesod param = mapM derive +deriveFormable :: [Table] -> Q [Dec] +deriveFormable = mapM derive where derive :: Table -> Q Dec derive t = do @@ -222,29 +222,24 @@ deriveFormable yesod param = mapM derive just <- [|pure|] nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ tableName t) - param' <- newName "param" - let c1 = Clause [ VarP param' - , ConP (mkName "Nothing") [] + let c1 = Clause [ ConP (mkName "Nothing") [] ] - (NormalB $ go param' ap just' $ zip cols $ map (const nothing) cols) + (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) [] xs <- mapM (const $ newName "x") cols let xs' = map (AppE just . VarE) xs - let c2 = Clause [ VarP param' - , ConP (mkName "Just") [ConP (mkName $ tableName t) + let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ tableName t) $ map VarP xs]] - (NormalB $ go param' ap just' $ zip cols xs') + (NormalB $ go ap just' $ zip cols xs') [] return $ InstanceD [] (ConT ''Formable - `AppT` ConT (mkName yesod) - `AppT` ConT (mkName param) `AppT` ConT (mkName $ tableName t)) [FunD (mkName "formable") [c1, c2]] - go param' ap just' = foldl (ap' ap) just' . map (go' param') - go' param' (label, ex) = + go ap just' = foldl (ap' ap) just' . map go' + go' (label, ex) = VarE (mkName "sealForm") `AppE` (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "formable") `AppE` VarE param' `AppE` ex) + (VarE (mkName "formable") `AppE` ex) ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String From 48d8ac308552ff06c61ac3161ff76f4d56ea522f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 10 Jun 2010 00:33:03 +0300 Subject: [PATCH 286/624] hlint --- Yesod/Dispatch.hs | 6 +++--- Yesod/Formable.hs | 5 ++--- Yesod/Handler.hs | 2 +- Yesod/Helpers/Crud.hs | 2 +- Yesod/Json.hs | 2 +- 5 files changed, 8 insertions(+), 9 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0b26ba5c..5571db19 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -79,7 +79,7 @@ import Yesod.Content mkYesod :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec] -mkYesod name = fmap (\(x, y) -> x ++ y) . mkYesodGeneral name [] [] False +mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. @@ -91,7 +91,7 @@ mkYesodSub :: String -- ^ name of the argument datatype -> [Resource] -> Q [Dec] mkYesodSub name clazzes = - fmap (\(x, y) -> x ++ y) . mkYesodGeneral name' rest clazzes True + fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True where (name':rest) = words name @@ -134,7 +134,7 @@ mkYesodGeneral :: String -- ^ argument name mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args - arg = foldl AppT (ConT $ name') $ map VarT args' + arg = foldl AppT (ConT name') $ map VarT args' let site = mkName $ "site" ++ name let gsbod = NormalB $ VarE site let yes' = FunD (mkName "getSite") [Clause [] gsbod []] diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index d44b9ebd..0e0b8416 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -24,10 +24,9 @@ module Yesod.Formable import Text.Hamlet import Data.Time (Day) import Control.Applicative -import Database.Persist (Persistable) +import Database.Persist (Persistable, Table (..)) import Data.Char (isAlphaNum, toUpper, isUpper) import Language.Haskell.TH.Syntax -import Database.Persist (Table (..)) import Control.Monad (liftM) import Control.Arrow (first) import Data.Maybe (fromMaybe, isJust) @@ -134,7 +133,7 @@ wrapperRow label errs control = [$hamlet| %li $string.err$ |] -instance Formable [Char] where +instance Formable String where formable = input' go where go name val = [$hamlet| diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index c93234cc..edbaee7a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -269,7 +269,7 @@ redirectParams rt url params = do | c == ' ' = "+" | otherwise = '%' : myShowHex (ord c) "" myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 (toChrHex) n r of + myShowHex n r = case showIntAtBase 16 toChrHex n r of [] -> "00" [c] -> ['0',c] s -> s diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 505f0bc2..21224b1a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -155,7 +155,7 @@ crudHelper title me isPost = do defaultCrud :: (Persist i (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) => a -> Crud a i -defaultCrud = const $ Crud +defaultCrud = const Crud { crudSelect = runDB $ select [] [] , crudReplace = \a -> runDB . replace a , crudInsert = runDB . insert diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 026819d2..310f3a93 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -95,7 +95,7 @@ jsonList (x:xs) = mconcat , Json $ preEscapedString "]" ] where - go j = mappend (Json $ preEscapedString ",") j + go = mappend (Json $ preEscapedString ",") -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. jsonMap :: [(String, Json)] -> Json From 3aa2636676dea02bb5dae01f8ffd1ba950e0e8c1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 10 Jun 2010 10:04:32 +0300 Subject: [PATCH 287/624] Formable instances and sealRow --- Yesod/Formable.hs | 93 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 79 insertions(+), 14 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 0e0b8416..c0d3abf6 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -17,8 +17,8 @@ module Yesod.Formable , wrapperRow , sealFormlet , sealForm - , NonEmptyString (..) , Slug (..) + , sealRow ) where import Text.Hamlet @@ -27,7 +27,7 @@ import Control.Applicative import Database.Persist (Persistable, Table (..)) import Data.Char (isAlphaNum, toUpper, isUpper) import Language.Haskell.TH.Syntax -import Control.Monad (liftM) +import Control.Monad (liftM, join) import Control.Arrow (first) import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mempty, mappend) @@ -37,6 +37,11 @@ import Yesod.Handler import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State import Web.Routes.Quasi (Routes, SinglePiece) +import Data.Int (Int64) + +sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b +sealRow label getVal val = + sealForm (wrapperRow label) $ formable $ fmap getVal val runForm :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) @@ -134,11 +139,24 @@ wrapperRow label errs control = [$hamlet| |] instance Formable String where - formable = input' go + formable x = input' go x `check` notEmpty where go name val = [$hamlet| %input!type=text!name=$string.name$!value=$string.val$ |] + notEmpty s + | null s = Left ["Value required"] + | otherwise = Right s + +instance Formable (Maybe String) where + formable x = input' go (join x) `check` isEmpty + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + isEmpty s + | null s = Right Nothing + | otherwise = Right $ Just s instance Formable Html where formable = fmap preEscapedString @@ -157,6 +175,64 @@ instance Formable Day where (y, _):_ -> Right y [] -> Left ["Invalid day"] +instance Formable Int64 where + formable x = input' go (fmap show x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid integer"] + +instance Formable Double where + formable x = input' go (fmap numstring x) `check` asDouble + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asDouble s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid double"] + numstring d = + let s = show d + in case reverse s of + '0':'.':y -> reverse y + _ -> s + +instance Formable (Maybe Day) where + formable x = input' go (fmap show $ join x) `check` asDay + where + go name val = [$hamlet| +%input!type=date!name=$string.name$!value=$string.val$ +|] + asDay "" = Right Nothing + asDay s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid day"] + +instance Formable (Maybe Int) where + formable x = input' go (fmap show $ join x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt "" = Right Nothing + asInt s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid integer"] + +instance Formable (Maybe Int64) where + formable x = input' go (fmap show $ join x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt "" = Right Nothing + asInt s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid integer"] + instance Formable Bool where formable x = Form $ \env -> do i <- incr @@ -194,17 +270,6 @@ instance Formable Slug where Right $ Slug x' | otherwise = Left ["Slug must be alphanumeric, - and _"] -newtype NonEmptyString = NonEmptyString { unNonEmptyString :: String } - deriving (Read, Eq, Show, SinglePiece, Persistable) -instance Formable NonEmptyString where - formable x = input' go (fmap unNonEmptyString x) `check` notEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - notEmpty "" = Left ["Must be non-empty"] - notEmpty y = Right $ NonEmptyString y - share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do f' <- f a From 809aa256f779d2e731981c31065ec679e313761f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 13 Jun 2010 16:07:58 +0300 Subject: [PATCH 288/624] Exposing check function --- Yesod/Formable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index c0d3abf6..1bd8d556 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -19,6 +19,7 @@ module Yesod.Formable , sealForm , Slug (..) , sealRow + , check ) where import Text.Hamlet From 23c149c13c40ac251cfae1c02e4014d8fd2f1b40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 14 Jun 2010 15:38:36 +0300 Subject: [PATCH 289/624] Fixed some dependencies --- yesod.cabal | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index f321c799..d52969bd 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -43,16 +43,14 @@ library web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.4 && < 0.5, hamlet >= 0.3.0 && < 0.4, - transformers >= 0.1 && < 0.3, + transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, - MonadCatchIO-transformers >= 0.1 && < 0.3, + MonadCatchIO-transformers >= 0.2 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1, - formlets >= 0.7.1 && < 0.8, - applicative-extras >= 0.1.6 && < 0.2, persistent >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Content From aceab3299982fdee285e4c55c1da1b63bafc1d6d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Jun 2010 11:08:57 +0300 Subject: [PATCH 290/624] Beginning of converting Handler to Cont monad --- Yesod/Handler.hs | 56 +++++++++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 22 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index edbaee7a..dc5cc7c7 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -104,9 +104,12 @@ data HandlerData sub master = HandlerData -- for headers, and an error-type monad for handling special responses. newtype GHandler sub master a = Handler { unHandler :: HandlerData sub master - -> IO ([Header], [(String, Maybe String)], HandlerContents a) + -> (a -> IO Helper) + -> IO Helper } +type Helper = ([Header], [(String, Maybe String)], HandlerContents) + -- | A 'GHandler' limited to the case where the master and sub sites are the -- same. This is the usual case for application writing; only code written -- specifically as a subsite need been concerned with the more general variety. @@ -123,8 +126,8 @@ newtype YesodApp = YesodApp -> IO (W.Status, [Header], ContentType, Content, [(String, String)]) } -data HandlerContents a = - HCContent a +data HandlerContents = + HCContent ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String @@ -136,18 +139,17 @@ instance Applicative (GHandler sub master) where (<*>) = ap instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway - return x = Handler $ \_ -> return ([], [], HCContent x) - (Handler handler) >>= f = Handler $ \rr -> do - (headers, session', c) <- handler rr - (headers', session'', c') <- - case c of - HCContent a -> unHandler (f a) rr - HCError e -> return ([], [], HCError e) - HCSendFile ct fp -> return ([], [], HCSendFile ct fp) - HCRedirect rt url -> return ([], [], HCRedirect rt url) - return (headers ++ headers', session' ++ session'', c') + return x = Handler $ \_ f -> do + (a, b, c) <- f x + return (a, b, c) + Handler handler >>= f = Handler $ \rr cont -> do + handler rr (\a -> unHandler (f a) rr cont) instance MonadIO (GHandler sub master) where - liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i') + liftIO i = Handler $ \_ f -> do + i' <- i + (a, b, c) <- f i' + return (a, b, c) +{- FIXME instance C.MonadCatchIO (GHandler sub master) where catch (Handler m) f = Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d) @@ -155,13 +157,16 @@ instance C.MonadCatchIO (GHandler sub master) where Handler $ E.block . m unblock (Handler m) = Handler $ E.unblock . m +-} instance Failure ErrorResponse (GHandler sub master) where - failure e = Handler $ \_ -> return ([], [], HCError e) + failure e = Handler $ \_ _ -> return ([], [], HCError e) instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> getData getData :: GHandler sub master (HandlerData sub master) -getData = Handler $ \r -> return ([], [], HCContent r) +getData = Handler $ \r f -> do + (a, b, c) <- f r + return (a, b, c) -- | Get the sub application argument. getYesodSub :: GHandler sub master sub @@ -217,7 +222,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr - }) + } $ \c -> return ([], [], HCContent $ chooseRep c)) (\e -> return ([], [], HCError $ toErrorHandler e)) let finalSession = foldl' modifySession (reqSession rr) session' let handleError e = do @@ -279,7 +284,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) +redirectString rt url = Handler $ \_ _ -> return ([], [], HCRedirect rt url) ultDestKey :: String ultDestKey = "_ULT" @@ -342,7 +347,8 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = Handler $ \_ -> return ([], [], HCSendFile ct fp) +sendFile ct fp = Handler $ \_ _ -> do + return ([], [], HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -390,14 +396,20 @@ header a = addHeader . Header a setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k v = Handler $ \_ -> return ([], [(k, Just v)], HCContent ()) +setSession k v = Handler $ \_ f -> do + (a, b, c) <- f () + return (a, b ++ [(k, Just v)], c) -- | Unsets a session variable. See 'setSession'. clearSession :: String -> GHandler sub master () -clearSession k = Handler $ \_ -> return ([], [(k, Nothing)], HCContent ()) +clearSession k = Handler $ \_ f -> do + (a, b, c) <- f () + return (a, b ++ [(k, Nothing)], c) addHeader :: Header -> GHandler sub master () -addHeader h = Handler $ \_ -> return ([h], [], HCContent ()) +addHeader h = Handler $ \_ f -> do + (a, b, c) <- f () + return (a ++ [h], b, c) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 From c60cc6ab217d2515d131b3f37ec844f9f9536197 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Jun 2010 11:11:11 +0300 Subject: [PATCH 291/624] Handler writers: Endos instead of lists --- Yesod/Handler.hs | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index dc5cc7c7..3b6d9615 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -76,8 +76,6 @@ import qualified Control.Exception as E import Control.Applicative import "transformers" Control.Monad.IO.Class -import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C -import "MonadCatchIO-transformers" Control.Monad.CatchIO (catch) import Control.Monad (liftM, ap) import System.IO @@ -108,7 +106,8 @@ newtype GHandler sub master a = Handler { -> IO Helper } -type Helper = ([Header], [(String, Maybe String)], HandlerContents) +type Endo a = a -> a +type Helper = (Endo [Header], Endo [(String, Maybe String)], HandlerContents) -- | A 'GHandler' limited to the case where the master and sub sites are the -- same. This is the usual case for application writing; only code written @@ -159,7 +158,7 @@ instance C.MonadCatchIO (GHandler sub master) where Handler $ E.unblock . m -} instance Failure ErrorResponse (GHandler sub master) where - failure e = Handler $ \_ _ -> return ([], [], HCError e) + failure e = Handler $ \_ _ -> return (id, id, HCError e) instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> getData @@ -222,22 +221,22 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr - } $ \c -> return ([], [], HCContent $ chooseRep c)) - (\e -> return ([], [], HCError $ toErrorHandler e)) - let finalSession = foldl' modifySession (reqSession rr) session' + } $ \c -> return (id, id, HCContent $ chooseRep c)) + (\e -> return (id, id, HCError $ toErrorHandler e)) + let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts - let hs' = headers ++ hs + let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.Status200, headers, ct, ContentFile fp, finalSession) + return (W.Status200, headers [], ct, ContentFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts - return (W.Status200, headers, ct, c, finalSession) + return (W.Status200, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do - let hs = Header "Location" loc : headers + let hs = Header "Location" loc : headers [] return (getRedirectStatus rt, hs, typePlain, emptyContent, finalSession) HCSendFile ct fp -> E.catch @@ -284,7 +283,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = Handler $ \_ _ -> return ([], [], HCRedirect rt url) +redirectString rt url = Handler $ \_ _ -> return (id, id, HCRedirect rt url) ultDestKey :: String ultDestKey = "_ULT" @@ -347,8 +346,7 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = Handler $ \_ _ -> do - return ([], [], HCSendFile ct fp) +sendFile ct fp = Handler $ \_ _ -> return (id, id, HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -398,18 +396,18 @@ setSession :: String -- ^ key -> GHandler sub master () setSession k v = Handler $ \_ f -> do (a, b, c) <- f () - return (a, b ++ [(k, Just v)], c) + return (a, b . (:) (k, Just v), c) -- | Unsets a session variable. See 'setSession'. clearSession :: String -> GHandler sub master () clearSession k = Handler $ \_ f -> do (a, b, c) <- f () - return (a, b ++ [(k, Nothing)], c) + return (a, b . (:) (k, Nothing), c) addHeader :: Header -> GHandler sub master () addHeader h = Handler $ \_ f -> do (a, b, c) <- f () - return (a ++ [h], b, c) + return (a . (:) h, b, c) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 From cb15ae78f48442fe5a966f7e3f50c9aad1c3012e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Jun 2010 11:49:18 +0300 Subject: [PATCH 292/624] Handler is entirely transformers --- Yesod/Handler.hs | 93 +++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 61 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3b6d9615..c7dd008e 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -75,8 +75,11 @@ import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E import Control.Applicative -import "transformers" Control.Monad.IO.Class -import Control.Monad (liftM, ap) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Cont import System.IO import qualified Network.Wai as W @@ -100,14 +103,15 @@ data HandlerData sub master = HandlerData -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses. -newtype GHandler sub master a = Handler { - unHandler :: HandlerData sub master - -> (a -> IO Helper) - -> IO Helper -} +type GHandler sub master = + ReaderT (HandlerData sub master) ( + ContT HandlerContents ( + WriterT (Endo [Header]) ( + WriterT (Endo [(String, Maybe String)]) ( + IO + )))) type Endo a = a -> a -type Helper = (Endo [Header], Endo [(String, Maybe String)], HandlerContents) -- | A 'GHandler' limited to the case where the master and sub sites are the -- same. This is the usual case for application writing; only code written @@ -131,63 +135,32 @@ data HandlerContents = | HCSendFile ContentType FilePath | HCRedirect RedirectType String -instance Functor (GHandler sub master) where - fmap = liftM -instance Applicative (GHandler sub master) where - pure = return - (<*>) = ap -instance Monad (GHandler sub master) where - fail = failure . InternalError -- We want to catch all exceptions anyway - return x = Handler $ \_ f -> do - (a, b, c) <- f x - return (a, b, c) - Handler handler >>= f = Handler $ \rr cont -> do - handler rr (\a -> unHandler (f a) rr cont) -instance MonadIO (GHandler sub master) where - liftIO i = Handler $ \_ f -> do - i' <- i - (a, b, c) <- f i' - return (a, b, c) -{- FIXME -instance C.MonadCatchIO (GHandler sub master) where - catch (Handler m) f = - Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d) - block (Handler m) = - Handler $ E.block . m - unblock (Handler m) = - Handler $ E.unblock . m --} instance Failure ErrorResponse (GHandler sub master) where - failure e = Handler $ \_ _ -> return (id, id, HCError e) + failure = lift . ContT . const . return . HCError instance RequestReader (GHandler sub master) where - getRequest = handlerRequest <$> getData - -getData :: GHandler sub master (HandlerData sub master) -getData = Handler $ \r f -> do - (a, b, c) <- f r - return (a, b, c) + getRequest = handlerRequest <$> ask -- | Get the sub application argument. getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> getData +getYesodSub = handlerSub <$> ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master -getYesod = handlerMaster <$> getData +getYesod = handlerMaster <$> ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Routes master -> String) -getUrlRender = handlerRender <$> getData +getUrlRender = handlerRender <$> ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getRoute :: GHandler sub master (Maybe (Routes sub)) -getRoute = handlerRoute <$> getData +getRoute = handlerRoute <$> ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) -getRouteToMaster = handlerToMaster <$> getData +getRouteToMaster = handlerToMaster <$> ask modifySession :: [(String, String)] -> (String, Maybe String) -> [(String, String)] @@ -213,16 +186,20 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) - (headers, session', contents) <- E.catch - (unHandler handler HandlerData + let hd = HandlerData { handlerRequest = rr , handlerSub = tosa ma , handlerMaster = ma , handlerRoute = sroute , handlerRender = mrender , handlerToMaster = tomr - } $ \c -> return (id, id, HCContent $ chooseRep c)) - (\e -> return (id, id, HCError $ toErrorHandler e)) + } + ((contents, headers), session') <- E.catch ( + runWriterT + $ runWriterT + $ flip runContT (return . HCContent . chooseRep) + $ flip runReaderT hd handler + ) (\e -> return ((HCError $ toErrorHandler e, id), id)) let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts @@ -283,7 +260,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = Handler $ \_ _ -> return (id, id, HCRedirect rt url) +redirectString rt url = lift $ ContT $ const $ return $ HCRedirect rt url ultDestKey :: String ultDestKey = "_ULT" @@ -346,7 +323,7 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = Handler $ \_ _ -> return (id, id, HCSendFile ct fp) +sendFile ct fp = lift $ ContT $ const $ return $ HCSendFile ct fp -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -394,20 +371,14 @@ header a = addHeader . Header a setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k v = Handler $ \_ f -> do - (a, b, c) <- f () - return (a, b . (:) (k, Just v), c) +setSession k v = lift . lift . lift . tell $ (:) (k, Just v) -- | Unsets a session variable. See 'setSession'. clearSession :: String -> GHandler sub master () -clearSession k = Handler $ \_ f -> do - (a, b, c) <- f () - return (a, b . (:) (k, Nothing), c) +clearSession k = lift . lift . lift . tell $ (:) (k, Nothing) addHeader :: Header -> GHandler sub master () -addHeader h = Handler $ \_ f -> do - (a, b, c) <- f () - return (a . (:) h, b, c) +addHeader = lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 From 9fd1d162065d7c8c73e0a58214152f683da0a409 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Jun 2010 11:50:04 +0300 Subject: [PATCH 293/624] Removed unnecessary MonadCatchIO dependency --- yesod.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index d52969bd..6dee8ca3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,7 +45,6 @@ library hamlet >= 0.3.0 && < 0.4, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, - MonadCatchIO-transformers >= 0.2 && < 0.3, pureMD5 >= 1.1.0.0 && < 1.2, random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, From 81011135055dbd5911481f84eab8de32864f9f1e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Jun 2010 12:07:56 +0300 Subject: [PATCH 294/624] Removed buffering (was killing performance) --- Yesod/Dispatch.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5571db19..9fd28ffc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -33,7 +33,6 @@ import Web.Routes.Quasi import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import qualified Network.Wai.Enumerator as W import Network.Wai.Middleware.CleanPath import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -238,8 +237,7 @@ toWaiApp' y segments env = do hs''' = (W.ContentType, S.fromString ct) : hs'' return $ W.Response s hs''' $ case c of ContentFile fp -> Left fp - ContentEnum e -> Right $ W.buffer - $ W.Enumerator e + ContentEnum e -> Right $ W.Enumerator e -- | Fully render a route to an absolute URL. Since Yesod does this for you -- internally, you will rarely need access to this. However, if you need to From 08ad4709c0d3c166ecf88c53a7b9dcd696260869 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 16 Jun 2010 08:46:49 +0300 Subject: [PATCH 295/624] Replacing dash in static files --- Yesod/Helpers/Static.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 74ff1ad0..fe4a283f 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -110,6 +110,7 @@ staticFiles fp = do concat `fmap` mapM go fs where replace' '.' = '_' + replace' '-' = '_' replace' c = c go f = do let name = mkName $ intercalate "_" $ map (map replace') f From 72aad8659d5eab76ea5d2c9bce0f1da7c235e6f2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 20 Jun 2010 10:33:55 +0300 Subject: [PATCH 296/624] persistent changes --- Yesod/Formable.hs | 20 +++++++++++--------- Yesod/Helpers/Crud.hs | 3 ++- Yesod/Yesod.hs | 4 ++-- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 1bd8d556..cc7d56d1 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -25,7 +25,8 @@ module Yesod.Formable import Text.Hamlet import Data.Time (Day) import Control.Applicative -import Database.Persist (Persistable, Table (..)) +import Database.Persist (PersistField) +import Database.Persist.Helper (EntityDef (..)) import Data.Char (isAlphaNum, toUpper, isUpper) import Language.Haskell.TH.Syntax import Control.Monad (liftM, join) @@ -159,7 +160,7 @@ instance Formable (Maybe String) where | null s = Right Nothing | otherwise = Right $ Just s -instance Formable Html where +instance Formable (Html ()) where formable = fmap preEscapedString . input' go . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) @@ -257,7 +258,7 @@ instance Formable Int where [] -> Left ["Invalid integer"] newtype Slug = Slug { unSlug :: String } - deriving (Read, Eq, Show, SinglePiece, Persistable) + deriving (Read, Eq, Show, SinglePiece, PersistField) instance Formable Slug where formable x = input' go (fmap unSlug x) `check` asSlug @@ -277,28 +278,29 @@ share2 f g a = do g' <- g a return $ f' ++ g' -deriveFormable :: [Table] -> Q [Dec] +deriveFormable :: [EntityDef] -> Q [Dec] deriveFormable = mapM derive where - derive :: Table -> Q Dec + derive :: EntityDef -> Q Dec derive t = do - let cols = map (toLabel . fst) $ tableColumns t + let fst3 (x, _, _) = x + let cols = map (toLabel . fst3) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ tableName t) + let just' = just `AppE` ConE (mkName $ entityName t) let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) [] xs <- mapM (const $ newName "x") cols let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ tableName t) + let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) $ map VarP xs]] (NormalB $ go ap just' $ zip cols xs') [] return $ InstanceD [] (ConT ''Formable - `AppT` ConT (mkName $ tableName t)) + `AppT` ConT (mkName $ entityName t)) [FunD (mkName "formable") [c1, c2]] go ap just' = foldl (ap' ap) just' . map go' go' (label, ex) = diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 21224b1a..6c35cb3a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -153,7 +153,8 @@ crudHelper title me isPost = do %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] -defaultCrud :: (Persist i (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) +defaultCrud :: (PersistEntity i, YesodPersist a, + PersistMonad i ~ YesodDB a (GHandler (Crud a i) a)) => a -> Crud a i defaultCrud = const Crud { crudSelect = runDB $ select [] [] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3cf87abe..c3b129e0 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,7 +8,7 @@ module Yesod.Yesod , YesodSite (..) -- ** Persistence , YesodPersist (..) - , Persist (..) + , PersistEntity (..) -- * Convenience functions , applyLayout , applyLayoutJson @@ -27,7 +27,7 @@ import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) -import Database.Persist (Persist (..)) +import Database.Persist (PersistEntity (..)) import Web.Routes.Quasi (QuasiSite (..), Routes) From bc7fc91606ba64267b22d86819597f4acc56035c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 20 Jun 2010 10:34:14 +0300 Subject: [PATCH 297/624] BlazeHtml 0.1 --- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 4 ++-- Yesod/Helpers/AtomFeed.hs | 4 ++-- Yesod/Helpers/Sitemap.hs | 2 +- Yesod/Json.hs | 6 +++--- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 41efd060..6ddce335 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -24,7 +24,7 @@ import Web.Routes.Quasi (Routes) -- -- > PageContent url -> Hamlet url data PageContent url = PageContent - { pageTitle :: Html + { pageTitle :: Html () , pageHead :: Hamlet url , pageBody :: Hamlet url } diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index c7dd008e..165c6ede 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -306,14 +306,14 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: Html -> GHandler sub master () +setMessage :: Html () -> GHandler sub master () setMessage = setSession msgKey . L.toString . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) +getMessage :: GHandler sub master (Maybe (Html ())) getMessage = do clearSession msgKey fmap (fmap preEscapedString) $ lookupSession msgKey diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index f108eaba..90bbde4d 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -44,10 +44,10 @@ data AtomFeedEntry url = AtomFeedEntry { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String - , atomEntryContent :: Html + , atomEntryContent :: Html () } -xmlns :: AtomFeed url -> Html +xmlns :: AtomFeed url -> Html () xmlns _ = preEscapedString "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 7ac9256b..dbe21d6d 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -50,7 +50,7 @@ data SitemapUrl url = SitemapUrl , priority :: Double } -sitemapNS :: Html +sitemapNS :: Html () sitemapNS = string "http://www.sitemaps.org/schemas/sitemap/0.9" template :: [SitemapUrl url] -> Hamlet url diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 310f3a93..e54631b7 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -41,7 +41,7 @@ import Yesod.Content -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json = Json { unJson :: Html } +newtype Json = Json { unJson :: Html () } deriving Monoid -- | Extract the final result from the given 'Json' value. @@ -61,10 +61,10 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: Html -> Json +jsonScalar :: Html () -> Json jsonScalar s = Json $ mconcat [ preEscapedString "\"" - , unsafeBytestring $ S.concat $ L.toChunks $ encodeJson $ renderHtml s + , unsafeByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s , preEscapedString "\"" ] where From 31af9ec792dcb0babb479b42b621e0ce5cbb9793 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 20 Jun 2010 11:18:54 +0300 Subject: [PATCH 298/624] persistent changes --- Yesod/Helpers/Crud.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 6c35cb3a..a7a17467 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -153,8 +153,7 @@ crudHelper title me isPost = do %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] -defaultCrud :: (PersistEntity i, YesodPersist a, - PersistMonad i ~ YesodDB a (GHandler (Crud a i) a)) +defaultCrud :: (PersistEntity i, YesodPersist a, PersistMonad i ~ YesodDB a) => a -> Crud a i defaultCrud = const Crud { crudSelect = runDB $ select [] [] From 4d48695326f749150abbb31ec79e2a303e207da6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 22 Jun 2010 09:51:05 +0300 Subject: [PATCH 299/624] Bumped to Hamlet 0.3.1 --- yesod.cabal | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 6dee8ca3..7795eb6a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -9,16 +9,6 @@ description: Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. - . - As a quick overview, here is a fully-functional Hello World application: - . - > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} - > import Yesod - > data HelloWorld = HelloWorld - > mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] - > instance Yesod HelloWorld where approot _ = "" - > getHome = return $ RepPlain $ cs "Hello World!" - > main = toWaiApp HelloWorld >>= basicHandler 3000 category: Web stability: Stable cabal-version: >= 1.6 @@ -42,7 +32,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.4 && < 0.5, - hamlet >= 0.3.0 && < 0.4, + hamlet >= 0.3.1 && < 0.4, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, From f3bf9ff27d1d0274d6a77ecba166f14be4e2b49c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 22 Jun 2010 14:09:05 +0300 Subject: [PATCH 300/624] Removed -Werror --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 7795eb6a..23309ce6 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -57,7 +57,7 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - ghc-options: -Wall -Werror + ghc-options: -Wall executable runtests if flag(buildtests) From ed2f89ca591755803a96ff94ec2e8511edb539d3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 24 Jun 2010 22:12:38 +0300 Subject: [PATCH 301/624] YesodBreadcrumbs --- Yesod/Yesod.hs | 28 ++++++++++++++++++++++++++++ yesod.cabal | 2 +- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c3b129e0..99cd0fda 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -9,6 +9,9 @@ module Yesod.Yesod -- ** Persistence , YesodPersist (..) , PersistEntity (..) + -- ** Breadcrumbs + , YesodBreadcrumbs (..) + , breadcrumbs -- * Convenience functions , applyLayout , applyLayoutJson @@ -97,6 +100,31 @@ class Yesod a where isAuthorized :: a -> Routes a -> IO (Maybe String) isAuthorized _ _ = return Nothing +-- | A type-safe, concise method of creating breadcrumbs for pages. For each +-- resource, you declare the title of the page and the parent resource (if +-- present). +class YesodBreadcrumbs y where + -- | Returns the title and the parent resource, if available. If you return + -- a 'Nothing', then this is considered a top-level page. + breadcrumb :: Routes y -> Handler y (String, Maybe (Routes y)) + +-- | Gets the title of the current page and the hierarchy of parent pages, +-- along with their respective titles. +breadcrumbs :: YesodBreadcrumbs y => Handler y (String, [(Routes y, String)]) +breadcrumbs = do + x <- getRoute + case x of + Nothing -> return ("Not found", []) + Just y -> do + (title, next) <- breadcrumb y + z <- go [] next + return (title, z) + where + go back Nothing = return back + go back (Just this) = do + (title, next) <- breadcrumb this + go ((this, title) : back) next + -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title diff --git a/yesod.cabal b/yesod.cabal index 23309ce6..43fa9682 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.3.0 +version: 0.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From b8c74e86ffbcc824b3e9f4e6f64bfa72ff432390 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 29 Jun 2010 00:35:09 +0300 Subject: [PATCH 302/624] Fixes for CGI scripts in a subpath --- Yesod/Dispatch.hs | 2 +- yesod.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 9fd28ffc..378c01d3 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -171,7 +171,7 @@ toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp a = return $ gzip $ jsonp - $ cleanPath + $ cleanPathRel (B.pack $ approot a) $ toWaiApp' a toWaiApp' :: (Yesod y, YesodSite y) diff --git a/yesod.cabal b/yesod.cabal index 43fa9682..8e99bf93 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.3.1 +version: 0.3.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, wai >= 0.1.0 && < 0.2, - wai-extra >= 0.1.2 && < 0.2, + wai-extra >= 0.1.3 && < 0.2, authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, From e4dd6ddd2c491753590011dc5c58f9bb81d2ffd7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 27 Jun 2010 17:42:05 +0300 Subject: [PATCH 303/624] persistent 0.1 --- Yesod/Formable.hs | 2 +- Yesod/Helpers/Crud.hs | 6 ++++-- Yesod/Yesod.hs | 4 ++-- yesod.cabal | 4 ++-- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index cc7d56d1..33c1305a 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -26,7 +26,7 @@ import Text.Hamlet import Data.Time (Day) import Control.Applicative import Database.Persist (PersistField) -import Database.Persist.Helper (EntityDef (..)) +import Database.Persist.Base (EntityDef (..)) import Data.Char (isAlphaNum, toUpper, isUpper) import Language.Haskell.TH.Syntax import Control.Monad (liftM, join) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index a7a17467..8ad82c5e 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -153,8 +153,10 @@ crudHelper title me isPost = do %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] -defaultCrud :: (PersistEntity i, YesodPersist a, PersistMonad i ~ YesodDB a) - => a -> Crud a i +defaultCrud + :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)), + YesodPersist a) + => a -> Crud a i defaultCrud = const Crud { crudSelect = runDB $ select [] [] , crudReplace = \a -> runDB . replace a diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 99cd0fda..d70ba3d1 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,7 +8,7 @@ module Yesod.Yesod , YesodSite (..) -- ** Persistence , YesodPersist (..) - , PersistEntity (..) + , module Database.Persist -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -30,7 +30,7 @@ import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) -import Database.Persist (PersistEntity (..)) +import Database.Persist import Web.Routes.Quasi (QuasiSite (..), Routes) diff --git a/yesod.cabal b/yesod.cabal index 8e99bf93..97847baf 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.3.1.1 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -40,7 +40,7 @@ library control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1, - persistent >= 0.0.0 && < 0.1 + persistent >= 0.1.0 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From d2f0194163fe2549da5ec1f74b943475c898b79c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 29 Jun 2010 09:04:26 +0300 Subject: [PATCH 304/624] Replace ContT with MEitherT in Handler monad --- Yesod/Handler.hs | 17 +++++++++-------- yesod.cabal | 3 ++- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 165c6ede..de82ac6b 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -70,6 +70,7 @@ import Yesod.Content import Yesod.Internal import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) +import Data.Neither import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -79,7 +80,6 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader -import Control.Monad.Trans.Cont import System.IO import qualified Network.Wai as W @@ -105,7 +105,7 @@ data HandlerData sub master = HandlerData -- for headers, and an error-type monad for handling special responses. type GHandler sub master = ReaderT (HandlerData sub master) ( - ContT HandlerContents ( + MEitherT HandlerContents ( WriterT (Endo [Header]) ( WriterT (Endo [(String, Maybe String)]) ( IO @@ -136,7 +136,7 @@ data HandlerContents = | HCRedirect RedirectType String instance Failure ErrorResponse (GHandler sub master) where - failure = lift . ContT . const . return . HCError + failure = lift . throwMEither . HCError instance RequestReader (GHandler sub master) where getRequest = handlerRequest <$> ask @@ -194,12 +194,13 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRender = mrender , handlerToMaster = tomr } - ((contents, headers), session') <- E.catch ( + ((contents', headers), session') <- E.catch ( runWriterT $ runWriterT - $ flip runContT (return . HCContent . chooseRep) + $ runMEitherT $ flip runReaderT hd handler - ) (\e -> return ((HCError $ toErrorHandler e, id), id)) + ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id)) + let contents = meither id (HCContent . chooseRep) contents' let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts @@ -260,7 +261,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = lift $ ContT $ const $ return $ HCRedirect rt url +redirectString rt url = lift $ throwMEither $ HCRedirect rt url ultDestKey :: String ultDestKey = "_ULT" @@ -323,7 +324,7 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = lift $ ContT $ const $ return $ HCSendFile ct fp +sendFile ct fp = lift $ throwMEither $ HCSendFile ct fp -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a diff --git a/yesod.cabal b/yesod.cabal index 97847baf..165caf72 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -40,7 +40,8 @@ library control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1, - persistent >= 0.1.0 && < 0.2 + persistent >= 0.1.0 && < 0.2, + neither >= 0.0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From a8e6485e460dc841a4bc884cad84318e466c4c95 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 29 Jun 2010 09:11:05 +0300 Subject: [PATCH 305/624] GHandler is a newtype (gives better compiler errors) --- Yesod/Handler.hs | 35 ++++++++++++++++++++--------------- yesod.cabal | 3 ++- 2 files changed, 22 insertions(+), 16 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index de82ac6b..d4cef5b1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -80,6 +81,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader +import Control.Monad.CatchIO (MonadCatchIO) import System.IO import qualified Network.Wai as W @@ -103,13 +105,15 @@ data HandlerData sub master = HandlerData -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses. -type GHandler sub master = +newtype GHandler sub master a = GHandler { unGHandler :: ReaderT (HandlerData sub master) ( MEitherT HandlerContents ( WriterT (Endo [Header]) ( WriterT (Endo [(String, Maybe String)]) ( IO - )))) + )))) a +} + deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) type Endo a = a -> a @@ -136,31 +140,31 @@ data HandlerContents = | HCRedirect RedirectType String instance Failure ErrorResponse (GHandler sub master) where - failure = lift . throwMEither . HCError + failure = GHandler . lift . throwMEither . HCError instance RequestReader (GHandler sub master) where - getRequest = handlerRequest <$> ask + getRequest = handlerRequest <$> GHandler ask -- | Get the sub application argument. getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> ask +getYesodSub = handlerSub <$> GHandler ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master -getYesod = handlerMaster <$> ask +getYesod = handlerMaster <$> GHandler ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Routes master -> String) -getUrlRender = handlerRender <$> ask +getUrlRender = handlerRender <$> GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getRoute :: GHandler sub master (Maybe (Routes sub)) -getRoute = handlerRoute <$> ask +getRoute = handlerRoute <$> GHandler ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) -getRouteToMaster = handlerToMaster <$> ask +getRouteToMaster = handlerToMaster <$> GHandler ask modifySession :: [(String, String)] -> (String, Maybe String) -> [(String, String)] @@ -198,7 +202,8 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do runWriterT $ runWriterT $ runMEitherT - $ flip runReaderT hd handler + $ flip runReaderT hd + $ unGHandler handler ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id)) let contents = meither id (HCContent . chooseRep) contents' let finalSession = foldl' modifySession (reqSession rr) $ session' [] @@ -261,7 +266,7 @@ redirectParams rt url params = do -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt url = lift $ throwMEither $ HCRedirect rt url +redirectString rt = GHandler . lift . throwMEither . HCRedirect rt ultDestKey :: String ultDestKey = "_ULT" @@ -324,7 +329,7 @@ getMessage = do -- For some backends, this is more efficient than reading in the file to -- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct fp = lift $ throwMEither $ HCSendFile ct fp +sendFile ct = GHandler . lift . throwMEither . HCSendFile ct -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a @@ -372,14 +377,14 @@ header a = addHeader . Header a setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k v = lift . lift . lift . tell $ (:) (k, Just v) +setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v) -- | Unsets a session variable. See 'setSession'. clearSession :: String -> GHandler sub master () -clearSession k = lift . lift . lift . tell $ (:) (k, Nothing) +clearSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing) addHeader :: Header -> GHandler sub master () -addHeader = lift . lift . tell . (:) +addHeader = GHandler . lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status getStatus NotFound = W.Status404 diff --git a/yesod.cabal b/yesod.cabal index 165caf72..0eb20e40 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -41,7 +41,8 @@ library cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1, persistent >= 0.1.0 && < 0.2, - neither >= 0.0.0 && < 0.1 + neither >= 0.0.0 && < 0.1, + MonadCatchIO-transformers >= 0.2.2.0 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From f7f42cad1d27656c1d18e322d205665d62260cba Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 29 Jun 2010 09:35:49 +0300 Subject: [PATCH 306/624] Facebook support in auth --- Yesod/Helpers/Auth.hs | 58 ++++++++++++++++++++++++++++++++++++++----- yesod.cabal | 5 ++-- 2 files changed, 55 insertions(+), 8 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f920bb3c..baca47f5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -38,6 +38,7 @@ module Yesod.Helpers.Auth import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId +import qualified Web.Authenticate.Facebook as Facebook import Yesod @@ -51,6 +52,7 @@ import System.IO import Control.Monad.Attempt import Data.Monoid (mempty) import Data.ByteString.Lazy.UTF8 (fromString) +import Data.Object class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other @@ -82,10 +84,12 @@ data Auth = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String , authEmailSettings :: Maybe AuthEmailSettings + , authFacebook :: Maybe (String, String) -- ^ client id and secret + , authFacebookPerms :: [String] } -- | Which subsystem authenticated the user. -data AuthType = AuthOpenId | AuthRpxnow | AuthEmail +data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook deriving (Show, Read, Eq) type Email = String @@ -117,6 +121,7 @@ data Creds = Creds , credsEmail :: Maybe String -- ^ Verified e-mail address. , credsDisplayName :: Maybe String -- ^ Display name. , credsId :: Maybe Integer -- ^ Numeric ID, if used. + , credsFacebookToken :: Maybe Facebook.AccessToken } deriving (Show, Read, Eq) @@ -147,6 +152,9 @@ mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| /openid/complete OpenIdComplete GET /login/rpxnow RpxnowR +/facebook FacebookR GET +/facebook/start StartFacebookR GET + /register EmailRegisterR GET POST /verify/#EmailId/#String EmailVerifyR GET /login EmailLoginR GET POST @@ -206,7 +214,7 @@ getOpenIdComplete = do redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do y <- getYesod - setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) [] + setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res @@ -229,6 +237,7 @@ handleRpxnowR = do (lookup "verifiedEmail" extra) (getDisplayName extra) Nothing + Nothing setCreds creds extra either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ case pp "dest" of @@ -328,7 +337,8 @@ getEmailVerifyR lid key = do case (realKey == Just key, memail) of (True, Just email) -> do liftIO $ verifyAccount ae lid - setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] + setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) + Nothing) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR _ -> applyLayout "Invalid verification key" mempty [$hamlet| @@ -376,7 +386,8 @@ postEmailLoginR = do _ -> Nothing case mlid of Just lid -> do - setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) [] + setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) + Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do setMessage $ string "Invalid email/password combination" @@ -389,7 +400,7 @@ getEmailPasswordR = do toMaster <- getRouteToMaster mcreds <- maybeCreds case mcreds of - Just (Creds _ AuthEmail _ _ (Just _)) -> return () + Just (Creds _ AuthEmail _ _ (Just _) _) -> return () _ -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR @@ -425,7 +436,7 @@ postEmailPasswordR = do redirect RedirectTemporary $ toMaster EmailPasswordR mcreds <- maybeCreds lid <- case mcreds of - Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid + Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid _ -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR @@ -481,3 +492,38 @@ inMemoryEmailSettings = do spgo eid pass (email, EmailCreds eid' pass' status key) | eid == eid' = (email, EmailCreds eid (Just pass) status key) | otherwise = (email, EmailCreds eid' pass' status key) + +getFacebookR :: YesodAuth master => GHandler Auth master () +getFacebookR = do + y <- getYesod + a <- authFacebook <$> getYesodSub + case a of + Nothing -> notFound + Just (cid, secret) -> do + render <- getUrlRender + tm <- getRouteToMaster + let fb = Facebook.Facebook cid secret $ render $ tm FacebookR + code <- runFormGet $ required $ input "code" + at <- liftIO $ Facebook.getAccessToken fb code + so <- liftIO $ Facebook.getGraphData at "me" + let c = fromMaybe (error "Invalid response from Facebook") $ do + m <- fromMapping so + id' <- lookupScalar "id" m + let name = lookupScalar "name" m + let email = lookupScalar "email" m + let id'' = "http://graph.facebook.com/" ++ id' + return $ Creds id'' AuthFacebook email name Nothing $ Just at + setCreds c [] + redirectUltDest RedirectTemporary $ defaultDest y + +getStartFacebookR :: GHandler Auth master () +getStartFacebookR = do + y <- getYesodSub + case authFacebook y of + Nothing -> notFound + Just (cid, secret) -> do + render <- getUrlRender + tm <- getRouteToMaster + let fb = Facebook.Facebook cid secret $ render $ tm FacebookR + let fburl = Facebook.getForwardUrl fb $ authFacebookPerms y + redirectString RedirectTemporary fburl diff --git a/yesod.cabal b/yesod.cabal index 0eb20e40..564fbf96 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -24,7 +24,7 @@ library time >= 1.1.3 && < 1.2, wai >= 0.1.0 && < 0.2, wai-extra >= 0.1.3 && < 0.2, - authenticate >= 0.6.2 && < 0.7, + authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, text >= 0.5 && < 0.8, @@ -42,7 +42,8 @@ library old-locale >= 1.0.0.2 && < 1.1, persistent >= 0.1.0 && < 0.2, neither >= 0.0.0 && < 0.1, - MonadCatchIO-transformers >= 0.2.2.0 && < 0.3 + MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, + data-object >= 0.3.1 && < 0.4 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From c91a4ada567f17752b7ff15826bd2d7072a4cb0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 12:23:55 +0300 Subject: [PATCH 307/624] Changes reflecting web-routes-quasi modifications. Minimal changes to get hello world working. --- Yesod.hs | 2 -- Yesod/Dispatch.hs | 82 ++++++++++++++++++++++++++--------------------- Yesod/Formable.hs | 2 +- Yesod/Hamlet.hs | 1 - Yesod/Handler.hs | 6 ++-- Yesod/Yesod.hs | 6 ++-- helloworld.hs | 7 ++++ 7 files changed, 61 insertions(+), 45 deletions(-) create mode 100644 helloworld.hs diff --git a/Yesod.hs b/Yesod.hs index 90fa85bd..073a625a 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,7 +13,6 @@ module Yesod , module Yesod.Formable , Application , liftIO - , Routes ) where #if TEST @@ -34,4 +33,3 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) -import Web.Routes.Quasi (Routes) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 378c01d3..3ac56f2f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -18,7 +18,6 @@ module Yesod.Dispatch , basicHandler -- * Utilities , fullRender - , quasiRender #if TEST , testSuite #endif @@ -30,6 +29,9 @@ import Yesod.Request import Yesod.Internal import Web.Routes.Quasi +import Web.Routes.Quasi.Parse +import Web.Routes.Quasi.TH +import Web.Routes.Site import Language.Haskell.TH.Syntax import qualified Network.Wai as W @@ -102,7 +104,7 @@ mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do (x, _) <- mkYesodGeneral name [] [] False res let rname = mkName $ "resources" ++ name - eres <- liftResources res + eres <- lift res let y = [ SigD rname $ ListT `AppT` ConT ''Resource , FunD rname [Clause [] (NormalB eres) []] ] @@ -142,6 +144,32 @@ mkYesodGeneral name args clazzes isSub res = do $ map (\x -> (x, [])) ("master" : args) ++ clazzes explode <- [|explodeHandler|] + let th = map thResourceFromResource res + w' <- createRoutes th + let w = DataD [] (mkName $ name ++ "Routes") [] w' [] + let x = TySynInstD ''Routes [arg] $ ConT $ mkName $ name ++ "Routes" + + parse' <- createParse th + parse'' <- newName "parse" + let parse = LetE [FunD parse'' parse'] $ VarE parse'' + + render' <- createRender th + render'' <- newName "render" + let render = LetE [FunD render'' render'] $ VarE render'' + + id' <- [|id|] + modMaster <- [|fmap chooseRep|] + dispatch' <- createDispatch modMaster id' th + dispatch'' <- newName "dispatch" + let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' + + site <- [|Site|] + let site' = site `AppE` dispatch `AppE` render `AppE` parse + let y = InstanceD [] (ConT ''YesodSite `AppT` arg) + [ FunD (mkName "getSite") [Clause [] (NormalB site') []] + ] + let z = undefined + {- QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings { crRoutes = mkName $ name ++ "Routes" , crApplication = ConT ''YesodApp @@ -153,7 +181,11 @@ mkYesodGeneral name args clazzes isSub res = do then Right clazzes' else Left (ConT name') } - return ([w, x], (if isSub then id else (:) yes) [y, z]) + -} + return ([w, x], [y]) + +thResourceFromResource :: Resource -> THResource +thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms) compact :: [(String, [a])] -> [(String, [a])] compact [] = [] @@ -193,41 +225,23 @@ toWaiApp' y segments env = do method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments - eurl = quasiParse site pathSegments + eurl = parsePathSegments site pathSegments render u = fromMaybe - (fullRender (approot y) (quasiRender site) u) + (fullRender (approot y) (formatPathSegments site) u) (urlRenderOverride y u) rr <- parseWaiRequest env session' onRequest y rr - ya <- - case eurl of - Left _ -> return $ runHandler (errorHandler y NotFound) - render - Nothing - id - y - id - Right url -> do - auth <- isAuthorized y url - case auth of - Nothing -> return $ quasiDispatch site - render - url - id - y - id - (badMethodApp method) - method - Just msg -> - return $ runHandler - (errorHandler y $ PermissionDenied msg) - render - (Just url) - id - y - id + let h = + case eurl of + Left _ -> errorHandler y NotFound + Right url -> do + -- FIXME auth <- isAuthorized y url + case handleSite site render url method of + Nothing -> errorHandler y $ BadMethod method + Just h' -> h' let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler y er) render eurl' id y id + let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName @@ -271,10 +285,6 @@ basicHandler port app = do SS.run port app Just _ -> CGI.run app -badMethodApp :: String -> YesodApp -badMethodApp m = YesodApp $ \eh req cts - -> unYesodApp (eh $ BadMethod m) eh req cts - fixSegs :: [String] -> [String] fixSegs [] = [] fixSegs [x] diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs index 33c1305a..bb39be50 100644 --- a/Yesod/Formable.hs +++ b/Yesod/Formable.hs @@ -38,7 +38,7 @@ import Yesod.Request import Yesod.Handler import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State -import Web.Routes.Quasi (Routes, SinglePiece) +import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 6ddce335..7aa6992b 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -17,7 +17,6 @@ module Yesod.Hamlet import Text.Hamlet import Yesod.Content import Yesod.Handler -import Web.Routes.Quasi (Routes) -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d4cef5b1..1b47d79a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -63,13 +63,13 @@ module Yesod.Handler -- * Internal Yesod , runHandler , YesodApp (..) + , Routes ) where import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal -import Web.Routes.Quasi (Routes) import Data.List (foldl', intercalate) import Data.Neither @@ -81,7 +81,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader -import Control.Monad.CatchIO (MonadCatchIO) +import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import System.IO import qualified Network.Wai as W @@ -93,6 +93,8 @@ import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr) +type family Routes a + data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d70ba3d1..870fb3a8 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -31,13 +31,13 @@ import qualified Web.ClientSession as CS import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) import Database.Persist - -import Web.Routes.Quasi (QuasiSite (..), Routes) +import Web.Routes.Site (Site) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class YesodSite y where - getSite :: QuasiSite YesodApp y y + getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) +type Method = String -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. diff --git a/helloworld.hs b/helloworld.hs new file mode 100644 index 00000000..2e26b7a8 --- /dev/null +++ b/helloworld.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +data HelloWorld = HelloWorld +mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] +instance Yesod HelloWorld where approot _ = "" +getHome = return $ RepPlain $ toContent "Hello World!" +main = toWaiApp HelloWorld >>= basicHandler 3000 From 2f17cda10dfa0ba355488bb59a798b3661258889 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 12:44:57 +0300 Subject: [PATCH 308/624] Routes is data family, not type family --- Yesod/Dispatch.hs | 4 ++-- Yesod/Handler.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 3ac56f2f..51ccbefb 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -146,8 +146,8 @@ mkYesodGeneral name args clazzes isSub res = do explode <- [|explodeHandler|] let th = map thResourceFromResource res w' <- createRoutes th - let w = DataD [] (mkName $ name ++ "Routes") [] w' [] - let x = TySynInstD ''Routes [arg] $ ConT $ mkName $ name ++ "Routes" + let w = DataInstD [] ''Routes [arg] w' [] + let x = TySynD (mkName $ name ++ "Routes") [] $ ConT ''Routes `AppT` arg parse' <- createParse th parse'' <- newName "parse" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1b47d79a..e15966bb 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -93,7 +93,7 @@ import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr) -type family Routes a +data family Routes a data HandlerData sub master = HandlerData { handlerRequest :: Request From 0e6f32f4a69362f47eab3d3f589a9b74b40bce60 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 14:24:36 +0300 Subject: [PATCH 309/624] Subsites working with new web-routes-quasi --- Yesod/Dispatch.hs | 99 ++++++++++++++++++++++++----------------- Yesod/Handler.hs | 20 +++++++++ Yesod/Helpers/Auth.hs | 3 +- Yesod/Helpers/Crud.hs | 5 ++- Yesod/Helpers/Static.hs | 11 ++--- Yesod/Yesod.hs | 5 +++ yesod.cabal | 2 +- 7 files changed, 93 insertions(+), 52 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 51ccbefb..2ebb3b01 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -57,6 +57,7 @@ import Control.Monad import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS +import Data.Char (isLower) import Data.Serialize import qualified Data.Serialize as Ser @@ -114,17 +115,13 @@ mkYesodData name res = do mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -explodeHandler :: HasReps c - => GHandler sub master c - -> (Routes master -> String) - -> Routes sub - -> (Routes sub -> Routes master) - -> master - -> (master -> sub) - -> YesodApp - -> String - -> YesodApp -explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f +typeHelper :: String -> Type +typeHelper = + foldl1 AppT . map go . words + where + go s@(x:_) + | isLower x = VarT $ mkName s + | otherwise = ConT $ mkName s mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument @@ -136,18 +133,13 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - let site = mkName $ "site" ++ name - let gsbod = NormalB $ VarE site - let yes' = FunD (mkName "getSite") [Clause [] gsbod []] - let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - let clazzes' = compact - $ map (\x -> (x, [])) ("master" : args) ++ - clazzes - explode <- [|explodeHandler|] - let th = map thResourceFromResource res + let clazzes' = map (\(x, y) -> ClassP x [typeHelper y]) + $ concatMap (\(x, y) -> zip y $ repeat x) + $ compact + $ map (\x -> (x, [])) ("master" : args) ++ clazzes + th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th let w = DataInstD [] ''Routes [arg] w' [] - let x = TySynD (mkName $ name ++ "Routes") [] $ ConT ''Routes `AppT` arg parse' <- createParse th parse'' <- newName "parse" @@ -157,35 +149,58 @@ mkYesodGeneral name args clazzes isSub res = do render'' <- newName "render" let render = LetE [FunD render'' render'] $ VarE render'' - id' <- [|id|] + tmh <- [|toMasterHandler|] modMaster <- [|fmap chooseRep|] - dispatch' <- createDispatch modMaster id' th + dispatch' <- createDispatch modMaster tmh th dispatch'' <- newName "dispatch" let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' site <- [|Site|] let site' = site `AppE` dispatch `AppE` render `AppE` parse - let y = InstanceD [] (ConT ''YesodSite `AppT` arg) - [ FunD (mkName "getSite") [Clause [] (NormalB site') []] + let (ctx, ytyp, yfunc) = + if isSub + then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") + else ([], ConT ''YesodSite `AppT` arg, "getSite") + let y = InstanceD ctx ytyp + [ FunD (mkName yfunc) [Clause [] (NormalB site') []] ] - let z = undefined - {- - QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings - { crRoutes = mkName $ name ++ "Routes" - , crApplication = ConT ''YesodApp - , crArgument = arg - , crExplode = explode - , crResources = res - , crSite = site - , crMaster = if isSub - then Right clazzes' - else Left (ConT name') - } - -} - return ([w, x], [y]) + return ([w], [y]) -thResourceFromResource :: Resource -> THResource -thResourceFromResource (Resource n ps (ByMethod ms)) = (n, Simple ps $ map fst ms) +isStatic :: Piece -> Bool +isStatic StaticPiece{} = True +isStatic _ = False + +fromStatic :: Piece -> String +fromStatic (StaticPiece s) = s +fromStatic _ = error "fromStatic" + +thResourceFromResource :: Type -> Resource -> Q THResource +thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) + | all isStatic ps && any (any isLower) atts = do + let stype' = ConT $ mkName stype + gss <- [|getSubSite|] + let inside = ConT ''Maybe `AppT` + (ConT ''GHandler `AppT` stype' `AppT` master `AppT` + ConT ''ChooseRep) + let typ = ConT ''Site `AppT` + (ConT ''Routes `AppT` stype') `AppT` + (ArrowT `AppT` ConT ''String `AppT` inside) + let gss' = gss `SigE` typ + parse' <- [|parsePathSegments|] + let parse = parse' `AppE` gss' + render' <- [|formatPathSegments|] + let render = render' `AppE` gss' + dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] + let dispatch = dispatch' `AppE` gss' + return (n, SubSite + { ssType = ConT ''Routes `AppT` stype' + , ssParse = parse + , ssRender = render + , ssDispatch = dispatch + , ssToMasterArg = VarE $ mkName toSubArg + , ssPieces = map fromStatic ps + }) +thResourceFromResource _ (Resource n ps attribs) = return (n, Simple ps attribs) compact :: [(String, [a])] -> [(String, [a])] compact [] = [] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e15966bb..925d4ac4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -64,6 +64,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , Routes + , toMasterHandler ) where import Prelude hiding (catch) @@ -104,6 +105,25 @@ data HandlerData sub master = HandlerData , handlerToMaster :: Routes sub -> Routes master } +handlerSubData :: (Routes sub -> Routes master) + -> (master -> sub) + -> Routes sub + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubData tm ts route hd = hd + { handlerSub = ts $ handlerMaster hd + , handlerToMaster = tm + , handlerRoute = Just route + } + +toMasterHandler :: (Routes sub -> Routes master) + -> (master -> sub) + -> Routes sub + -> GHandler sub master a + -> Handler master a +toMasterHandler tm ts route (GHandler h) = + GHandler $ withReaderT (handlerSubData tm ts route) h + -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of reader for basic arguments, a writer -- for headers, and an error-type monad for handling special responses. diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index baca47f5..cb55cd41 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -22,8 +22,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..) - , AuthRoutes (..) - , siteAuth + , Routes (..) -- * Settings , YesodAuth (..) , Creds (..) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 8ad82c5e..7964790a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -1,12 +1,13 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..) - , CrudRoutes (..) + , Routes (..) , defaultCrud - , siteCrud ) where import Yesod.Yesod diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index fe4a283f..8a496bdb 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static @@ -25,8 +27,7 @@ module Yesod.Helpers.Static ( -- * Subsite Static (..) - , StaticRoutes (..) - , siteStatic + , Routes (..) -- * Lookup files in filesystem , fileLookupDir , staticFiles @@ -52,9 +53,9 @@ import Test.HUnit hiding (Test) -- see 'fileLookupDir'. data Static = Static (FilePath -> IO (Maybe (Either FilePath Content))) -$(mkYesodSub "Static" [] [$parseRoutes| +mkYesodSub "Static" [] [$parseRoutes| *Strings StaticRoute GET -|]) +|] -- | Lookup files in a specific directory. -- @@ -117,7 +118,7 @@ staticFiles fp = do f' <- lift f let sr = ConE $ mkName "StaticRoute" return - [ SigD name $ ConT ''StaticRoutes + [ SigD name $ ConT ''Routes `AppT` ConT ''Static , FunD name [ Clause [] (NormalB $ sr `AppE` f') [] ] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 870fb3a8..e59856f3 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,11 +1,13 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes Yesod (..) , YesodSite (..) + , YesodSubSite (..) -- ** Persistence , YesodPersist (..) , module Database.Persist @@ -39,6 +41,9 @@ class YesodSite y where getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) type Method = String +class YesodSubSite s y where + getSubSite :: Site (Routes s) (Method -> Maybe (GHandler s y ChooseRep)) + -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. class Yesod a where diff --git a/yesod.cabal b/yesod.cabal index 564fbf96..890e7af0 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -31,7 +31,7 @@ library utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.4 && < 0.5, + web-routes-quasi >= 0.5 && < 0.6, hamlet >= 0.3.1 && < 0.4, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, From 949e3bff2f2cb0b009ef57c8a7e6faed9dd3cd0f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 20:38:32 +0300 Subject: [PATCH 310/624] Methods must be upper case --- Yesod/Dispatch.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2ebb3b01..78ab8b0b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -57,7 +57,7 @@ import Control.Monad import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS -import Data.Char (isLower) +import Data.Char (isLower, isUpper) import Data.Serialize import qualified Data.Serialize as Ser @@ -175,6 +175,8 @@ fromStatic (StaticPiece s) = s fromStatic _ = error "fromStatic" thResourceFromResource :: Type -> Resource -> Q THResource +thResourceFromResource _ (Resource n ps attribs) + | all (all isUpper) attribs = return (n, Simple ps attribs) thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) | all isStatic ps && any (any isLower) atts = do let stype' = ConT $ mkName stype @@ -200,7 +202,8 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) , ssToMasterArg = VarE $ mkName toSubArg , ssPieces = map fromStatic ps }) -thResourceFromResource _ (Resource n ps attribs) = return (n, Simple ps attribs) +thResourceFromResource _ (Resource n _ _) = + error $ "Invalid attributes for resource: " ++ n compact :: [(String, [a])] -> [(String, [a])] compact [] = [] From ac8d0fb800c6cbcae271965791b16d8de488e3f2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 20:39:33 +0300 Subject: [PATCH 311/624] Better signature for errorHandler --- Yesod/Dispatch.hs | 6 +++--- Yesod/Yesod.hs | 11 +++-------- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 78ab8b0b..211ef741 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -251,14 +251,14 @@ toWaiApp' y segments env = do onRequest y rr let h = case eurl of - Left _ -> errorHandler y NotFound + Left _ -> errorHandler NotFound Right url -> do -- FIXME auth <- isAuthorized y url case handleSite site render url method of - Nothing -> errorHandler y $ BadMethod method + Nothing -> errorHandler $ BadMethod method Just h' -> h' let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler y er) render eurl' id y id + let eh er = runHandler (errorHandler er) render eurl' id y id let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index e59856f3..fa9c5213 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -69,11 +69,8 @@ class Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: Yesod y - => a - -> ErrorResponse - -> Handler y ChooseRep - errorHandler _ = defaultErrorHandler + errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. defaultLayout :: PageContent (Routes a) -> GHandler sub a Content @@ -167,9 +164,7 @@ applyLayout' :: Yesod master applyLayout' s = fmap chooseRep . applyLayout s mempty -- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y - => ErrorResponse - -> Handler y ChooseRep +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| From 729751f7420fd941eed73d6079ec02a79a808d61 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 20:46:47 +0300 Subject: [PATCH 312/624] Fixed type signature in some functions in Yesod typeclass --- Yesod/Dispatch.hs | 8 ++++---- Yesod/Handler.hs | 4 ++-- Yesod/Yesod.hs | 14 +++++++------- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 211ef741..30297ddf 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -246,14 +246,14 @@ toWaiApp' y segments env = do eurl = parsePathSegments site pathSegments render u = fromMaybe (fullRender (approot y) (formatPathSegments site) u) - (urlRenderOverride y u) + (urlRenderOverride u) rr <- parseWaiRequest env session' - onRequest y rr - let h = + let h = do + onRequest case eurl of Left _ -> errorHandler NotFound Right url -> do - -- FIXME auth <- isAuthorized y url + isAuthorized url >>= maybe (return ()) permissionDenied case handleSite site render url method of Nothing -> errorHandler $ BadMethod method Just h' -> h' diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 925d4ac4..4ad0e4c1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -364,8 +364,8 @@ badMethod = do failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w -- | Return a 403 permission denied page. -permissionDenied :: Failure ErrorResponse m => m a -permissionDenied = failure $ PermissionDenied "Permission denied" +permissionDenied :: Failure ErrorResponse m => String -> m a +permissionDenied = failure . PermissionDenied -- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index fa9c5213..381df617 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -85,22 +85,22 @@ class Yesod a where |] -- | Gets called at the beginning of each request. Useful for logging. - onRequest :: a -> Request -> IO () - onRequest _ _ = return () + onRequest :: GHandler sub a () + onRequest = return () -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Routes a -> Maybe String - urlRenderOverride _ _ = Nothing + urlRenderOverride :: Routes a -> Maybe String + urlRenderOverride _ = Nothing - -- | Determine is a request is authorized or not. + -- | Determine if a request is authorized or not. -- -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: a -> Routes a -> IO (Maybe String) - isAuthorized _ _ = return Nothing + isAuthorized :: Routes a -> Handler a (Maybe String) + isAuthorized _ = return Nothing -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if From d34f44fd53c4e696c2f7076a26ef486d10259a66 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:11:15 +0300 Subject: [PATCH 313/624] More sane Yesod.Request lookup functions --- Yesod/Form.hs | 9 +++-- Yesod/Helpers/Auth.hs | 36 ++++++++---------- Yesod/Request.hs | 88 +++++++++++++++++++++++-------------------- 3 files changed, 69 insertions(+), 64 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 03f9c0fc..3dafee0b 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -63,15 +63,18 @@ runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m) => Form x -> m x runFormPost f = do rr <- getRequest - pp <- postParams rr - runFormGeneric pp f + (pp, _) <- liftIO $ reqRequestBody rr + runFormGeneric (flip lookup' pp) f + +lookup' :: Eq a => a -> [(a, b)] -> [b] +lookup' a = map snd . filter (\x -> a == fst x) -- | Run a form against GET parameters. runFormGet :: (RequestReader m, Failure ErrorResponse m) => Form x -> m x runFormGet f = do rr <- getRequest - runFormGeneric (getParams rr) f + runFormGeneric (flip lookupGetParams rr) f input :: ParamName -> Form [ParamValue] input pn = Form $ \l -> Right (Just pn, l pn) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index cb55cd41..aee6537c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -168,17 +168,14 @@ testOpenId = do getOpenIdR :: Yesod master => GHandler Auth master RepHtml getOpenIdR = do testOpenId - rr <- getRequest - case getParams rr "dest" of - [] -> return () - (x:_) -> setUltDestString x + lookupGetParam "dest" >>= maybe (return ()) setUltDestString rtom <- getRouteToMaster message <- getMessage applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@ - %label!for=openid OpenID: + %label!for=openid OpenID: $ %input#openid!type=text!name=openid %input!type=submit!value=Login |] @@ -186,10 +183,7 @@ $maybe message msg getOpenIdForward :: GHandler Auth master () getOpenIdForward = do testOpenId - rr <- getRequest - oid <- case getParams rr "openid" of - [x] -> return x - _ -> invalidArgs [("openid", "Expected single parameter")] + oid <- runFormGet $ required $ input "openid" render <- getUrlRender toMaster <- getRouteToMaster let complete = render $ toMaster OpenIdComplete @@ -224,11 +218,11 @@ handleRpxnowR = do apiKey <- case authRpxnowApiKey auth of Just x -> return x Nothing -> notFound - rr <- getRequest - pp <- postParams rr - let token = case getParams rr "token" ++ pp "token" of - [] -> invalidArgs [("token", "Value not supplied")] - (x:_) -> x + token1 <- lookupGetParam "token" + token2 <- lookupPostParam "token" + let token = case token1 `mplus` token2 of + Nothing -> invalidArgs [("token", "Value not supplied")] + Just x -> x Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token let creds = Creds ident @@ -238,14 +232,14 @@ handleRpxnowR = do Nothing Nothing setCreds creds extra + dest1 <- lookupPostParam "dest" + dest2 <- lookupGetParam "dest" either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ - case pp "dest" of - (d:_) -> Right d - [] -> case getParams rr "dest" of - [] -> Left $ defaultDest ay - ("":_) -> Left $ defaultDest ay - (('#':rest):_) -> Right rest - (s:_) -> Right s + case dest1 `mplus` dest2 of + Just "" -> Left $ defaultDest ay + Nothing -> Left $ defaultDest ay + Just ('#':d) -> Right d + Just d -> Right d -- | Get some form of a display name. getDisplayName :: [(String, String)] -> Maybe String diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 10c9ef10..f69c0a67 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -29,11 +29,13 @@ module Yesod.Request , lookupPostParam , lookupCookie , lookupSession - -- ** Alternate - , getParams - , postParams - , cookies - , session + , lookupFile + -- ** Multi-lookup + , lookupGetParams + , lookupPostParams + , lookupCookies + , lookupSessions + , lookupFiles -- * Parameter type synonyms , ParamName , ParamValue @@ -46,6 +48,7 @@ import "transformers" Control.Monad.IO.Class import Control.Monad (liftM) import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r +import Data.Maybe (listToMaybe) type ParamName = String type ParamValue = String @@ -99,59 +102,64 @@ data Request = Request , reqLangs :: [String] } -multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue] -multiLookup [] _ = [] -multiLookup ((k, v):rest) pn - | k == pn = v : multiLookup rest pn - | otherwise = multiLookup rest pn +lookup' :: Eq a => a -> [(a, b)] -> [b] +lookup' a = map snd . filter (\x -> a == fst x) --- | All GET paramater values with the given name. -getParams :: RequestReader m => m (ParamName -> [ParamValue]) -getParams = do +-- | Lookup for GET parameters. +lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] +lookupGetParams pn = do rr <- getRequest - return $ multiLookup $ reqGetParams rr + return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupGetParam pn = do - rr <- getRequest - return $ lookup pn $ 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 +lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. +lookupPostParams :: (MonadIO m, RequestReader m) + => ParamName + -> m [ParamValue] +lookupPostParams pn = do + rr <- getRequest + (pp, _) <- liftIO $ reqRequestBody rr + return $ lookup' pn pp + lookupPostParam :: (MonadIO m, RequestReader m) => ParamName -> m (Maybe ParamValue) -lookupPostParam pn = do - rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - return $ lookup pn pp +lookupPostParam = liftM listToMaybe . lookupPostParams --- | All cookies with the given name. -cookies :: RequestReader m => m (ParamName -> [ParamValue]) -cookies = do +-- | Lookup for POSTed files. +lookupFile :: (MonadIO m, RequestReader m) + => ParamName + -> m (Maybe (FileInfo BL.ByteString)) +lookupFile = liftM listToMaybe . lookupFiles + +-- | Lookup for POSTed files. +lookupFiles :: (MonadIO m, RequestReader m) + => ParamName + -> m [FileInfo BL.ByteString] +lookupFiles pn = do rr <- getRequest - return $ multiLookup $ reqCookies rr + (_, files) <- liftIO $ reqRequestBody rr + return $ lookup' pn files -- | Lookup for cookie data. lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupCookie pn = do - rr <- getRequest - return $ lookup pn $ reqCookies rr +lookupCookie = liftM listToMaybe . lookupCookies --- | All session data with the given name. -session :: RequestReader m => m (ParamName -> [ParamValue]) -session = do +-- | Lookup for cookie data. +lookupCookies :: RequestReader m => ParamName -> m [ParamValue] +lookupCookies pn = do rr <- getRequest - return $ multiLookup $ reqSession rr + return $ lookup' pn $ reqCookies rr -- | Lookup for session data. lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupSession pn = do +lookupSession = liftM listToMaybe . lookupSessions + +-- | Lookup for session data. +lookupSessions :: RequestReader m => ParamName -> m [ParamValue] +lookupSessions pn = do rr <- getRequest - return $ lookup pn $ reqSession rr + return $ lookup' pn $ reqSession rr From 0652fae94fce8e11a98524302d67addf20a88da1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:16:00 +0300 Subject: [PATCH 314/624] Cleaned up Yesod.Handler function names --- Yesod/Handler.hs | 33 +++++++++++++++++---------------- Yesod/Helpers/Auth.hs | 2 +- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 4ad0e4c1..69bc0fe4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -6,7 +6,6 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------- -- @@ -22,8 +21,10 @@ -- --------------------------------------------------------- module Yesod.Handler - ( -- * Handler monad - Handler + ( -- * Type families + Routes + -- * Handler monad + , Handler , GHandler -- ** Read information from handler , getYesod @@ -45,13 +46,13 @@ module Yesod.Handler -- ** Sending static files , sendFile -- * Setting headers - , addCookie + , setCookie , deleteCookie - , header + , setHeader , setLanguage -- * Session , setSession - , clearSession + , deleteSession -- ** Ultimate destination , setUltDest , setUltDestString @@ -63,7 +64,6 @@ module Yesod.Handler -- * Internal Yesod , runHandler , YesodApp (..) - , Routes , toMasterHandler ) where @@ -325,7 +325,7 @@ redirectUltDest :: RedirectType -> GHandler sub master () redirectUltDest rt def = do mdest <- lookupSession ultDestKey - clearSession ultDestKey + deleteSession ultDestKey maybe (redirect rt def) (redirectString rt) mdest msgKey :: String @@ -343,7 +343,7 @@ setMessage = setSession msgKey . L.toString . renderHtml -- See 'setMessage'. getMessage :: GHandler sub master (Maybe (Html ())) getMessage = do - clearSession msgKey + deleteSession msgKey fmap (fmap preEscapedString) $ lookupSession msgKey -- | Bypass remaining handler code and output the given file. @@ -373,11 +373,11 @@ invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client. -addCookie :: Int -- ^ minutes to timeout +setCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value -> GHandler sub master () -addCookie a b = addHeader . AddCookie a b +setCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client. deleteCookie :: String -> GHandler sub master () @@ -385,11 +385,11 @@ deleteCookie = addHeader . DeleteCookie -- | Set the language header. Will show up in 'languages'. setLanguage :: String -> GHandler sub master () -setLanguage = addCookie 60 langKey +setLanguage = setCookie 60 langKey -- FIXME shouldn't we use session for this? -- | Set an arbitrary header on the client. -header :: String -> String -> GHandler sub master () -header a = addHeader . Header a +setHeader :: String -> String -> GHandler sub master () +setHeader a = addHeader . Header a -- | Set a variable in the user's session. -- @@ -402,9 +402,10 @@ setSession :: String -- ^ key setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v) -- | Unsets a session variable. See 'setSession'. -clearSession :: String -> GHandler sub master () -clearSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing) +deleteSession :: String -> GHandler sub master () +deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing) +-- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master () addHeader = GHandler . lift . lift . tell . (:) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index aee6537c..27b3cb6b 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -270,7 +270,7 @@ $maybe creds c getLogout :: YesodAuth master => GHandler Auth master () getLogout = do y <- getYesod - clearSession credsKey + deleteSession credsKey redirectUltDest RedirectTemporary $ defaultDest y -- | Retrieve user credentials. If user is not logged in, redirects to the From 5bed76f067d07d0641f484f677dcb786b91e80ad Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:19:24 +0300 Subject: [PATCH 315/624] redirect uses redirectParams --- Yesod/Handler.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 69bc0fe4..7c714214 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -255,16 +255,15 @@ safeEh er = YesodApp $ \_ _ _ -> do -- | Redirect to the given route. redirect :: RedirectType -> Routes master -> GHandler sub master a -redirect rt url = do - r <- getUrlRender - redirectString rt $ r url +redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters. redirectParams :: RedirectType -> Routes master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRender - redirectString rt $ r url ++ '?' : encodeUrlPairs params + redirectString rt $ r url ++ + if null params then "" else '?' : encodeUrlPairs params where encodeUrlPairs = intercalate "&" . map encodeUrlPair encodeUrlPair (x, []) = escape x From 6ce79d673f392b78b4854e410f4dc47ae711de04 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:21:49 +0300 Subject: [PATCH 316/624] setLanguage uses user session --- Yesod/Dispatch.hs | 13 ++++++++----- Yesod/Handler.hs | 4 ++-- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 30297ddf..b006ec2b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -321,14 +321,17 @@ parseWaiRequest env session' = do cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env langs = map S.toString $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey cookies' of + langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs - langs'' = case lookup langKey gets' of - Nothing -> langs' - Just x -> x : langs' + 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'' + return $ Request gets' cookies' session' rbthunk env langs''' rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7c714214..5f3ebbf5 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -382,9 +382,9 @@ setCookie a b = addHeader . AddCookie a b deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie --- | Set the language header. Will show up in 'languages'. +-- | Set the language in the user session. Will show up in 'languages'. setLanguage :: String -> GHandler sub master () -setLanguage = setCookie 60 langKey -- FIXME shouldn't we use session for this? +setLanguage = setSession langKey -- | Set an arbitrary header on the client. setHeader :: String -> String -> GHandler sub master () From e32c5b9a536f7ae51230d7c6882d605c9c8b3e5c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:33:32 +0300 Subject: [PATCH 317/624] Static file serving: extensible mime-type dictionary --- Yesod.hs | 2 ++ Yesod/Content.hs | 35 ++++++++++++++++++++++------------- Yesod/Helpers/Static.hs | 21 +++++++++++++++------ 3 files changed, 39 insertions(+), 19 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 073a625a..a36f348a 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,6 +13,7 @@ module Yesod , module Yesod.Formable , Application , liftIO + , mempty ) where #if TEST @@ -33,3 +34,4 @@ import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.IO.Class (liftIO) +import Data.Monoid (mempty) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index bbd6ac5f..0dea1d78 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -85,9 +85,14 @@ data Content = ContentFile FilePath -> a -> IO (Either a a)) +-- | Zero-length enumerator. emptyContent :: Content emptyContent = ContentEnum $ \_ -> return . Right +-- | Anything which can be converted into 'Content'. Most of the time, you will +-- want to use the 'ContentEnum' constructor. An easier approach will be to use +-- a pre-defined 'toContent' function, such as converting your data into a lazy +-- bytestring and then calling 'toContent' on that. class ToContent a where toContent :: a -> Content @@ -140,6 +145,9 @@ instance HasReps ChooseRep where instance HasReps () where chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] +instance HasReps (ContentType, Content) where + chooseRep = const . return + instance HasReps [(ContentType, Content)] where chooseRep a cts = return $ case filter (\(ct, _) -> go ct `elem` map go cts) a of @@ -218,19 +226,20 @@ typeOctet = "application/octet-stream" simpleContentType :: String -> String simpleContentType = fst . span (/= ';') --- | 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 +-- | A default extension to mime-type dictionary. +typeByExt :: [(String, ContentType)] +typeByExt = + [ ("jpg", typeJpeg) + , ("jpeg", typeJpeg) + , ("js", typeJavascript) + , ("css", typeCss) + , ("html", typeHtml) + , ("png", typePng) + , ("gif", typeGif) + , ("txt", typePlain) + , ("flv", typeFlv) + , ("ogv", typeOgv) + ] -- | Get a file extension (everything after last period). ext :: String -> String diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 8a496bdb..da0f3bc4 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -38,6 +38,7 @@ module Yesod.Helpers.Static import System.Directory import Control.Monad +import Data.Maybe (fromMaybe) import Yesod import Data.List (intercalate) @@ -51,7 +52,11 @@ import Test.HUnit hiding (Test) -- | A function for looking up file contents. For serving from the file system, -- see 'fileLookupDir'. -data Static = Static (FilePath -> IO (Maybe (Either FilePath Content))) +data Static = Static + { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) + -- | Mapping from file extension to content type. See 'typeByExt'. + , staticTypes :: [(String, ContentType)] + } mkYesodSub "Static" [] [$parseRoutes| *Strings StaticRoute GET @@ -63,7 +68,7 @@ mkYesodSub "Static" [] [$parseRoutes| -- probably are), the handler itself checks that no unsafe paths are being -- requested. In particular, no path segments may begin with a single period, -- so hidden files and parent directories are safe. -fileLookupDir :: FilePath -> Static +fileLookupDir :: FilePath -> [(String, ContentType)] -> Static fileLookupDir dir = Static $ \fp -> do let fp' = dir ++ '/' : fp exists <- doesFileExist fp' @@ -72,16 +77,20 @@ fileLookupDir dir = Static $ \fp -> do else return Nothing getStaticRoute :: [String] - -> GHandler Static master [(ContentType, Content)] + -> GHandler Static master (ContentType, Content) getStaticRoute fp' = do - Static fl <- getYesodSub + Static fl ctypes <- getYesodSub 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, bs)] + Just (Left fp'') -> do + let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes + sendFile ctype fp'' + Just (Right bs) -> do + let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes + return (ctype, bs) where isUnsafe [] = True isUnsafe ('.':_) = True From 058b738b4af9990bc3c1196885e1e99405da8f17 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:43:48 +0300 Subject: [PATCH 318/624] Added sendResponse function --- Yesod/Handler.hs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 5f3ebbf5..9b9235c1 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -43,8 +43,9 @@ module Yesod.Handler , badMethod , permissionDenied , invalidArgs - -- ** Sending static files + -- ** Short-circuit responses. , sendFile + , sendResponse -- * Setting headers , setCookie , deleteCookie @@ -94,6 +95,7 @@ import Text.Hamlet import Numeric (showIntAtBase) import Data.Char (ord, chr) +-- | The type-safe URLs associated with a site argument. data family Routes a data HandlerData sub master = HandlerData @@ -116,6 +118,8 @@ handlerSubData tm ts route hd = hd , handlerRoute = Just route } +-- | Used internally for promoting subsite handler functions to master site +-- handler functions. Should not be needed by users. toMasterHandler :: (Routes sub -> Routes master) -> (master -> sub) -> Routes sub @@ -125,8 +129,10 @@ toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h -- | A generic handler monad, which can have a different subsite and master --- site. This monad is a combination of reader for basic arguments, a writer --- for headers, and an error-type monad for handling special responses. +-- site. This monad is a combination of 'ReaderT' for basic arguments, a +-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling +-- special responses. It is declared as a newtype to make compiler errors more +-- readable. newtype GHandler sub master a = GHandler { unGHandler :: ReaderT (HandlerData sub master) ( MEitherT HandlerContents ( @@ -352,6 +358,10 @@ getMessage = do sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct = GHandler . lift . throwMEither . HCSendFile ct +-- | Bypass remaining handler code and output the given content. +sendResponse :: HasReps c => c -> GHandler sub master a +sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep + -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound From ea48760294fe7546d04ade08b714a21dedf97816 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:45:42 +0300 Subject: [PATCH 319/624] Combined authFacebook and authFacebookPerms --- Yesod/Helpers/Auth.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 27b3cb6b..54bf1f26 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -49,7 +49,6 @@ import Control.Applicative import Control.Concurrent.MVar import System.IO import Control.Monad.Attempt -import Data.Monoid (mempty) import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object @@ -83,8 +82,8 @@ data Auth = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String , authEmailSettings :: Maybe AuthEmailSettings - , authFacebook :: Maybe (String, String) -- ^ client id and secret - , authFacebookPerms :: [String] + -- | client id, secret and requested permissions + , authFacebook :: Maybe (String, String, [String]) } -- | Which subsystem authenticated the user. @@ -492,7 +491,7 @@ getFacebookR = do a <- authFacebook <$> getYesodSub case a of Nothing -> notFound - Just (cid, secret) -> do + Just (cid, secret, _) -> do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR @@ -514,9 +513,9 @@ getStartFacebookR = do y <- getYesodSub case authFacebook y of Nothing -> notFound - Just (cid, secret) -> do + Just (cid, secret, perms) -> do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR - let fburl = Facebook.getForwardUrl fb $ authFacebookPerms y + let fburl = Facebook.getForwardUrl fb perms redirectString RedirectTemporary fburl From 95047029f876205a68ac425f3ed2644f45a77386 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 21:55:23 +0300 Subject: [PATCH 320/624] Some documentation updates Next target for cleanup: Yesod.Form, Yesod.Formable and Yesod.Helpers.Crud. --- Yesod/Json.hs | 4 ++-- Yesod/Request.hs | 4 +++- Yesod/Yesod.hs | 2 ++ 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index e54631b7..1a12518b 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -35,8 +35,8 @@ import Yesod.Content #endif -- | A monad for generating Json output. In truth, it is just a newtype wrapper --- around 'Hamlet'; we thereby get the benefits of Hamlet (interleaving IO and --- enumerator output) without accidently mixing non-JSON content. +-- around 'Html'; we thereby get the benefits of BlazeHtml (type safety and +-- speed) without accidently mixing non-JSON content. -- -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON diff --git a/Yesod/Request.hs b/Yesod/Request.hs index f69c0a67..6171289c 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -63,12 +63,14 @@ instance RequestReader ((->) Request) where -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order --- of preference: +-- of preference): -- -- * The _LANG get parameter. -- -- * The _LANG cookie. -- +-- * The _LANG user session variable. +-- -- * Accept-Language HTTP header. -- -- This is handled by the parseWaiRequest function in Yesod.Dispatch (not diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 381df617..d42230a5 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -41,6 +41,8 @@ class YesodSite y where getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) type Method = String +-- | Same as 'YesodSite', but for subsites. Once again, users should not need +-- to deal with it directly, as the mkYesodSub creates instances appropriately. class YesodSubSite s y where getSubSite :: Site (Routes s) (Method -> Maybe (GHandler s y ChooseRep)) From 1a375e8fb47d044eaf6faaa7648e8ff77ac68b23 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 22:41:47 +0300 Subject: [PATCH 321/624] Merged Yesod.Form and yesod.Formable --- Yesod.hs | 4 +- Yesod/Form.hs | 420 ++++++++++++++++++++++++++++++++---------- Yesod/Formable.hs | 319 -------------------------------- Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 32 +++- Yesod/Helpers/Crud.hs | 4 +- Yesod/Internal.hs | 2 +- Yesod/Yesod.hs | 7 +- yesod.cabal | 1 - 9 files changed, 353 insertions(+), 438 deletions(-) delete mode 100644 Yesod/Formable.hs diff --git a/Yesod.hs b/Yesod.hs index a36f348a..6d8406eb 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -10,7 +10,6 @@ module Yesod , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json - , module Yesod.Formable , Application , liftIO , mempty @@ -27,8 +26,7 @@ import Yesod.Dispatch #endif import Yesod.Request -import Yesod.Form hiding (Form) -import Yesod.Formable +import Yesod.Form import Yesod.Yesod import Yesod.Handler hiding (runHandler) import Network.Wai (Application) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 3dafee0b..73a476e7 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -1,25 +1,38 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Parse forms (and query strings). module Yesod.Form - ( Form (..) - , runFormGeneric - , runFormPost + ( -- * Data types + Form (..) + , Formlet + , FormResult (..) + -- * Unwrapping functions , runFormGet + , runFormPost + , runFormGet' + , runFormPost' + -- * Create your own formlets + , incr , input - , applyForm - -- * Specific checks - , required - , optional - , notEmpty - , checkDay - , checkBool - , checkInteger - -- * Utility - , catchFormError + , check + -- * Error display + , wrapperRow + , sealFormlet + , sealForm + , sealRow + -- * Formable + , Formable (..) + , deriveFormable + , share2 + -- * Pre-built formlets ) where +import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) @@ -28,110 +41,323 @@ import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Yesod.Internal import Control.Monad.Attempt +import Control.Monad ((<=<), liftM, join) +import Data.Monoid (mempty, mappend) +import Control.Monad.Trans.State +import Control.Arrow (first) +import Language.Haskell.TH.Syntax +import Database.Persist.Base (PersistField, EntityDef (..)) +import Data.Char (isAlphaNum, toUpper, isUpper) +import Data.Maybe (fromMaybe, isJust) +import Web.Routes.Quasi (SinglePiece) +import Data.Int (Int64) +import qualified Data.ByteString.Lazy.UTF8 noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)" -data Form x = Form ( - (ParamName -> [ParamValue]) - -> Either [(ParamName, FormError)] (Maybe ParamName, x) - ) +data FormResult a = FormMissing + | FormFailure [String] + | FormSuccess a +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing -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 +newtype Form sub y a = Form + { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) + } +type Formlet sub y a = Maybe a -> Form sub y a -type FormError = String +type Env = [(String, String)] -runFormGeneric :: Failure ErrorResponse m - => (ParamName -> [ParamValue]) -> Form x -> m x -runFormGeneric params (Form f) = - case f params of - Left es -> invalidArgs es - Right (_, x) -> return x +instance Functor (Form sub url) where + fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) + +instance Applicative (Form sub url) where + pure a = Form $ const $ return (pure a, mempty) + (Form f) <*> (Form g) = Form $ \env -> do + (f1, f2) <- f env + (g1, g2) <- g env + return (f1 <*> g1, f2 `mappend` g2) + +runFormGeneric :: Env + -> Form sub y a + -> GHandler sub y (FormResult a, Hamlet (Routes y)) +runFormGeneric env f = evalStateT (deform f env) 1 -- | Run a form against POST parameters. -runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m) - => Form x -> m x +runFormPost :: Form sub y a + -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormPost f = do rr <- getRequest (pp, _) <- liftIO $ reqRequestBody rr - runFormGeneric (flip lookup' pp) f + runFormGeneric pp f -lookup' :: Eq a => a -> [(a, b)] -> [b] -lookup' a = map snd . filter (\x -> a == fst x) +-- | Run a form against POST parameters, disregarding the resulting HTML and +-- returning an error response on invalid input. +runFormPost' :: Form sub y a -> GHandler sub y a +runFormPost' = helper <=< runFormPost + +-- | Run a form against GET parameters, disregarding the resulting HTML and +-- returning an error response on invalid input. +runFormGet' :: Form sub y a -> GHandler sub y a +runFormGet' = helper <=< runFormGet + +helper :: (FormResult a, Hamlet (Routes y)) -> GHandler sub y a +helper (FormSuccess a, _) = return a +helper (FormFailure e, _) = invalidArgs e +helper (FormMissing, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. -runFormGet :: (RequestReader m, Failure ErrorResponse m) - => Form x -> m x +runFormGet :: Form sub y a + -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormGet f = do - rr <- getRequest - runFormGeneric (flip lookupGetParams rr) f + gets <- reqGetParams `fmap` getRequest + runFormGeneric gets f -input :: ParamName -> Form [ParamValue] -input pn = Form $ \l -> Right (Just pn, l pn) +type Incr = StateT Int -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) +incr :: Monad m => Incr m Int +incr = do + i <- get + let i' = i + 1 + put i' + return i' -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" +input :: (String -> String -> Hamlet (Routes y)) + -> Maybe String + -> Form sub y String +input mkXml val = Form $ \env -> do + i <- incr + let i' = show i + let param = lookup i' env + let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param + return (maybe FormMissing FormSuccess param, xml) -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 $ maybe (Left "Invalid day") Right . readMay +check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b +check (Form form) f = Form $ \env -> liftM (first go) (form env) where - readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing + go FormMissing = FormMissing + go (FormFailure x) = FormFailure x + go (FormSuccess a) = + case f a of + Left errs -> FormFailure errs + Right b -> FormSuccess b -checkBool :: Form [ParamValue] -> Form Bool -checkBool = applyForm $ \pv -> Right $ case pv of - [] -> False - [""] -> False - ["false"] -> False - _ -> True +wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url +wrapperRow label errs control = [$hamlet| +%tr + %th $string.label$ + %td ^control^ + $if not.null.errs + %td.errors + %ul + $forall errs err + %li $string.err$ +|] -checkInteger :: Form ParamValue -> Form Integer -checkInteger = applyForm $ \pv -> - case reads pv of - [] -> Left "Invalid integer" - ((i, _):_) -> Right i +sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b +sealRow label getVal val = + sealForm (wrapperRow label) $ formable $ fmap getVal val --- | 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) +sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) + -> Form sub y a -> Form sub y a +sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) + where + go (res, xml) = (res, wrapper (toList res) xml) + toList (FormFailure errs) = errs + toList _ = [] + +sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) + -> Formlet sub y a -> Formlet sub y a +sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal + +class Formable a where + formable :: Formlet sub master a + +--------------- Formable instances +instance Formable String where + formable x = input go x `check` notEmpty + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + notEmpty s + | null s = Left ["Value required"] + | otherwise = Right s + +instance Formable (Maybe String) where + formable x = input go (join x) `check` isEmpty + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + isEmpty s + | null s = Right Nothing + | otherwise = Right $ Just s + +instance Formable (Html ()) where + formable = fmap preEscapedString + . input go + . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) + where + go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] + +instance Formable Day where + formable x = input go (fmap show x) `check` asDay + where + go name val = [$hamlet| +%input!type=date!name=$string.name$!value=$string.val$ +|] + asDay s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid day"] + +instance Formable Int64 where + formable x = input go (fmap show x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid integer"] + +instance Formable Double where + formable x = input go (fmap numstring x) `check` asDouble + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asDouble s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid double"] + numstring d = + let s = show d + in case reverse s of + '0':'.':y -> reverse y + _ -> s + +instance Formable (Maybe Day) where + formable x = input go (fmap show $ join x) `check` asDay + where + go name val = [$hamlet| +%input!type=date!name=$string.name$!value=$string.val$ +|] + asDay "" = Right Nothing + asDay s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid day"] + +instance Formable (Maybe Int) where + formable x = input go (fmap show $ join x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt "" = Right Nothing + asInt s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid integer"] + +instance Formable (Maybe Int64) where + formable x = input go (fmap show $ join x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt "" = Right Nothing + asInt s = case reads s of + (y, _):_ -> Right $ Just y + [] -> Left ["Invalid integer"] + +instance Formable Bool where + formable x = Form $ \env -> do + i <- incr + let i' = show i + let param = lookup i' env + let def = if null env then fromMaybe False x else isJust param + return (FormSuccess $ isJust param, go i' def) + where + go name val = [$hamlet| +%input!type=checkbox!name=$string.name$!:val:checked +|] + +instance Formable Int where + formable x = input go (fmap show x) `check` asInt + where + go name val = [$hamlet| +%input!type=number!name=$string.name$!value=$string.val$ +|] + asInt s = case reads s of + (y, _):_ -> Right y + [] -> Left ["Invalid integer"] + +newtype Slug = Slug { unSlug :: String } + deriving (Read, Eq, Show, SinglePiece, PersistField) + +instance Formable Slug where + formable x = input go (fmap unSlug x) `check` asSlug + where + go name val = [$hamlet| +%input!type=text!name=$string.name$!value=$string.val$ +|] + asSlug [] = Left ["Slug must be non-empty"] + asSlug x' + | all (\c -> c `elem` "-_" || isAlphaNum c) x' = + Right $ Slug x' + | otherwise = Left ["Slug must be alphanumeric, - and _"] + +share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] +share2 f g a = do + f' <- f a + g' <- g a + return $ f' ++ g' + +deriveFormable :: [EntityDef] -> Q [Dec] +deriveFormable = mapM derive + where + derive :: EntityDef -> Q Dec + derive t = do + let fst3 (x, _, _) = x + let cols = map (toLabel . fst3) $ entityColumns t + ap <- [|(<*>)|] + just <- [|pure|] + nothing <- [|Nothing|] + let just' = just `AppE` ConE (mkName $ entityName t) + let c1 = Clause [ ConP (mkName "Nothing") [] + ] + (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + [] + xs <- mapM (const $ newName "x") cols + let xs' = map (AppE just . VarE) xs + let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) + $ map VarP xs]] + (NormalB $ go ap just' $ zip cols xs') + [] + return $ InstanceD [] (ConT ''Formable + `AppT` ConT (mkName $ entityName t)) + [FunD (mkName "formable") [c1, c2]] + go ap just' = foldl (ap' ap) just' . map go' + go' (label, ex) = + VarE (mkName "sealForm") `AppE` + (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` + (VarE (mkName "formable") `AppE` ex) + ap' ap x y = InfixE (Just x) ap (Just y) + +toLabel :: String -> String +toLabel "" = "" +toLabel (x:rest) = toUpper x : go rest + where + go "" = "" + go (c:cs) + | isUpper c = ' ' : c : go cs + | otherwise = c : go cs diff --git a/Yesod/Formable.hs b/Yesod/Formable.hs deleted file mode 100644 index bb39be50..00000000 --- a/Yesod/Formable.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Yesod.Formable - ( Form (..) - , Formlet - , FormResult (..) - , runForm - , incr - , Formable (..) - , deriveFormable - , share2 - , wrapperRow - , sealFormlet - , sealForm - , Slug (..) - , sealRow - , check - ) where - -import Text.Hamlet -import Data.Time (Day) -import Control.Applicative -import Database.Persist (PersistField) -import Database.Persist.Base (EntityDef (..)) -import Data.Char (isAlphaNum, toUpper, isUpper) -import Language.Haskell.TH.Syntax -import Control.Monad (liftM, join) -import Control.Arrow (first) -import Data.Maybe (fromMaybe, isJust) -import Data.Monoid (mempty, mappend) -import qualified Data.ByteString.Lazy.UTF8 -import Yesod.Request -import Yesod.Handler -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State -import Web.Routes.Quasi (SinglePiece) -import Data.Int (Int64) - -sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b -sealRow label getVal val = - sealForm (wrapperRow label) $ formable $ fmap getVal val - -runForm :: Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) -runForm f = do - req <- getRequest - (pp, _) <- liftIO $ reqRequestBody req - evalStateT (deform f pp) 1 - -type Env = [(String, String)] - -type Incr = StateT Int - -incr :: Monad m => Incr m Int -incr = do - i <- get - let i' = i + 1 - put i' - return i' - -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing - -newtype Form sub y a = Form - { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) - } -type Formlet sub y a = Maybe a -> Form sub y a - -instance Functor (Form sub url) where - fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) - -instance Applicative (Form sub url) where - pure a = Form $ const $ return (pure a, mempty) - (Form f) <*> (Form g) = Form $ \env -> do - (f1, f2) <- f env - (g1, g2) <- g env - return (f1 <*> g1, f2 `mappend` g2) - -sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) - -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) - where - go (res, xml) = (res, wrapper (toList res) xml) - toList (FormFailure errs) = errs - toList _ = [] - -sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) - -> Formlet sub y a -> Formlet sub y a -sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal - -input' :: (String -> String -> Hamlet (Routes y)) - -> Maybe String - -> Form sub y String -input' mkXml val = Form $ \env -> do - i <- incr - let i' = show i - let param = lookup i' env - let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param - return (maybe FormMissing FormSuccess param, xml) - -check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b -check (Form form) f = Form $ \env -> liftM (first go) (form env) - where - go FormMissing = FormMissing - go (FormFailure x) = FormFailure x - go (FormSuccess a) = - case f a of - Left errs -> FormFailure errs - Right b -> FormSuccess b - -class Formable a where - formable :: Formlet sub master a - -wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url -wrapperRow label errs control = [$hamlet| -%tr - %th $string.label$ - %td ^control^ - $if not.null.errs - %td.errors - %ul - $forall errs err - %li $string.err$ -|] - -instance Formable String where - formable x = input' go x `check` notEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - notEmpty s - | null s = Left ["Value required"] - | otherwise = Right s - -instance Formable (Maybe String) where - formable x = input' go (join x) `check` isEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - isEmpty s - | null s = Right Nothing - | otherwise = Right $ Just s - -instance Formable (Html ()) where - formable = fmap preEscapedString - . input' go - . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) - where - go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] - -instance Formable Day where - formable x = input' go (fmap show x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid day"] - -instance Formable Int64 where - formable x = input' go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -instance Formable Double where - formable x = input' go (fmap numstring x) `check` asDouble - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asDouble s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid double"] - numstring d = - let s = show d - in case reverse s of - '0':'.':y -> reverse y - _ -> s - -instance Formable (Maybe Day) where - formable x = input' go (fmap show $ join x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay "" = Right Nothing - asDay s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid day"] - -instance Formable (Maybe Int) where - formable x = input' go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable (Maybe Int64) where - formable x = input' go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable Bool where - formable x = Form $ \env -> do - i <- incr - let i' = show i - let param = lookup i' env - let def = if null env then fromMaybe False x else isJust param - return (FormSuccess $ isJust param, go i' def) - where - go name val = [$hamlet| -%input!type=checkbox!name=$string.name$!:val:checked -|] - -instance Formable Int where - formable x = input' go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -newtype Slug = Slug { unSlug :: String } - deriving (Read, Eq, Show, SinglePiece, PersistField) - -instance Formable Slug where - formable x = input' go (fmap unSlug x) `check` asSlug - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - asSlug [] = Left ["Slug must be non-empty"] - asSlug x' - | all (\c -> c `elem` "-_" || isAlphaNum c) x' = - Right $ Slug x' - | otherwise = Left ["Slug must be alphanumeric, - and _"] - -share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] -share2 f g a = do - f' <- f a - g' <- g a - return $ f' ++ g' - -deriveFormable :: [EntityDef] -> Q [Dec] -deriveFormable = mapM derive - where - derive :: EntityDef -> Q Dec - derive t = do - let fst3 (x, _, _) = x - let cols = map (toLabel . fst3) $ entityColumns t - ap <- [|(<*>)|] - just <- [|pure|] - nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ entityName t) - let c1 = Clause [ ConP (mkName "Nothing") [] - ] - (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) - [] - xs <- mapM (const $ newName "x") cols - let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) - $ map VarP xs]] - (NormalB $ go ap just' $ zip cols xs') - [] - return $ InstanceD [] (ConT ''Formable - `AppT` ConT (mkName $ entityName t)) - [FunD (mkName "formable") [c1, c2]] - go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = - VarE (mkName "sealForm") `AppE` - (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "formable") `AppE` ex) - ap' ap x y = InfixE (Just x) ap (Just y) - -toLabel :: String -> String -toLabel "" = "" -toLabel (x:rest) = toUpper x : go rest - where - go "" = "" - go (c:cs) - | isUpper c = ' ' : c : go cs - | otherwise = c : go cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 9b9235c1..af3e7045 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -377,7 +377,7 @@ permissionDenied :: Failure ErrorResponse m => String -> m a permissionDenied = failure . PermissionDenied -- | Return a 400 invalid arguments page. -invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a +invalidArgs :: Failure ErrorResponse m => [String] -> m a invalidArgs = failure . InvalidArgs ------- Headers diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 54bf1f26..916b6b9e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -179,10 +179,22 @@ $maybe message msg %input!type=submit!value=Login |] +-- FIXME next two functions should show up in Yesod.Form properly +requiredField :: String -> Form sub master String +requiredField n = Form $ \env -> + return (maybe FormMissing FormSuccess $ lookup n env, mempty) + +notEmptyField :: String -> Form sub master String +notEmptyField n = Form $ \env -> return + (case lookup n env of + Nothing -> FormMissing + Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] + Just x -> FormSuccess x, mempty) + getOpenIdForward :: GHandler Auth master () getOpenIdForward = do testOpenId - oid <- runFormGet $ required $ input "openid" + oid <- runFormGet' $ requiredField "openid" render <- getUrlRender toMaster <- getRouteToMaster let complete = render $ toMaster OpenIdComplete @@ -220,7 +232,7 @@ handleRpxnowR = do token1 <- lookupGetParam "token" token2 <- lookupPostParam "token" let token = case token1 `mplus` token2 of - Nothing -> invalidArgs [("token", "Value not supplied")] + Nothing -> invalidArgs ["token: Value not supplied"] Just x -> x Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token let creds = Creds @@ -302,7 +314,7 @@ getEmailRegisterR = do postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings - email <- runFormPost $ notEmpty $ required $ input "email" -- FIXME checkEmail + email <- runFormPost' $ notEmptyField "email" -- FIXME checkEmail y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <- @@ -366,9 +378,9 @@ $maybe msg ms postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings - (email, pass) <- runFormPost $ (,) - <$> notEmpty (required $ input "email") -- FIXME valid e-mail? - <*> required (input "password") + (email, pass) <- runFormPost' $ (,) + <$> notEmptyField "email" -- FIXME valid e-mail? + <*> requiredField "password" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email let mlid = @@ -419,9 +431,9 @@ $maybe msg ms postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do ae <- getAuthEmailSettings - (new, confirm) <- runFormPost $ (,) - <$> notEmpty (required $ input "new") - <*> notEmpty (required $ input "confirm") + (new, confirm) <- runFormPost' $ (,) + <$> notEmptyField "new" + <*> notEmptyField "confirm" toMaster <- getRouteToMaster when (new /= confirm) $ do setMessage $ string "Passwords did not match, please try again" @@ -495,7 +507,7 @@ getFacebookR = do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR - code <- runFormGet $ required $ input "code" + code <- runFormGet' $ requiredField "code" at <- liftIO $ Facebook.getAccessToken fb code so <- liftIO $ Facebook.getGraphData at "me" let c = fromMaybe (error "Invalid response from Facebook") $ do diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 7964790a..e46e296d 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -15,7 +15,7 @@ import Yesod.Dispatch import Yesod.Content import Yesod.Handler import Text.Hamlet -import Yesod.Formable +import Yesod.Form import Data.Monoid (mempty) class Formable a => Item a where @@ -127,7 +127,7 @@ crudHelper -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do crud <- getYesodSub - (errs, form) <- runForm $ formable $ fmap snd me + (errs, form) <- runFormPost $ formable $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of (True, FormSuccess a) -> do diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index b741fc6f..2309904e 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -13,7 +13,7 @@ module Yesod.Internal data ErrorResponse = NotFound | InternalError String - | InvalidArgs [(String, String)] + | InvalidArgs [String] | PermissionDenied String | BadMethod String deriving (Show, Eq) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index d42230a5..fb6fb806 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -183,10 +183,9 @@ defaultErrorHandler (PermissionDenied msg) = defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments -%dl - $forall ia pair - %dt $string.fst.pair$ - %dd $string.snd.pair$ +%ul + $forall ia msg + %li $string.msg$ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| diff --git a/yesod.cabal b/yesod.cabal index 890e7af0..00670ad8 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -48,7 +48,6 @@ library Yesod.Content Yesod.Dispatch Yesod.Form - Yesod.Formable Yesod.Hamlet Yesod.Handler Yesod.Internal From 53f7837cff9f565de101a51b4e8dccae31f785c5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 30 Jun 2010 23:17:00 +0300 Subject: [PATCH 322/624] Added a few incomplete functions to Form --- Yesod/Form.hs | 35 +++++++++++++++++++++++++++-------- Yesod/Helpers/Auth.hs | 12 ------------ 2 files changed, 27 insertions(+), 20 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 73a476e7..780636a2 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -30,6 +30,10 @@ module Yesod.Form , deriveFormable , share2 -- * Pre-built formlets + , optionalField + , requiredField + , notEmptyField + , boolField ) where import Text.Hamlet @@ -39,8 +43,6 @@ import Control.Applicative hiding (optional) import Data.Time (Day) import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class -import Yesod.Internal -import Control.Monad.Attempt import Control.Monad ((<=<), liftM, join) import Data.Monoid (mempty, mappend) import Control.Monad.Trans.State @@ -48,14 +50,11 @@ import Control.Arrow (first) import Language.Haskell.TH.Syntax import Database.Persist.Base (PersistField, EntityDef (..)) import Data.Char (isAlphaNum, toUpper, isUpper) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 -noParamNameError :: String -noParamNameError = "No param name (miscalling of Yesod.Form library)" - data FormResult a = FormMissing | FormFailure [String] | FormSuccess a @@ -120,8 +119,8 @@ helper (FormMissing, _) = invalidArgs ["No input found"] runFormGet :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormGet f = do - gets <- reqGetParams `fmap` getRequest - runFormGeneric gets f + gs <- reqGetParams `fmap` getRequest + runFormGeneric gs f type Incr = StateT Int @@ -180,6 +179,26 @@ sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Formlet sub y a -> Formlet sub y a sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal +-------- Prebuilt +optionalField :: String -> Form sub master (Maybe String) +optionalField n = Form $ \env -> + return (FormSuccess $ lookup n env, mempty) -- FIXME + +requiredField :: String -> Form sub master String +requiredField n = Form $ \env -> + return (maybe FormMissing FormSuccess $ lookup n env, mempty) -- FIXME + +notEmptyField :: String -> Form sub master String +notEmptyField n = Form $ \env -> return + (case lookup n env of + Nothing -> FormMissing + Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] + Just x -> FormSuccess x, mempty) -- FIXME + +boolField :: String -> Form sub master Bool +boolField n = Form $ \env -> return + (FormSuccess $ isJust $ lookup n env, mempty) -- FIXME + class Formable a where formable :: Formlet sub master a diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 916b6b9e..32d91c91 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -179,18 +179,6 @@ $maybe message msg %input!type=submit!value=Login |] --- FIXME next two functions should show up in Yesod.Form properly -requiredField :: String -> Form sub master String -requiredField n = Form $ \env -> - return (maybe FormMissing FormSuccess $ lookup n env, mempty) - -notEmptyField :: String -> Form sub master String -notEmptyField n = Form $ \env -> return - (case lookup n env of - Nothing -> FormMissing - Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] - Just x -> FormSuccess x, mempty) - getOpenIdForward :: GHandler Auth master () getOpenIdForward = do testOpenId From f49c16c3bae2b03fb889c6b4785f9be57c35df20 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 08:41:14 +0300 Subject: [PATCH 323/624] Support for files in forms --- Yesod/Dispatch.hs | 8 +++++--- Yesod/Form.hs | 38 ++++++++++++++++++++------------------ Yesod/Request.hs | 14 ++++++++++---- 3 files changed, 35 insertions(+), 25 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index b006ec2b..fb8d340a 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -61,7 +61,8 @@ import Data.Char (isLower, isUpper) import Data.Serialize import qualified Data.Serialize as Ser -import Network.Wai.Parse +import Network.Wai.Parse hiding (FileInfo) +import qualified Network.Wai.Parse as NWP #if TEST import Test.Framework (testGroup, Test) @@ -122,6 +123,7 @@ typeHelper = go s@(x:_) | isLower x = VarT $ mkName s | otherwise = ConT $ mkName s + go [] = error "typeHelper: empty string to go" mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument @@ -336,8 +338,8 @@ parseWaiRequest env session' = do rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where fix1 = map (S.toString *** S.toString) - fix2 (x, FileInfo a b c) = - (S.toString x, FileInfo a b c) + fix2 (x, NWP.FileInfo a b c) = + (S.toString x, FileInfo (S.toString a) (S.toString b) c) -- | 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 diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 780636a2..aa231410 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -71,34 +71,36 @@ instance Applicative FormResult where _ <*> _ = FormMissing newtype Form sub y a = Form - { deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) + { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) } type Formlet sub y a = Maybe a -> Form sub y a type Env = [(String, String)] +type FileEnv = [(String, FileInfo)] instance Functor (Form sub url) where - fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env) + fmap f (Form g) = Form $ \env fe -> liftM (first $ fmap f) (g env fe) instance Applicative (Form sub url) where - pure a = Form $ const $ return (pure a, mempty) - (Form f) <*> (Form g) = Form $ \env -> do - (f1, f2) <- f env - (g1, g2) <- g env + pure a = Form $ const $ const $ return (pure a, mempty) + (Form f) <*> (Form g) = Form $ \env fe -> do + (f1, f2) <- f env fe + (g1, g2) <- g env fe return (f1 <*> g1, f2 `mappend` g2) runFormGeneric :: Env + -> FileEnv -> Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) -runFormGeneric env f = evalStateT (deform f env) 1 +runFormGeneric env fe f = evalStateT (deform f env fe) 1 -- | Run a form against POST parameters. runFormPost :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormPost f = do rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - runFormGeneric pp f + (pp, files) <- liftIO $ reqRequestBody rr + runFormGeneric pp files f -- | Run a form against POST parameters, disregarding the resulting HTML and -- returning an error response on invalid input. @@ -120,7 +122,7 @@ runFormGet :: Form sub y a -> GHandler sub y (FormResult a, Hamlet (Routes y)) runFormGet f = do gs <- reqGetParams `fmap` getRequest - runFormGeneric gs f + runFormGeneric gs [] f type Incr = StateT Int @@ -134,7 +136,7 @@ incr = do input :: (String -> String -> Hamlet (Routes y)) -> Maybe String -> Form sub y String -input mkXml val = Form $ \env -> do +input mkXml val = Form $ \env _ -> do i <- incr let i' = show i let param = lookup i' env @@ -142,7 +144,7 @@ input mkXml val = Form $ \env -> do return (maybe FormMissing FormSuccess param, xml) check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b -check (Form form) f = Form $ \env -> liftM (first go) (form env) +check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe) where go FormMissing = FormMissing go (FormFailure x) = FormFailure x @@ -169,7 +171,7 @@ sealRow label getVal val = sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = Form $ \env -> liftM go (form env) +sealForm wrapper (Form form) = Form $ \env fe -> liftM go (form env fe) where go (res, xml) = (res, wrapper (toList res) xml) toList (FormFailure errs) = errs @@ -181,22 +183,22 @@ sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal -------- Prebuilt optionalField :: String -> Form sub master (Maybe String) -optionalField n = Form $ \env -> +optionalField n = Form $ \env _ -> return (FormSuccess $ lookup n env, mempty) -- FIXME requiredField :: String -> Form sub master String -requiredField n = Form $ \env -> +requiredField n = Form $ \env _ -> return (maybe FormMissing FormSuccess $ lookup n env, mempty) -- FIXME notEmptyField :: String -> Form sub master String -notEmptyField n = Form $ \env -> return +notEmptyField n = Form $ \env _ -> return (case lookup n env of Nothing -> FormMissing Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] Just x -> FormSuccess x, mempty) -- FIXME boolField :: String -> Form sub master Bool -boolField n = Form $ \env -> return +boolField n = Form $ \env _ -> return (FormSuccess $ isJust $ lookup n env, mempty) -- FIXME class Formable a where @@ -299,7 +301,7 @@ instance Formable (Maybe Int64) where [] -> Left ["Invalid integer"] instance Formable Bool where - formable x = Form $ \env -> do + formable x = Form $ \env _ -> do i <- incr let i' = show i let param = lookup i' env diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 6171289c..f89bc67b 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -46,7 +46,6 @@ import qualified Network.Wai as W import qualified Data.ByteString.Lazy as BL import "transformers" Control.Monad.IO.Class import Control.Monad (liftM) -import Network.Wai.Parse import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) @@ -85,9 +84,16 @@ waiRequest = reqWaiRequest `liftM` getRequest -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo BL.ByteString)] + , [(ParamName, FileInfo)] ) +data FileInfo = FileInfo + { fileName :: String + , fileContentType :: String + , fileContent :: BL.ByteString + } + deriving (Eq, Show) + -- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] @@ -134,13 +140,13 @@ lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. lookupFile :: (MonadIO m, RequestReader m) => ParamName - -> m (Maybe (FileInfo BL.ByteString)) + -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. lookupFiles :: (MonadIO m, RequestReader m) => ParamName - -> m [FileInfo BL.ByteString] + -> m [FileInfo] lookupFiles pn = do rr <- getRequest (_, files) <- liftIO $ reqRequestBody rr From e76f380cb54b6c0bd619c6dec17b89f1dba37809 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 16:21:49 +0300 Subject: [PATCH 324/624] Initial widgets support --- Yesod.hs | 5 +- Yesod/Dispatch.hs | 2 +- Yesod/Widget.hs | 150 ++++++++++++++++++++++++++++++++++++++++++++++ hellowidget.hs | 31 ++++++++++ static/script.js | 3 + static/style.css | 3 + static/style2.css | 3 + yesod.cabal | 1 + 8 files changed, 195 insertions(+), 3 deletions(-) create mode 100644 Yesod/Widget.hs create mode 100644 hellowidget.hs create mode 100644 static/script.js create mode 100644 static/style.css create mode 100644 static/style2.css diff --git a/Yesod.hs b/Yesod.hs index 6d8406eb..73c3f733 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,8 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module Yesod - ( - module Yesod.Request + ( module Yesod.Request , module Yesod.Content , module Yesod.Yesod , module Yesod.Handler @@ -10,6 +9,7 @@ module Yesod , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json + , module Yesod.Widget , Application , liftIO , mempty @@ -28,6 +28,7 @@ import Yesod.Dispatch import Yesod.Request import Yesod.Form import Yesod.Yesod +import Yesod.Widget import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index fb8d340a..01e82cd5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -141,7 +141,7 @@ mkYesodGeneral name args clazzes isSub res = do $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th - let w = DataInstD [] ''Routes [arg] w' [] + let w = DataInstD [] ''Routes [arg] w' [''Show, ''Read, ''Eq] parse' <- createParse th parse'' <- newName "parse" diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs new file mode 100644 index 00000000..354df21a --- /dev/null +++ b/Yesod/Widget.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PackageImports #-} +module Yesod.Widget + ( -- * Datatype + Widget + -- * Unwrapping + , widgetToPageContent + , applyLayoutW + -- * Creating + , newIdent + , setTitle + , addStyle + , addStylesheet + , addStylesheetRemote + , addScript + , addScriptRemote + , addHead + , addBody + -- * Manipulating + , wrapWidget + ) where + +import Data.List (nub) +import Data.Monoid +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State +import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string) +import Yesod.Handler (Routes, GHandler) +import Yesod.Yesod (Yesod, defaultLayout) +import Yesod.Content (RepHtml (..)) +import Data.Maybe (fromMaybe) +import Control.Applicative (Applicative) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (lift) +import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) + +data Location url = Local url | Remote String + deriving (Show, Eq) +locationToHamlet :: Location url -> Hamlet url +locationToHamlet (Local url) = [$hamlet|@url@|] +locationToHamlet (Remote s) = [$hamlet|$string.s$|] + +newtype UniqueList x = UniqueList ([x] -> [x]) +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y +runUniqueList :: Eq x => UniqueList x -> [x] +runUniqueList (UniqueList x) = nub $ x [] +toUnique :: x -> UniqueList x +toUnique = UniqueList . (:) + +newtype Script url = Script { unScript :: Location url } + deriving (Show, Eq) +newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html () } +newtype Style url = Style (Hamlet url) + deriving Monoid +newtype Head url = Head (Hamlet url) + deriving Monoid +newtype Body url = Body (Hamlet url) + deriving Monoid + +newtype Widget sub master a = Widget { unWidget :: + WriterT (Body (Routes master)) ( + WriterT (Last Title) ( + WriterT (UniqueList (Script (Routes master))) ( + WriterT (UniqueList (Stylesheet (Routes master))) ( + WriterT (Style (Routes master)) ( + WriterT (Head (Routes master)) ( + StateT Int ( + GHandler sub master + ))))))) a +} + deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) + +setTitle :: Html () -> Widget sub master () +setTitle = Widget . lift . tell . Last . Just . Title + +addHead :: Hamlet (Routes master) -> Widget sub master () +addHead = Widget . lift . lift . lift . lift . lift . tell . Head + +addBody :: Hamlet (Routes master) -> Widget sub master () +addBody = Widget . tell . Body + +newIdent :: Widget sub master String +newIdent = Widget $ lift $ lift $ lift $ lift $ lift $ lift $ do + i <- get + let i' = i + 1 + put i' + return $ "w" ++ show i' + +addStyle :: Hamlet (Routes master) -> Widget sub master () +addStyle = Widget . lift . lift . lift . lift . tell . Style + +addStylesheet :: Routes master -> Widget sub master () +addStylesheet = Widget . lift . lift . lift . tell . toUnique . Stylesheet . Local + +addStylesheetRemote :: String -> Widget sub master () +addStylesheetRemote = + Widget . lift . lift . lift . tell . toUnique . Stylesheet . Remote + +addScript :: Routes master -> Widget sub master () +addScript = Widget . lift . lift . tell . toUnique . Script . Local + +addScriptRemote :: String -> Widget sub master () +addScriptRemote = + Widget . lift . lift . tell . toUnique . Script . Remote + +applyLayoutW :: (Eq (Routes m), Yesod m) + => Widget sub m () -> GHandler sub m RepHtml +applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout + +widgetToPageContent :: Eq (Routes master) + => Widget sub master () + -> GHandler sub master (PageContent (Routes master)) +widgetToPageContent (Widget w) = do + w' <- flip evalStateT 0 + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT w + let (((((((), + Body body), + Last mTitle), + scripts'), + stylesheets'), + Style style), + Head head') = w' + let title = maybe mempty unTitle mTitle + let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' + let stylesheets = map (locationToHamlet . unStylesheet) + $ runUniqueList stylesheets' + let head'' = [$hamlet| +$forall scripts s + %script!src=^s^ +$forall stylesheets s + %link!rel=stylesheet!href=^s^ +%style + ^style^ +^head'^ +|] + return $ PageContent title head'' body + +wrapWidget :: (Hamlet (Routes m) -> Hamlet (Routes m)) + -> Widget s m a -> Widget s m a +wrapWidget wrap (Widget w) = + Widget $ mapWriterT (fmap go) w + where + go (a, Body h) = (a, Body $ wrap h) diff --git a/hellowidget.hs b/hellowidget.hs new file mode 100644 index 00000000..c3099586 --- /dev/null +++ b/hellowidget.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +import Yesod.Widget +import Yesod.Helpers.Static + +data HW = HW { hwStatic :: Static } +mkYesod "HW" [$parseRoutes| +/ RootR GET +/static StaticR Static hwStatic +|] +instance Yesod HW where approot _ = "" +wrapper h = [$hamlet| +#wrapper ^h^ +%footer Brought to you by Yesod Widgets™ +|] +getRootR = applyLayoutW $ wrapWidget wrapper $ do + i <- newIdent + setTitle $ string "Hello Widgets" + addStyle [$hamlet|\#$string.i${color:red}|] + addStylesheet $ StaticR $ StaticRoute ["style.css"] + addStylesheetRemote "http://localhost:3000/static/style2.css" + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + addScript $ StaticR $ StaticRoute ["script.js"] + addBody [$hamlet| +%h1#$string.i$ Welcome to my first widget!!! +%p + %a!href=@RootR@ Recursive link. +%p.noscript Your script did not load. :( +|] + addHead [$hamlet|%meta!keywords=haskell|] +main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000 diff --git a/static/script.js b/static/script.js new file mode 100644 index 00000000..43c21a53 --- /dev/null +++ b/static/script.js @@ -0,0 +1,3 @@ +$(function(){ + $("p.noscript").hide(); +}); diff --git a/static/style.css b/static/style.css new file mode 100644 index 00000000..39895bcc --- /dev/null +++ b/static/style.css @@ -0,0 +1,3 @@ +body { + background-color: #ffd; +} diff --git a/static/style2.css b/static/style2.css new file mode 100644 index 00000000..853ac29a --- /dev/null +++ b/static/style2.css @@ -0,0 +1,3 @@ +body { + font-family: sans-serif; +} diff --git a/yesod.cabal b/yesod.cabal index 00670ad8..5ff38b18 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,6 +53,7 @@ library Yesod.Internal Yesod.Json Yesod.Request + Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed Yesod.Helpers.Auth From 5568530a5d4c1a445fe4ca8fe89baf3377c299e8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 17:19:42 +0300 Subject: [PATCH 325/624] Added extractBody --- Yesod/Widget.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 354df21a..767a2b5d 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -20,6 +20,7 @@ module Yesod.Widget , addBody -- * Manipulating , wrapWidget + , extractBody ) where import Data.List (nub) @@ -30,7 +31,6 @@ import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string) import Yesod.Handler (Routes, GHandler) import Yesod.Yesod (Yesod, defaultLayout) import Yesod.Content (RepHtml (..)) -import Data.Maybe (fromMaybe) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -63,7 +63,7 @@ newtype Head url = Head (Hamlet url) newtype Body url = Body (Hamlet url) deriving Monoid -newtype Widget sub master a = Widget { unWidget :: +newtype Widget sub master a = Widget ( WriterT (Body (Routes master)) ( WriterT (Last Title) ( WriterT (UniqueList (Script (Routes master))) ( @@ -72,8 +72,7 @@ newtype Widget sub master a = Widget { unWidget :: WriterT (Head (Routes master)) ( StateT Int ( GHandler sub master - ))))))) a -} + ))))))) a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) setTitle :: Html () -> Widget sub master () @@ -148,3 +147,9 @@ wrapWidget wrap (Widget w) = Widget $ mapWriterT (fmap go) w where go (a, Body h) = (a, Body $ wrap h) + +extractBody :: Widget s m () -> Widget s m (Hamlet (Routes m)) +extractBody (Widget w) = + Widget $ mapWriterT (fmap go) w + where + go ((), Body h) = (h, Body mempty) From 3ed97f4cfca3793905ee43caceeb00356f83649c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 17:55:00 +0300 Subject: [PATCH 326/624] Switch Routes back to type family. There appears to be a bug in GHC, but I'm not certain. Look at the output from compiling the previous commit; some kind of interaction with a DataInstD and deriving instances. --- Yesod/Dispatch.hs | 8 +++++--- Yesod/Handler.hs | 2 +- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Helpers/Crud.hs | 2 +- Yesod/Helpers/Static.hs | 2 +- Yesod/Yesod.hs | 4 ++-- 6 files changed, 12 insertions(+), 10 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 01e82cd5..dcf46e4a 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -141,7 +141,9 @@ mkYesodGeneral name args clazzes isSub res = do $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th - let w = DataInstD [] ''Routes [arg] w' [''Show, ''Read, ''Eq] + let routesName = mkName $ name ++ "Routes" + let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] + let x = TySynInstD ''Routes [arg] $ ConT routesName parse' <- createParse th parse'' <- newName "parse" @@ -166,7 +168,7 @@ mkYesodGeneral name args clazzes isSub res = do let y = InstanceD ctx ytyp [ FunD (mkName yfunc) [Clause [] (NormalB site') []] ] - return ([w], [y]) + return ([w, x], [y]) isStatic :: Piece -> Bool isStatic StaticPiece{} = True @@ -248,7 +250,7 @@ toWaiApp' y segments env = do eurl = parsePathSegments site pathSegments render u = fromMaybe (fullRender (approot y) (formatPathSegments site) u) - (urlRenderOverride u) + (urlRenderOverride y u) rr <- parseWaiRequest env session' let h = do onRequest diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index af3e7045..6b1f4e3a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -96,7 +96,7 @@ import Numeric (showIntAtBase) import Data.Char (ord, chr) -- | The type-safe URLs associated with a site argument. -data family Routes a +type family Routes a data HandlerData sub master = HandlerData { handlerRequest :: Request diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 32d91c91..3de63fd4 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -22,7 +22,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..) - , Routes (..) + , AuthRoutes (..) -- * Settings , YesodAuth (..) , Creds (..) @@ -154,7 +154,7 @@ mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| /facebook/start StartFacebookR GET /register EmailRegisterR GET POST -/verify/#EmailId/#String EmailVerifyR GET +/verify/#Integer/#String EmailVerifyR GET /login EmailLoginR GET POST /set-password EmailPasswordR GET POST |] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index e46e296d..9ebd8290 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -6,7 +6,7 @@ module Yesod.Helpers.Crud ( Item (..) , Crud (..) - , Routes (..) + , CrudRoutes (..) , defaultCrud ) where diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index da0f3bc4..f62d4bac 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,7 +27,7 @@ module Yesod.Helpers.Static ( -- * Subsite Static (..) - , Routes (..) + , StaticRoutes (..) -- * Lookup files in filesystem , fileLookupDir , staticFiles diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index fb6fb806..7b17f149 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -93,8 +93,8 @@ class Yesod a where -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: Routes a -> Maybe String - urlRenderOverride _ = Nothing + urlRenderOverride :: a -> Routes a -> Maybe String + urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. -- From 8f1f8537fea74920f88370214bbec7454e1a66c5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 20:46:16 +0300 Subject: [PATCH 327/624] Began porting forms to widgets --- Yesod/Form.hs | 30 +++++++++++++++--------------- Yesod/Helpers/Crud.hs | 24 +++++++++++++++++------- Yesod/Widget.hs | 4 ++++ 3 files changed, 36 insertions(+), 22 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index aa231410..490b3ff4 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -29,7 +29,7 @@ module Yesod.Form , Formable (..) , deriveFormable , share2 - -- * Pre-built formlets + -- * Pre-built form , optionalField , requiredField , notEmptyField @@ -54,6 +54,7 @@ import Data.Maybe (isJust) import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 +import Yesod.Widget data FormResult a = FormMissing | FormFailure [String] @@ -71,7 +72,7 @@ instance Applicative FormResult where _ <*> _ = FormMissing newtype Form sub y a = Form - { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y)) + { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Widget sub y ()) } type Formlet sub y a = Maybe a -> Form sub y a @@ -91,12 +92,12 @@ instance Applicative (Form sub url) where runFormGeneric :: Env -> FileEnv -> Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormGeneric env fe f = evalStateT (deform f env fe) 1 -- | Run a form against POST parameters. runFormPost :: Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr @@ -112,26 +113,26 @@ runFormPost' = helper <=< runFormPost runFormGet' :: Form sub y a -> GHandler sub y a runFormGet' = helper <=< runFormGet -helper :: (FormResult a, Hamlet (Routes y)) -> GHandler sub y a +helper :: (FormResult a, Widget sub y ()) -> GHandler sub y a helper (FormSuccess a, _) = return a helper (FormFailure e, _) = invalidArgs e helper (FormMissing, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. runFormGet :: Form sub y a - -> GHandler sub y (FormResult a, Hamlet (Routes y)) + -> GHandler sub y (FormResult a, Widget sub y ()) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f type Incr = StateT Int -incr :: Monad m => Incr m Int +incr :: Monad m => Incr m String incr = do i <- get let i' = i + 1 put i' - return i' + return $ "f" ++ show i' input :: (String -> String -> Hamlet (Routes y)) -> Maybe String @@ -141,7 +142,7 @@ input mkXml val = Form $ \env _ -> do let i' = show i let param = lookup i' env let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param - return (maybe FormMissing FormSuccess param, xml) + return (maybe FormMissing FormSuccess param, addBody xml) -- FIXME check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe) @@ -171,11 +172,11 @@ sealRow label getVal val = sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = Form $ \env fe -> liftM go (form env fe) +sealForm wrapper (Form form) = error "FIXME" {-Form $ \env fe -> liftM go (form env fe) where go (res, xml) = (res, wrapper (toList res) xml) toList (FormFailure errs) = errs - toList _ = [] + toList _ = []-} sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) -> Formlet sub y a -> Formlet sub y a @@ -303,12 +304,11 @@ instance Formable (Maybe Int64) where instance Formable Bool where formable x = Form $ \env _ -> do i <- incr - let i' = show i - let param = lookup i' env + let param = lookup i env let def = if null env then fromMaybe False x else isJust param - return (FormSuccess $ isJust param, go i' def) + return (FormSuccess $ isJust param, go i def) where - go name val = [$hamlet| + go name val = addBody [$hamlet| %input!type=checkbox!name=$string.name$!:val:checked |] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 9ebd8290..d777494d 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -11,6 +11,7 @@ module Yesod.Helpers.Crud ) where import Yesod.Yesod +import Yesod.Widget import Yesod.Dispatch import Yesod.Content import Yesod.Handler @@ -33,6 +34,7 @@ mkYesodSub "Crud master item" [ ("master", [''Yesod]) , ("item", [''Item]) , ("Key item", [''SinglePiece]) + , ("Routes master", [''Eq]) ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST @@ -56,21 +58,24 @@ getCrudListR = do %a!href=@toMaster.CrudAddR@ Add new item |] -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => GHandler (Crud master item) master RepHtml getCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) False -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => GHandler (Crud master item) master RepHtml postCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) True -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -81,7 +86,8 @@ getCrudEditR s = do (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + Eq (Routes master)) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -105,7 +111,7 @@ getCrudDeleteR s = do %p Do you really want to delete $string.itemTitle.item$? %p %input!type=submit!value=Yes - \ + \ $ %a!href=@toMaster.CrudListR@ No |] @@ -122,7 +128,7 @@ itemReadId :: SinglePiece x => String -> Maybe x itemReadId = either (const Nothing) Just . fromSinglePiece crudHelper - :: (Item a, Yesod master, SinglePiece (Key a)) + :: (Item a, Yesod master, SinglePiece (Key a), Eq (Routes master)) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do @@ -139,7 +145,11 @@ crudHelper title me isPost = do redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return () - applyLayout title mempty [$hamlet| + applyLayoutW $ do + wrapWidget (wrapForm toMaster) form + setTitle $ string title + where + wrapForm toMaster form = [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $string.title$ diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 767a2b5d..21fa4891 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleInstances #-} module Yesod.Widget ( -- * Datatype Widget @@ -74,6 +75,9 @@ newtype Widget sub master a = Widget ( GHandler sub master ))))))) a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) +instance Monoid (Widget sub master ()) where + mempty = return () + mappend x y = x >> y setTitle :: Html () -> Widget sub master () setTitle = Widget . lift . tell . Last . Just . Title From d8fca59025ba53b205d10ea834cb5d81c06b4d16 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 1 Jul 2010 22:16:54 +0300 Subject: [PATCH 328/624] Semi-working forms based on widgets Cool feature: automatically include a Javascript library for a datepicker when you need a day field. --- Yesod/Form.hs | 256 +++++++++++++++++++++++++++++++++---------------- hellowidget.hs | 26 +++++ 2 files changed, 202 insertions(+), 80 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 490b3ff4..f365e842 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -9,13 +9,19 @@ module Yesod.Form ( -- * Data types Form (..) - , Formlet , FormResult (..) -- * Unwrapping functions , runFormGet , runFormPost , runFormGet' , runFormPost' + , requiredField + , stringField + , intField + , dayField + , boolField + , fieldsToTable + {- FIXME -- * Create your own formlets , incr , input @@ -34,6 +40,7 @@ module Yesod.Form , requiredField , notEmptyField , boolField + -} ) where import Text.Hamlet @@ -44,7 +51,7 @@ import Data.Time (Day) import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) -import Data.Monoid (mempty, mappend) +import Data.Monoid (Monoid (..)) import Control.Monad.Trans.State import Control.Arrow (first) import Language.Haskell.TH.Syntax @@ -59,6 +66,7 @@ import Yesod.Widget data FormResult a = FormMissing | FormFailure [String] | FormSuccess a + deriving Show instance Functor FormResult where fmap _ FormMissing = FormMissing fmap _ (FormFailure errs) = FormFailure errs @@ -71,33 +79,175 @@ instance Applicative FormResult where _ <*> (FormFailure y) = FormFailure y _ <*> _ = FormMissing -newtype Form sub y a = Form - { deform :: Env -> FileEnv -> Incr (GHandler sub y) (FormResult a, Widget sub y ()) +data Enctype = UrlEncoded | Multipart +instance Show Enctype where + show UrlEncoded = "urlencoded" + show Multipart = "multipart/mimetype" -- FIXME +instance Monoid Enctype where + mempty = UrlEncoded + mappend UrlEncoded UrlEncoded = UrlEncoded + mappend _ _ = Multipart + +newtype GForm sub y xml a = GForm + { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype) + } +type Form sub y = GForm sub y (Widget sub y ()) +type FormField sub y = GForm sub y [FieldInfo sub y] + +data FieldInfo sub y = FieldInfo + { fiLabel :: Html () + , fiTooltip :: Html () + , fiIdent :: String + , fiInput :: Widget sub y () + , fiErrors :: Html () } -type Formlet sub y a = Maybe a -> Form sub y a type Env = [(String, String)] type FileEnv = [(String, FileInfo)] -instance Functor (Form sub url) where - fmap f (Form g) = Form $ \env fe -> liftM (first $ fmap f) (g env fe) +instance Monoid xml => Functor (GForm sub url xml) where + fmap f (GForm g) = + GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) + where + first3 f (x, y, z) = (f x, y, z) -instance Applicative (Form sub url) where - pure a = Form $ const $ const $ return (pure a, mempty) - (Form f) <*> (Form g) = Form $ \env fe -> do - (f1, f2) <- f env fe - (g1, g2) <- g env fe - return (f1 <*> g1, f2 `mappend` g2) +instance Monoid xml => Applicative (GForm sub url xml) where + pure a = GForm $ const $ const $ return (pure a, mempty, mempty) + (GForm f) <*> (GForm g) = GForm $ \env fe -> do + (f1, f2, f3) <- f env fe + (g1, g2, g3) <- g env fe + return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) + +fieldsToTable :: [FieldInfo sub y] -> Widget sub y () +fieldsToTable = mapM_ go + where + go fi = do + flip wrapWidget (fiInput fi) $ \w -> [$hamlet| +%tr + %td + %label!for=$string.fiIdent.fi$ $fiLabel.fi$ + .tooltip $fiTooltip.fi$ + %td + ^w^ + %td.errors + $fiErrors.fi$ +|] + +requiredField :: FieldProfile sub y a + -> Html () -> Html () -> Maybe a -> FormField sub y a +requiredField (FieldProfile parse render mkXml w) label tooltip orig = + GForm $ \env _ -> do + name <- incr + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormMissing, "") + Just "" -> (FormFailure ["Value is required"], "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = name + , fiInput = w name >> addBody (mkXml (string name) (string val) True) + , fiErrors = case res of + FormFailure [x] -> string x + _ -> string "" + } + return (res, [fi], UrlEncoded) + +data FieldProfile sub y a = FieldProfile + { fpParse :: String -> Either String a + , fpRender :: a -> String + , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y) + , fpWidget :: String -> Widget sub y () + } + +--------------------- Begin prebuilt forms + +stringField :: FieldProfile sub y String +stringField = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=text!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +intField :: FieldProfile sub y Int +intField = FieldProfile + { fpParse = maybe (Left "Invalid integer") Right . readMay + , fpRender = show + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +dayField :: FieldProfile sub y Day +dayField = FieldProfile + { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay + , fpRender = show + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|] + } + +boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool +boolField label tooltip orig = GForm $ \env _ -> do + name <- incr + let (res, val) = + if null env + then (FormMissing, fromMaybe False orig) + else case lookup name env of + Nothing -> (FormSuccess False, False) + Just _ -> (FormSuccess True, True) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = name + , fiInput = addBody [$hamlet| +%input#$string.name$!type=checkbox!name=$string.name$!:val:checked +|] + , fiErrors = case res of + FormFailure [x] -> string x + _ -> string "" + } + return (res, [fi], UrlEncoded) + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing + +--------------------- End prebuilt forms + +incr :: Monad m => StateT Int m String +incr = do + i <- get + let i' = i + 1 + put i' + return $ "f" ++ show i' runFormGeneric :: Env -> FileEnv - -> Form sub y a - -> GHandler sub y (FormResult a, Widget sub y ()) + -> GForm sub y xml a + -> GHandler sub y (FormResult a, xml, Enctype) runFormGeneric env fe f = evalStateT (deform f env fe) 1 -- | Run a form against POST parameters. -runFormPost :: Form sub y a - -> GHandler sub y (FormResult a, Widget sub y ()) +runFormPost :: GForm sub y xml a + -> GHandler sub y (FormResult a, xml, Enctype) runFormPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr @@ -105,7 +255,7 @@ runFormPost f = do -- | Run a form against POST parameters, disregarding the resulting HTML and -- returning an error response on invalid input. -runFormPost' :: Form sub y a -> GHandler sub y a +runFormPost' :: GForm sub y xml a -> GHandler sub y a runFormPost' = helper <=< runFormPost -- | Run a form against GET parameters, disregarding the resulting HTML and @@ -113,74 +263,19 @@ runFormPost' = helper <=< runFormPost runFormGet' :: Form sub y a -> GHandler sub y a runFormGet' = helper <=< runFormGet -helper :: (FormResult a, Widget sub y ()) -> GHandler sub y a -helper (FormSuccess a, _) = return a -helper (FormFailure e, _) = invalidArgs e -helper (FormMissing, _) = invalidArgs ["No input found"] +helper :: (FormResult a, b, c) -> GHandler sub y a +helper (FormSuccess a, _, _) = return a +helper (FormFailure e, _, _) = invalidArgs e +helper (FormMissing, _, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. -runFormGet :: Form sub y a - -> GHandler sub y (FormResult a, Widget sub y ()) +runFormGet :: GForm sub y xml a + -> GHandler sub y (FormResult a, xml, Enctype) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f -type Incr = StateT Int - -incr :: Monad m => Incr m String -incr = do - i <- get - let i' = i + 1 - put i' - return $ "f" ++ show i' - -input :: (String -> String -> Hamlet (Routes y)) - -> Maybe String - -> Form sub y String -input mkXml val = Form $ \env _ -> do - i <- incr - let i' = show i - let param = lookup i' env - let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param - return (maybe FormMissing FormSuccess param, addBody xml) -- FIXME - -check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b -check (Form form) f = Form $ \env fe -> liftM (first go) (form env fe) - where - go FormMissing = FormMissing - go (FormFailure x) = FormFailure x - go (FormSuccess a) = - case f a of - Left errs -> FormFailure errs - Right b -> FormSuccess b - -wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url -wrapperRow label errs control = [$hamlet| -%tr - %th $string.label$ - %td ^control^ - $if not.null.errs - %td.errors - %ul - $forall errs err - %li $string.err$ -|] - -sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b -sealRow label getVal val = - sealForm (wrapperRow label) $ formable $ fmap getVal val - -sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) - -> Form sub y a -> Form sub y a -sealForm wrapper (Form form) = error "FIXME" {-Form $ \env fe -> liftM go (form env fe) - where - go (res, xml) = (res, wrapper (toList res) xml) - toList (FormFailure errs) = errs - toList _ = []-} - -sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y)) - -> Formlet sub y a -> Formlet sub y a -sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal +{- -------- Prebuilt optionalField :: String -> Form sub master (Maybe String) @@ -382,3 +477,4 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs +-} diff --git a/hellowidget.hs b/hellowidget.hs index c3099586..fb8983d5 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -2,10 +2,12 @@ import Yesod import Yesod.Widget import Yesod.Helpers.Static +import Control.Applicative data HW = HW { hwStatic :: Static } mkYesod "HW" [$parseRoutes| / RootR GET +/form FormR /static StaticR Static hwStatic |] instance Yesod HW where approot _ = "" @@ -25,7 +27,31 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do %h1#$string.i$ Welcome to my first widget!!! %p %a!href=@RootR@ Recursive link. +%p + %a!href=@FormR@ Check out the form. %p.noscript Your script did not load. :( |] addHead [$hamlet|%meta!keywords=haskell|] + +handleFormR = do + (res, form, enctype) <- runFormPost $ (,,,,) + <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing + <*> requiredField stringField (string "Another field") (string "") (Just "some default text") + <*> requiredField intField (string "A number field") (string "some nums") (Just 5) + <*> requiredField dayField (string "A day field") (string "") Nothing + <*> boolField (string "A checkbox") (string "") (Just False) + applyLayoutW $ do + addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] + flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet| +%form!method=post!enctype=$string.show.enctype$ + %table + ^h^ + %tr + %td!colspan=2 + %input!type=submit + %h3 + Result: $string.show.res$ +|] + setTitle $ string "Form" + main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000 From be3235a0b268757f89e6eb527e16449ddc5bdab3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 07:18:08 +0300 Subject: [PATCH 329/624] Added maybeAuthorized --- Yesod/Yesod.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7b17f149..14ff1cf1 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,6 +17,7 @@ module Yesod.Yesod -- * Convenience functions , applyLayout , applyLayoutJson + , maybeAuthorized -- * Defaults , defaultErrorHandler ) where @@ -34,6 +35,7 @@ import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) import Database.Persist import Web.Routes.Site (Site) +import Data.Maybe (isNothing) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -101,7 +103,7 @@ class Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Routes a -> Handler a (Maybe String) + isAuthorized :: Routes a -> GHandler s a (Maybe String) isAuthorized _ = return Nothing -- | A type-safe, concise method of creating breadcrumbs for pages. For each @@ -201,3 +203,12 @@ defaultErrorHandler (BadMethod m) = class YesodPersist y where type YesodDB y :: (* -> *) -> * -> * runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a + +-- | Return the same URL if the user is authorized to see it. +-- +-- Built on top of 'isAuthorized'. This is useful for building page that only +-- contain links to pages the user is allowed to see. +maybeAuthorized :: Yesod a => Routes a -> GHandler s a (Maybe (Routes a)) +maybeAuthorized r = do + x <- isAuthorized r + return $ if isNothing x then Just r else Nothing From f2e71a6c001aff092f6883d02dedfa49c07004b2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 07:18:39 +0300 Subject: [PATCH 330/624] htmlField and fixed auth --- Yesod/Form.hs | 57 +++++++++++++++++++++++++++++++++++++++---- Yesod/Helpers/Auth.hs | 14 +++++------ Yesod/Helpers/Crud.hs | 12 ++++----- hellowidget.hs | 11 ++++++--- 4 files changed, 73 insertions(+), 21 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index f365e842..1bd1916e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -8,18 +8,26 @@ -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types - Form (..) + GForm (..) + , Form + , FormField , FormResult (..) -- * Unwrapping functions , runFormGet , runFormPost , runFormGet' , runFormPost' + -- * Type classes + , IsForm (..) + , IsFormField (..) + -- * Pre-built fields , requiredField , stringField , intField , dayField , boolField + , htmlField + , stringInput , fieldsToTable {- FIXME -- * Create your own formlets @@ -60,7 +68,7 @@ import Data.Char (isAlphaNum, toUpper, isUpper) import Data.Maybe (isJust) import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64) -import qualified Data.ByteString.Lazy.UTF8 +import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget data FormResult a = FormMissing @@ -81,8 +89,8 @@ instance Applicative FormResult where data Enctype = UrlEncoded | Multipart instance Show Enctype where - show UrlEncoded = "urlencoded" - show Multipart = "multipart/mimetype" -- FIXME + show UrlEncoded = "application/x-www-form-urlencoded" + show Multipart = "multipart/form-data" instance Monoid Enctype where mempty = UrlEncoded mappend UrlEncoded UrlEncoded = UrlEncoded @@ -133,6 +141,11 @@ fieldsToTable = mapM_ go $fiErrors.fi$ |] +class IsForm a where + toForm :: Maybe a -> Form sub y a +class IsFormField a where + toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a + requiredField :: FieldProfile sub y a -> Html () -> Html () -> Maybe a -> FormField sub y a requiredField (FieldProfile parse render mkXml w) label tooltip orig = @@ -177,6 +190,8 @@ stringField = FieldProfile |] , fpWidget = \_name -> return () } +instance IsFormField String where + toFormField = requiredField stringField intField :: FieldProfile sub y Int intField = FieldProfile @@ -187,6 +202,8 @@ intField = FieldProfile |] , fpWidget = \_name -> return () } +instance IsFormField Int where + toFormField = requiredField intField dayField :: FieldProfile sub y Day dayField = FieldProfile @@ -202,6 +219,8 @@ dayField = FieldProfile addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|] } +instance IsFormField Day where + toFormField = requiredField dayField boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do @@ -224,6 +243,23 @@ boolField label tooltip orig = GForm $ \env _ -> do _ -> string "" } return (res, [fi], UrlEncoded) +instance IsFormField Bool where + toFormField = boolField + +htmlField :: FieldProfile sub y (Html ()) +htmlField = FieldProfile + { fpParse = Right . preEscapedString + , fpRender = U.toString . renderHtml + , fpHamlet = \name val isReq -> [$hamlet| +%textarea#$name$!name=$name$ $val$ +|] + , fpWidget = \name -> do + addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" + addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|] + addStyle [$hamlet|\#$string.name${min-width:400px;min-height:300px}|] + } +instance IsFormField (Html ()) where + toFormField = requiredField htmlField readMay :: Read a => String -> Maybe a readMay s = case reads s of @@ -232,6 +268,17 @@ readMay s = case reads s of --------------------- End prebuilt forms +--------------------- Begin prebuilt inputs + +stringInput :: String -> Form sub master String +stringInput n = GForm $ \env _ -> return + (case lookup n env of + Nothing -> FormMissing + Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] + Just x -> FormSuccess x, mempty, UrlEncoded) + +--------------------- End prebuilt inputs + incr :: Monad m => StateT Int m String incr = do i <- get @@ -324,7 +371,7 @@ instance Formable (Maybe String) where instance Formable (Html ()) where formable = fmap preEscapedString . input go - . fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml) + . fmap (U.toString . renderHtml) where go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 3de63fd4..366639c5 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -182,7 +182,7 @@ $maybe message msg getOpenIdForward :: GHandler Auth master () getOpenIdForward = do testOpenId - oid <- runFormGet' $ requiredField "openid" + oid <- runFormGet' $ stringInput "openid" render <- getUrlRender toMaster <- getRouteToMaster let complete = render $ toMaster OpenIdComplete @@ -302,7 +302,7 @@ getEmailRegisterR = do postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings - email <- runFormPost' $ notEmptyField "email" -- FIXME checkEmail + email <- runFormPost' $ stringInput "email" -- FIXME checkEmail y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <- @@ -367,8 +367,8 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost' $ (,) - <$> notEmptyField "email" -- FIXME valid e-mail? - <*> requiredField "password" + <$> stringInput "email" -- FIXME valid e-mail? + <*> stringInput "password" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email let mlid = @@ -420,8 +420,8 @@ postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do ae <- getAuthEmailSettings (new, confirm) <- runFormPost' $ (,) - <$> notEmptyField "new" - <*> notEmptyField "confirm" + <$> stringInput "new" + <*> stringInput "confirm" toMaster <- getRouteToMaster when (new /= confirm) $ do setMessage $ string "Passwords did not match, please try again" @@ -495,7 +495,7 @@ getFacebookR = do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR - code <- runFormGet' $ requiredField "code" + code <- runFormGet' $ stringInput "code" at <- liftIO $ Facebook.getAccessToken fb code so <- liftIO $ Facebook.getGraphData at "me" let c = fromMaybe (error "Invalid response from Facebook") $ do diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index d777494d..f469a07a 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -19,7 +19,7 @@ import Text.Hamlet import Yesod.Form import Data.Monoid (mempty) -class Formable a => Item a where +class IsForm a => Item a where itemTitle :: a -> String data Crud master item = Crud @@ -133,7 +133,7 @@ crudHelper -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do crud <- getYesodSub - (errs, form) <- runFormPost $ formable $ fmap snd me + (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of (True, FormSuccess a) -> do @@ -146,21 +146,21 @@ crudHelper title me isPost = do $ toSinglePiece eid _ -> return () applyLayoutW $ do - wrapWidget (wrapForm toMaster) form + wrapWidget (wrapForm toMaster enctype) form setTitle $ string title where - wrapForm toMaster form = [$hamlet| + wrapForm toMaster enctype form = [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $string.title$ -%form!method=post +%form!method=post!enctype=$string.show.enctype$ %table ^form^ %tr %td!colspan=2 %input!type=submit $maybe me e - \ + \ $ %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] diff --git a/hellowidget.hs b/hellowidget.hs index fb8983d5..c06264f4 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -34,12 +34,17 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,) + (res, form, enctype) <- runFormPost $ (,,,,,) <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing <*> requiredField stringField (string "Another field") (string "") (Just "some default text") <*> requiredField intField (string "A number field") (string "some nums") (Just 5) <*> requiredField dayField (string "A day field") (string "") Nothing <*> boolField (string "A checkbox") (string "") (Just False) + <*> requiredField htmlField (string "HTML") (string "") + (Just $ string "You can put rich text here") + let mhtml = case res of + FormSuccess (_, _, _, _, _, x) -> Just x + _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet| @@ -49,8 +54,8 @@ handleFormR = do %tr %td!colspan=2 %input!type=submit - %h3 - Result: $string.show.res$ + $maybe mhtml html + $html$ |] setTitle $ string "Form" From 65d8e2febd1c5df3a8104a564eb95d9ffe32a5d7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 09:19:26 +0300 Subject: [PATCH 331/624] Added blog sample --- .gitignore | 1 + Yesod/Form.hs | 39 ++++++++++++------ Yesod/Yesod.hs | 2 +- blog.hs | 108 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 137 insertions(+), 13 deletions(-) create mode 100644 blog.hs diff --git a/.gitignore b/.gitignore index 31291836..ed9fa968 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ client_session_key.aes *.hi *.o +blog.db3 diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1bd1916e..4f10e95f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -29,6 +29,9 @@ module Yesod.Form , htmlField , stringInput , fieldsToTable + , share2 + , mkIsForm + , mapFormXml {- FIXME -- * Create your own formlets , incr @@ -102,6 +105,11 @@ newtype GForm sub y xml a = GForm type Form sub y = GForm sub y (Widget sub y ()) type FormField sub y = GForm sub y [FieldInfo sub y] +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () @@ -478,6 +486,7 @@ instance Formable Slug where | all (\c -> c `elem` "-_" || isAlphaNum c) x' = Right $ Slug x' | otherwise = Left ["Slug must be alphanumeric, - and _"] +-} share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do @@ -485,8 +494,8 @@ share2 f g a = do g' <- g a return $ f' ++ g' -deriveFormable :: [EntityDef] -> Q [Dec] -deriveFormable = mapM derive +mkIsForm :: [EntityDef] -> Q [Dec] +mkIsForm = mapM derive where derive :: EntityDef -> Q Dec derive t = do @@ -496,24 +505,31 @@ deriveFormable = mapM derive just <- [|pure|] nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ entityName t) + string' <- [|string|] + mempty' <- [|mempty|] + mfx <- [|mapFormXml|] + ftt <- [|fieldsToTable|] + let go_ = go ap just' string' mempty' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] - (NormalB $ go ap just' $ zip cols $ map (const nothing) cols) + (NormalB $ go_ $ zip cols $ map (const nothing) cols) [] xs <- mapM (const $ newName "x") cols let xs' = map (AppE just . VarE) xs let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) $ map VarP xs]] - (NormalB $ go ap just' $ zip cols xs') + (NormalB $ go_ $ zip cols xs') [] - return $ InstanceD [] (ConT ''Formable + return $ InstanceD [] (ConT ''IsForm `AppT` ConT (mkName $ entityName t)) - [FunD (mkName "formable") [c1, c2]] - go ap just' = foldl (ap' ap) just' . map go' - go' (label, ex) = - VarE (mkName "sealForm") `AppE` - (VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE` - (VarE (mkName "formable") `AppE` ex) + [FunD (mkName "toForm") [c1, c2]] + go ap just' string' mem mfx ftt a = + let x = foldl (ap' ap) just' $ map (go' string' mem) a + in mfx `AppE` ftt `AppE` x + go' string' mempty' (label, ex) = + let label' = string' `AppE` LitE (StringL label) + in VarE (mkName "toFormField") `AppE` label' + `AppE` mempty' `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String @@ -524,4 +540,3 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs --} diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 14ff1cf1..8c2a3876 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -103,7 +103,7 @@ class Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Routes a -> GHandler s a (Maybe String) + isAuthorized :: Routes a -> GHandler s a (Maybe String) -- FIXME use a data type that specifies whether authentication is required isAuthorized _ = return Nothing -- | A type-safe, concise method of creating breadcrumbs for pages. For each diff --git a/blog.hs b/blog.hs new file mode 100644 index 00000000..0a9b50c1 --- /dev/null +++ b/blog.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} +import Yesod +import Yesod.Helpers.Auth +import Yesod.Helpers.Crud +import Database.Persist.Sqlite +import Data.Time (Day) + +type Html' = Html () +share2 mkPersist mkIsForm [$persist| +Entry + title String + posted Day Desc + content Html' + deriving +|] +instance Item Entry where + itemTitle = entryTitle + +getAuth = const $ Auth + { authIsOpenIdEnabled = False + , authRpxnowApiKey = Nothing + , authEmailSettings = Nothing + -- | client id, secret and requested permissions + , authFacebook = Just (clientId, secret, ["email"]) + } + where + clientId = "134280699924829" + secret = "a7685e10c8977f5435e599aaf1d232eb" + +data Blog = Blog Connection +type EntryCrud = Crud Blog Entry +mkYesod "Blog" [$parseRoutes| +/ RootR GET +/entry/#EntryId EntryR GET +/admin AdminR EntryCrud defaultCrud +/auth AuthR Auth getAuth +|] +instance Yesod Blog where + approot _ = "http://localhost:3000" + defaultLayout p = do + mcreds <- maybeCreds + admin <- maybeAuthorized $ AdminR CrudListR + hamletToContent [$hamlet| +!!! +%html + %head + %title $pageTitle.p$ + ^pageHead.p^ + %body + %p + %a!href=@RootR@ Homepage + $maybe admin a + \ | $ + %a!href=@a@ Admin + \ | $ + $maybe mcreds c + Welcome $ + $maybe credsDisplayName.c dn + $string.dn$ + $nothing + $string.credsIdent.c$ + \ $ + %a!href=@AuthR.Logout@ Logout + $nothing + %a!href=@AuthR.StartFacebookR@ Facebook Connect + ^pageBody.p^ + %p + Powered by Yesod Web Framework +|] + isAuthorized AdminR{} = do + mc <- maybeCreds + let x = (mc >>= credsEmail) == Just "michael@snoyman.com" + return $ if x then Nothing else Just "Permission denied" + isAuthorized _ = return Nothing +instance YesodAuth Blog where + defaultDest _ = RootR + defaultLoginRoute _ = RootR +instance YesodPersist Blog where + type YesodDB Blog = SqliteReader + runDB db = do + Blog conn <- getYesod + runSqlite db conn + +getRootR = do + entries <- runDB $ select [] [EntryPostedDesc] + applyLayoutW $ do + setTitle $ string "Blog tutorial homepage" + addBody [$hamlet| +%h1 All Entries +%ul + $forall entries entry + %li + %a!href=@EntryR.fst.entry@ $string.entryTitle.snd.entry$ +|] + +getEntryR :: EntryId -> Handler Blog RepHtml +getEntryR eid = do + entry <- runDB (get eid) >>= maybe notFound return + applyLayoutW $ do + setTitle $ string $ entryTitle entry + addBody [$hamlet| +%h1 $string.entryTitle.entry$ +%h2 $string.show.entryPosted.entry$ +#content $entryContent.entry$ +|] +main = withSqlite "blog.db3" $ \conn -> do + flip runSqlite conn $ initialize (undefined :: Entry) + toWaiApp (Blog conn) >>= basicHandler 3000 From 879d5657bac213b874a6ee676d24761813c737ba Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 09:22:15 +0300 Subject: [PATCH 332/624] Remove old content from Form module --- Yesod/Form.hs | 195 +++----------------------------------------------- 1 file changed, 10 insertions(+), 185 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4f10e95f..62dab6b3 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -20,38 +20,21 @@ module Yesod.Form -- * Type classes , IsForm (..) , IsFormField (..) - -- * Pre-built fields + -- * Field/form helpers , requiredField + , mapFormXml + , newFormIdent + -- * Pre-built fields + , fieldsToTable , stringField , intField , dayField , boolField , htmlField , stringInput - , fieldsToTable + -- * Template Haskell , share2 , mkIsForm - , mapFormXml - {- FIXME - -- * Create your own formlets - , incr - , input - , check - -- * Error display - , wrapperRow - , sealFormlet - , sealForm - , sealRow - -- * Formable - , Formable (..) - , deriveFormable - , share2 - -- * Pre-built form - , optionalField - , requiredField - , notEmptyField - , boolField - -} ) where import Text.Hamlet @@ -158,7 +141,7 @@ requiredField :: FieldProfile sub y a -> Html () -> Html () -> Maybe a -> FormField sub y a requiredField (FieldProfile parse render mkXml w) label tooltip orig = GForm $ \env _ -> do - name <- incr + name <- newFormIdent let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -232,7 +215,7 @@ instance IsFormField Day where boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do - name <- incr + name <- newFormIdent let (res, val) = if null env then (FormMissing, fromMaybe False orig) @@ -287,8 +270,8 @@ stringInput n = GForm $ \env _ -> return --------------------- End prebuilt inputs -incr :: Monad m => StateT Int m String -incr = do +newFormIdent :: Monad m => StateT Int m String +newFormIdent = do i <- get let i' = i + 1 put i' @@ -330,164 +313,6 @@ runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f -{- - --------- Prebuilt -optionalField :: String -> Form sub master (Maybe String) -optionalField n = Form $ \env _ -> - return (FormSuccess $ lookup n env, mempty) -- FIXME - -requiredField :: String -> Form sub master String -requiredField n = Form $ \env _ -> - return (maybe FormMissing FormSuccess $ lookup n env, mempty) -- FIXME - -notEmptyField :: String -> Form sub master String -notEmptyField n = Form $ \env _ -> return - (case lookup n env of - Nothing -> FormMissing - Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] - Just x -> FormSuccess x, mempty) -- FIXME - -boolField :: String -> Form sub master Bool -boolField n = Form $ \env _ -> return - (FormSuccess $ isJust $ lookup n env, mempty) -- FIXME - -class Formable a where - formable :: Formlet sub master a - ---------------- Formable instances -instance Formable String where - formable x = input go x `check` notEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - notEmpty s - | null s = Left ["Value required"] - | otherwise = Right s - -instance Formable (Maybe String) where - formable x = input go (join x) `check` isEmpty - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - isEmpty s - | null s = Right Nothing - | otherwise = Right $ Just s - -instance Formable (Html ()) where - formable = fmap preEscapedString - . input go - . fmap (U.toString . renderHtml) - where - go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|] - -instance Formable Day where - formable x = input go (fmap show x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid day"] - -instance Formable Int64 where - formable x = input go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -instance Formable Double where - formable x = input go (fmap numstring x) `check` asDouble - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asDouble s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid double"] - numstring d = - let s = show d - in case reverse s of - '0':'.':y -> reverse y - _ -> s - -instance Formable (Maybe Day) where - formable x = input go (fmap show $ join x) `check` asDay - where - go name val = [$hamlet| -%input!type=date!name=$string.name$!value=$string.val$ -|] - asDay "" = Right Nothing - asDay s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid day"] - -instance Formable (Maybe Int) where - formable x = input go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable (Maybe Int64) where - formable x = input go (fmap show $ join x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt "" = Right Nothing - asInt s = case reads s of - (y, _):_ -> Right $ Just y - [] -> Left ["Invalid integer"] - -instance Formable Bool where - formable x = Form $ \env _ -> do - i <- incr - let param = lookup i env - let def = if null env then fromMaybe False x else isJust param - return (FormSuccess $ isJust param, go i def) - where - go name val = addBody [$hamlet| -%input!type=checkbox!name=$string.name$!:val:checked -|] - -instance Formable Int where - formable x = input go (fmap show x) `check` asInt - where - go name val = [$hamlet| -%input!type=number!name=$string.name$!value=$string.val$ -|] - asInt s = case reads s of - (y, _):_ -> Right y - [] -> Left ["Invalid integer"] - -newtype Slug = Slug { unSlug :: String } - deriving (Read, Eq, Show, SinglePiece, PersistField) - -instance Formable Slug where - formable x = input go (fmap unSlug x) `check` asSlug - where - go name val = [$hamlet| -%input!type=text!name=$string.name$!value=$string.val$ -|] - asSlug [] = Left ["Slug must be non-empty"] - asSlug x' - | all (\c -> c `elem` "-_" || isAlphaNum c) x' = - Right $ Slug x' - | otherwise = Left ["Slug must be alphanumeric, - and _"] --} - share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do f' <- f a From c7f1669ac0ae0d6050100b66c1793a480a8e7cb6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 09:37:17 +0300 Subject: [PATCH 333/624] Yesod routes must fulfill equality constraint --- Yesod/Helpers/Crud.hs | 15 +++++---------- Yesod/Yesod.hs | 7 ++++--- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index f469a07a..bbcf3add 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -34,7 +34,6 @@ mkYesodSub "Crud master item" [ ("master", [''Yesod]) , ("item", [''Item]) , ("Key item", [''SinglePiece]) - , ("Routes master", [''Eq]) ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST @@ -58,24 +57,21 @@ getCrudListR = do %a!href=@toMaster.CrudAddR@ Add new item |] -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - Eq (Routes master)) +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) => GHandler (Crud master item) master RepHtml getCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) False -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - Eq (Routes master)) +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) => GHandler (Crud master item) master RepHtml postCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) True -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - Eq (Routes master)) +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -86,8 +82,7 @@ getCrudEditR s = do (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - Eq (Routes master)) +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -128,7 +123,7 @@ itemReadId :: SinglePiece x => String -> Maybe x itemReadId = either (const Nothing) Just . fromSinglePiece crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), Eq (Routes master)) + :: (Item a, Yesod master, SinglePiece (Key a)) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 8c2a3876..6c300a95 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod @@ -39,18 +40,18 @@ import Data.Maybe (isNothing) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class YesodSite y where +class Eq (Routes y) => YesodSite y where getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need -- to deal with it directly, as the mkYesodSub creates instances appropriately. -class YesodSubSite s y where +class Eq (Routes s) => YesodSubSite s y where getSubSite :: Site (Routes s) (Method -> Maybe (GHandler s y ChooseRep)) -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. -class Yesod a where +class Eq (Routes a) => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- From 56240984f30472039cc8a388fd3b614a48241e83 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 2 Jul 2010 13:36:45 +0300 Subject: [PATCH 334/624] A bunch of minor additions for forms --- Yesod/Form.hs | 205 ++++++++++++++++++++++++++++++++++++------ Yesod/Helpers/Crud.hs | 2 +- Yesod/Widget.hs | 65 +++++++------- Yesod/Yesod.hs | 8 +- 4 files changed, 218 insertions(+), 62 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 62dab6b3..63f773f9 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -10,8 +10,12 @@ module Yesod.Form ( -- * Data types GForm (..) , Form + , Formlet , FormField , FormResult (..) + , Enctype (..) + , FieldInfo (..) + , FieldProfile (..) -- * Unwrapping functions , runFormGet , runFormPost @@ -22,16 +26,22 @@ module Yesod.Form , IsFormField (..) -- * Field/form helpers , requiredField + , optionalField , mapFormXml , newFormIdent - -- * Pre-built fields , fieldsToTable + -- * Pre-built fields , stringField , intField , dayField , boolField , htmlField + , selectField + , maybeSelectField + -- * Pre-built inputs , stringInput + , maybeStringInput + , boolInput -- * Template Haskell , share2 , mkIsForm @@ -42,17 +52,14 @@ import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) import Control.Monad.Trans.State -import Control.Arrow (first) import Language.Haskell.TH.Syntax -import Database.Persist.Base (PersistField, EntityDef (..)) -import Data.Char (isAlphaNum, toUpper, isUpper) -import Data.Maybe (isJust) -import Web.Routes.Quasi (SinglePiece) +import Database.Persist.Base (EntityDef (..)) +import Data.Char (toUpper, isUpper) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget @@ -85,7 +92,8 @@ instance Monoid Enctype where newtype GForm sub y xml a = GForm { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype) } -type Form sub y = GForm sub y (Widget sub y ()) +type Form sub y = GForm sub y (GWidget sub y ()) +type Formlet sub y a = Maybe a -> Form sub y a type FormField sub y = GForm sub y [FieldInfo sub y] mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a @@ -97,8 +105,8 @@ data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () , fiIdent :: String - , fiInput :: Widget sub y () - , fiErrors :: Html () + , fiInput :: GWidget sub y () + , fiErrors :: Maybe (Html ()) } type Env = [(String, String)] @@ -108,7 +116,7 @@ instance Monoid xml => Functor (GForm sub url xml) where fmap f (GForm g) = GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) where - first3 f (x, y, z) = (f x, y, z) + first3 f' (x, y, z) = (f' x, y, z) instance Monoid xml => Applicative (GForm sub url xml) where pure a = GForm $ const $ const $ return (pure a, mempty, mempty) @@ -117,19 +125,19 @@ instance Monoid xml => Applicative (GForm sub url xml) where (g1, g2, g3) <- g env fe return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -fieldsToTable :: [FieldInfo sub y] -> Widget sub y () +fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () fieldsToTable = mapM_ go where go fi = do - flip wrapWidget (fiInput fi) $ \w -> [$hamlet| + wrapWidget (fiInput fi) $ \w -> [$hamlet| %tr %td %label!for=$string.fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$ %td ^w^ - %td.errors - $fiErrors.fi$ + $maybe fiErrors.fi err + %td.errors $err$ |] class IsForm a where @@ -158,8 +166,36 @@ requiredField (FieldProfile parse render mkXml w) label tooltip orig = , fiIdent = name , fiInput = w name >> addBody (mkXml (string name) (string val) True) , fiErrors = case res of - FormFailure [x] -> string x - _ -> string "" + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +optionalField :: FieldProfile sub y a + -> Html () -> Html () -> Maybe (Maybe a) + -> FormField sub y (Maybe a) +optionalField (FieldProfile parse render mkXml w) label tooltip orig' = + GForm $ \env _ -> do + let orig = join orig' + name <- newFormIdent + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormSuccess Nothing, "") + Just "" -> (FormSuccess Nothing, "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess $ Just y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = name + , fiInput = w name >> addBody (mkXml (string name) (string val) False) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing } return (res, [fi], UrlEncoded) @@ -167,7 +203,7 @@ data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y) - , fpWidget :: String -> Widget sub y () + , fpWidget :: String -> GWidget sub y () } --------------------- Begin prebuilt forms @@ -183,18 +219,45 @@ stringField = FieldProfile } instance IsFormField String where toFormField = requiredField stringField +instance IsFormField (Maybe String) where + toFormField = optionalField stringField -intField :: FieldProfile sub y Int +intField :: Integral i => FieldProfile sub y i intField = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMay + { fpParse = maybe (Left "Invalid integer") Right . readMayI + , fpRender = showI + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + where + showI x = show (fromIntegral x :: Integer) + readMayI s = case reads s of + (x, _):_ -> Just $ fromInteger x + [] -> Nothing +instance IsFormField Int where + toFormField = requiredField intField +instance IsFormField (Maybe Int) where + toFormField = optionalField intField +instance IsFormField Int64 where + toFormField = requiredField intField +instance IsFormField (Maybe Int64) where + toFormField = optionalField intField + +doubleField :: FieldProfile sub y Double +doubleField = FieldProfile + { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () } -instance IsFormField Int where - toFormField = requiredField intField +instance IsFormField Double where + toFormField = requiredField doubleField +instance IsFormField (Maybe Double) where + toFormField = optionalField doubleField dayField :: FieldProfile sub y Day dayField = FieldProfile @@ -212,6 +275,8 @@ dayField = FieldProfile } instance IsFormField Day where toFormField = requiredField dayField +instance IsFormField (Maybe Day) where + toFormField = optionalField dayField boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do @@ -230,8 +295,8 @@ boolField label tooltip orig = GForm $ \env _ -> do %input#$string.name$!type=checkbox!name=$string.name$!:val:checked |] , fiErrors = case res of - FormFailure [x] -> string x - _ -> string "" + FormFailure [x] -> Just $ string x + _ -> Nothing } return (res, [fi], UrlEncoded) instance IsFormField Bool where @@ -241,22 +306,97 @@ htmlField :: FieldProfile sub y (Html ()) htmlField = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \name val isReq -> [$hamlet| -%textarea#$name$!name=$name$ $val$ + , fpHamlet = \name val _isReq -> [$hamlet| +%textarea.html#$name$!name=$name$ $val$ |] , fpWidget = \name -> do addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|] - addStyle [$hamlet|\#$string.name${min-width:400px;min-height:300px}|] } instance IsFormField (Html ()) where toFormField = requiredField htmlField +instance IsFormField (Maybe (Html ())) where + toFormField = optionalField htmlField readMay :: Read a => String -> Maybe a readMay s = case reads s of (x, _):_ -> Just x [] -> Nothing +selectField :: Eq x => [(x, String)] + -> Html () -> Html () + -> Maybe x -> FormField sub master x +selectField pairs label tooltip initial = GForm $ \env _ -> do + i <- newFormIdent + let pairs' = zip [1 :: Int ..] pairs + let res = case lookup i env of + Nothing -> FormMissing + Just "none" -> FormFailure ["Field is required"] + Just x -> + case reads x of + (x', _):_ -> + case lookup x' pairs' of + Nothing -> FormFailure ["Invalid entry"] + Just (y, _) -> FormSuccess y + [] -> FormFailure ["Invalid entry"] + let isSelected x = + case res of + FormSuccess y -> x == y + _ -> Just x == initial + let input = [$hamlet| +%select#$string.i$!name=$string.i$ + %option!value=none + $forall pairs' pair + %option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = i + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +maybeSelectField :: Eq x => [(x, String)] + -> Html () -> Html () + -> Maybe x -> FormField sub master (Maybe x) +maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do + i <- newFormIdent + let pairs' = zip [1 :: Int ..] pairs + let res = case lookup i env of + Nothing -> FormMissing + Just "none" -> FormSuccess Nothing + Just x -> + case reads x of + (x', _):_ -> + case lookup x' pairs' of + Nothing -> FormFailure ["Invalid entry"] + Just (y, _) -> FormSuccess $ Just y + [] -> FormFailure ["Invalid entry"] + let isSelected x = + case res of + FormSuccess y -> Just x == y + _ -> Just x == initial + let input = [$hamlet| +%select#$string.i$!name=$string.i$ + %option!value=none + $forall pairs' pair + %option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = i + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + --------------------- End prebuilt forms --------------------- Begin prebuilt inputs @@ -268,6 +408,17 @@ stringInput n = GForm $ \env _ -> return Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] Just x -> FormSuccess x, mempty, UrlEncoded) +maybeStringInput :: String -> Form sub master (Maybe String) +maybeStringInput n = GForm $ \env _ -> return + (case lookup n env of + Nothing -> FormSuccess Nothing + Just "" -> FormSuccess Nothing + Just x -> FormSuccess $ Just x, mempty, UrlEncoded) + +boolInput :: String -> Form sub master Bool +boolInput n = GForm $ \env _ -> return + (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) + --------------------- End prebuilt inputs newFormIdent :: Monad m => StateT Int m String diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index bbcf3add..74263fca 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -141,7 +141,7 @@ crudHelper title me isPost = do $ toSinglePiece eid _ -> return () applyLayoutW $ do - wrapWidget (wrapForm toMaster enctype) form + wrapWidget form (wrapForm toMaster enctype) setTitle $ string title where wrapForm toMaster enctype form = [$hamlet| diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 21fa4891..8081e37d 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -5,7 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} module Yesod.Widget ( -- * Datatype - Widget + GWidget + , Widget -- * Unwrapping , widgetToPageContent , applyLayoutW @@ -64,7 +65,7 @@ newtype Head url = Head (Hamlet url) newtype Body url = Body (Hamlet url) deriving Monoid -newtype Widget sub master a = Widget ( +newtype GWidget sub master a = GWidget ( WriterT (Body (Routes master)) ( WriterT (Last Title) ( WriterT (UniqueList (Script (Routes master))) ( @@ -75,51 +76,52 @@ newtype Widget sub master a = Widget ( GHandler sub master ))))))) a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) -instance Monoid (Widget sub master ()) where +instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y +type Widget y = GWidget y y -setTitle :: Html () -> Widget sub master () -setTitle = Widget . lift . tell . Last . Just . Title +setTitle :: Html () -> GWidget sub master () +setTitle = GWidget . lift . tell . Last . Just . Title -addHead :: Hamlet (Routes master) -> Widget sub master () -addHead = Widget . lift . lift . lift . lift . lift . tell . Head +addHead :: Hamlet (Routes master) -> GWidget sub master () +addHead = GWidget . lift . lift . lift . lift . lift . tell . Head -addBody :: Hamlet (Routes master) -> Widget sub master () -addBody = Widget . tell . Body +addBody :: Hamlet (Routes master) -> GWidget sub master () +addBody = GWidget . tell . Body -newIdent :: Widget sub master String -newIdent = Widget $ lift $ lift $ lift $ lift $ lift $ lift $ do +newIdent :: GWidget sub master String +newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ do i <- get let i' = i + 1 put i' return $ "w" ++ show i' -addStyle :: Hamlet (Routes master) -> Widget sub master () -addStyle = Widget . lift . lift . lift . lift . tell . Style +addStyle :: Hamlet (Routes master) -> GWidget sub master () +addStyle = GWidget . lift . lift . lift . lift . tell . Style -addStylesheet :: Routes master -> Widget sub master () -addStylesheet = Widget . lift . lift . lift . tell . toUnique . Stylesheet . Local +addStylesheet :: Routes master -> GWidget sub master () +addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local -addStylesheetRemote :: String -> Widget sub master () +addStylesheetRemote :: String -> GWidget sub master () addStylesheetRemote = - Widget . lift . lift . lift . tell . toUnique . Stylesheet . Remote + GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote -addScript :: Routes master -> Widget sub master () -addScript = Widget . lift . lift . tell . toUnique . Script . Local +addScript :: Routes master -> GWidget sub master () +addScript = GWidget . lift . lift . tell . toUnique . Script . Local -addScriptRemote :: String -> Widget sub master () +addScriptRemote :: String -> GWidget sub master () addScriptRemote = - Widget . lift . lift . tell . toUnique . Script . Remote + GWidget . lift . lift . tell . toUnique . Script . Remote applyLayoutW :: (Eq (Routes m), Yesod m) - => Widget sub m () -> GHandler sub m RepHtml + => GWidget sub m () -> GHandler sub m RepHtml applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout widgetToPageContent :: Eq (Routes master) - => Widget sub master () + => GWidget sub master () -> GHandler sub master (PageContent (Routes master)) -widgetToPageContent (Widget w) = do +widgetToPageContent (GWidget w) = do w' <- flip evalStateT 0 $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT $ runWriterT w @@ -145,15 +147,16 @@ $forall stylesheets s |] return $ PageContent title head'' body -wrapWidget :: (Hamlet (Routes m) -> Hamlet (Routes m)) - -> Widget s m a -> Widget s m a -wrapWidget wrap (Widget w) = - Widget $ mapWriterT (fmap go) w +wrapWidget :: GWidget s m a + -> (Hamlet (Routes m) -> Hamlet (Routes m)) + -> GWidget s m a +wrapWidget (GWidget w) wrap = + GWidget $ mapWriterT (fmap go) w where go (a, Body h) = (a, Body $ wrap h) -extractBody :: Widget s m () -> Widget s m (Hamlet (Routes m)) -extractBody (Widget w) = - Widget $ mapWriterT (fmap go) w +extractBody :: GWidget s m () -> GWidget s m (Hamlet (Routes m)) +extractBody (GWidget w) = + GWidget $ mapWriterT (fmap go) w where go ((), Body h) = (h, Body mempty) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6c300a95..531ef1aa 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -113,13 +113,15 @@ class Eq (Routes a) => Yesod a where class YesodBreadcrumbs y where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Routes y -> Handler y (String, Maybe (Routes y)) + breadcrumb :: Routes y -> GHandler sub y (String, Maybe (Routes y)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => Handler y (String, [(Routes y, String)]) +breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Routes y, String)]) breadcrumbs = do - x <- getRoute + x' <- getRoute + tm <- getRouteToMaster + let x = fmap tm x' case x of Nothing -> return ("Not found", []) Just y -> do From fcfd1559cad577003aca7f12a89aa85eb2adab53 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 4 Jul 2010 01:00:50 +0300 Subject: [PATCH 335/624] Minor fix in atom --- Yesod/Helpers/AtomFeed.hs | 6 +++--- yesod.cabal | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 90bbde4d..769b1aa7 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -47,13 +47,13 @@ data AtomFeedEntry url = AtomFeedEntry , atomEntryContent :: Html () } -xmlns :: AtomFeed url -> Html () -xmlns _ = preEscapedString "http://www.w3.org/2005/Atom" +xmlns :: Html () +xmlns = preEscapedString "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?> -%feed!xmlns=$xmlns.arg$ +%feed!xmlns=$xmlns$ %title $string.atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ %link!href=@atomLinkHome.arg@ diff --git a/yesod.cabal b/yesod.cabal index 5ff38b18..8ee7494d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.5 && < 0.6, - hamlet >= 0.3.1 && < 0.4, + hamlet >= 0.4.0 && < 0.5, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, From 2289400d7a47935bb0d14e9e19a3dc08921aa2af Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 4 Jul 2010 01:28:15 +0300 Subject: [PATCH 336/624] Hamlet html-angle-brackets change --- Yesod/Form.hs | 30 +++++++++++++++--------------- Yesod/Helpers/AtomFeed.hs | 15 ++++++--------- Yesod/Helpers/Auth.hs | 10 +++++----- Yesod/Helpers/Crud.hs | 8 ++++---- Yesod/Helpers/Sitemap.hs | 11 ++++------- Yesod/Widget.hs | 2 +- Yesod/Yesod.hs | 12 ++++++------ 7 files changed, 41 insertions(+), 47 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 63f773f9..c9fa6859 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -132,12 +132,12 @@ fieldsToTable = mapM_ go wrapWidget (fiInput fi) $ \w -> [$hamlet| %tr %td - %label!for=$string.fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ + %label!for=$fiIdent.fi$ $<fiLabel.fi>$ + .tooltip $<fiTooltip.fi>$ %td ^w^ $maybe fiErrors.fi err - %td.errors $err$ + %td.errors $<err>$ |] class IsForm a where @@ -213,7 +213,7 @@ stringField = FieldProfile { fpParse = Right , fpRender = id , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=text!:isReq:required!value=$val$ +%input#$<name>$!name=$<name>$!type=text!:isReq:required!value=$<val>$ |] , fpWidget = \_name -> return () } @@ -227,7 +227,7 @@ intField = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ +%input#$<name>$!name=$<name>$!type=number!:isReq:required!value=$<val>$ |] , fpWidget = \_name -> return () } @@ -250,7 +250,7 @@ doubleField = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ +%input#$<name>$!name=$<name>$!type=number!:isReq:required!value=$<val>$ |] , fpWidget = \_name -> return () } @@ -265,13 +265,13 @@ dayField = FieldProfile . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ +%input#$<name>$!name=$<name>$!type=date!:isReq:required!value=$<val>$ |] , fpWidget = \name -> do addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addHead [$hamlet|%script $$(function(){$$("#$string.name$").datepicker({dateFormat:'yy-mm-dd'})})|] + addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] } instance IsFormField Day where toFormField = requiredField dayField @@ -292,7 +292,7 @@ boolField label tooltip orig = GForm $ \env _ -> do , fiTooltip = tooltip , fiIdent = name , fiInput = addBody [$hamlet| -%input#$string.name$!type=checkbox!name=$string.name$!:val:checked +%input#$name$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -307,11 +307,11 @@ htmlField = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$name$!name=$name$ $val$ +%textarea.html#$<name>$!name=$<name>$ $<val>$ |] , fpWidget = \name -> do addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" - addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$string.name$")})|] + addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] } instance IsFormField (Html ()) where toFormField = requiredField htmlField @@ -344,10 +344,10 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do FormSuccess y -> x == y _ -> Just x == initial let input = [$hamlet| -%select#$string.i$!name=$string.i$ +%select#$i$!name=$i$ %option!value=none $forall pairs' pair - %option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$ + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo { fiLabel = label @@ -381,10 +381,10 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do FormSuccess y -> Just x == y _ -> Just x == initial let input = [$hamlet| -%select#$string.i$!name=$string.i$ +%select#$i$!name=$i$ %option!value=none $forall pairs' pair - %option!value=$string.show.fst.pair$!:isSelected.fst.snd.pair:selected $string.snd.snd.pair$ + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo { fiLabel = label diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 769b1aa7..53455585 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -47,17 +47,14 @@ data AtomFeedEntry url = AtomFeedEntry , atomEntryContent :: Html () } -xmlns :: Html () -xmlns = preEscapedString "http://www.w3.org/2005/Atom" - template :: AtomFeed url -> Hamlet url template arg = [$xhamlet| <?xml version="1.0" encoding="utf-8"?> -%feed!xmlns=$xmlns$ - %title $string.atomTitle.arg$ +%feed!xmlns="http://www.w3.org/2005/Atom" + %title $atomTitle.arg$ %link!rel=self!href=@atomLinkSelf.arg@ %link!href=@atomLinkHome.arg@ - %updated $string.formatW3.atomUpdated.arg$ + %updated $formatW3.atomUpdated.arg$ %id @atomLinkHome.arg@ $forall atomEntries.arg entry ^entryTemplate.entry^ @@ -68,7 +65,7 @@ entryTemplate arg = [$xhamlet| %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@ - %updated $string.formatW3.atomEntryUpdated.arg$ - %title $string.atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ + %updated $formatW3.atomEntryUpdated.arg$ + %title $atomEntryTitle.arg$ + %content!type=html $<cdata.atomEntryContent.arg>$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 366639c5..2b5b4b99 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -172,7 +172,7 @@ getOpenIdR = do message <- getMessage applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg - %p.message $msg$ + %p.message $<msg>$ %form!method=get!action=@rtom.OpenIdForward@ %label!for=openid OpenID: $ %input#openid!type=text!name=openid @@ -257,7 +257,7 @@ getCheck = do $if isNothing.creds %p Not logged in $maybe creds c - %p Logged in as $string.credsIdent.c$ + %p Logged in as $credsIdent.c$ |] json creds = jsonMap @@ -317,7 +317,7 @@ postEmailRegisterR = do let verUrl = render $ tm $ EmailVerifyR lid verKey liftIO $ sendVerifyEmail ae email verKey verUrl applyLayout "Confirmation e-mail sent" mempty [$hamlet| -%p A confirmation e-mail has been sent to $string.email$. +%p A confirmation e-mail has been sent to $email$. |] getEmailVerifyR :: YesodAuth master @@ -344,7 +344,7 @@ getEmailLoginR = do msg <- getMessage applyLayout "Login" mempty [$hamlet| $maybe msg ms - %p.message $ms$ + %p.message $<ms>$ %p Please log in to your account. %p %a!href=@toMaster.EmailRegisterR@ I don't have an account @@ -399,7 +399,7 @@ getEmailPasswordR = do msg <- getMessage applyLayout "Set password" mempty [$hamlet| $maybe msg ms - %p.message $ms$ + %p.message $<ms>$ %h3 Set a new password %form!method=post!action=@toMaster.EmailPasswordR@ %table diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 74263fca..9fd93c23 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -52,7 +52,7 @@ getCrudListR = do $forall items item %li %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ - $string.itemTitle.snd.item$ + $itemTitle.snd.item$ %p %a!href=@toMaster.CrudAddR@ Add new item |] @@ -103,7 +103,7 @@ getCrudDeleteR s = do applyLayout "Confirm delete" mempty [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? - %p Do you really want to delete $string.itemTitle.item$? + %p Do you really want to delete $itemTitle.item$? %p %input!type=submit!value=Yes \ $ @@ -147,8 +147,8 @@ crudHelper title me isPost = do wrapForm toMaster enctype form = [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list -%h1 $string.title$ -%form!method=post!enctype=$string.show.enctype$ +%h1 $title$ +%form!method=post!enctype=$show.enctype$ %table ^form^ %tr diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index dbe21d6d..82c12eba 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -50,18 +50,15 @@ data SitemapUrl url = SitemapUrl , priority :: Double } -sitemapNS :: Html () -sitemapNS = string "http://www.sitemaps.org/schemas/sitemap/0.9" - template :: [SitemapUrl url] -> Hamlet url template urls = [$hamlet| -%urlset!xmlns=$sitemapNS$ +%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" $forall urls url %url %loc @sitemapLoc.url@ - %lastmod $string.formatW3.sitemapLastMod.url$ - %changefreq $string.showFreq.sitemapChangeFreq.url$ - %priority $string.show.priority.url$ + %lastmod $formatW3.sitemapLastMod.url$ + %changefreq $showFreq.sitemapChangeFreq.url$ + %priority $show.priority.url$ |] sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 8081e37d..00d1dfb0 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -42,7 +42,7 @@ data Location url = Local url | Remote String deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url locationToHamlet (Local url) = [$hamlet|@url@|] -locationToHamlet (Remote s) = [$hamlet|$string.s$|] +locationToHamlet (Remote s) = [$hamlet|$s$|] newtype UniqueList x = UniqueList ([x] -> [x]) instance Monoid (UniqueList x) where diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 531ef1aa..64f4f475 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -83,7 +83,7 @@ class Eq (Routes a) => Yesod a where !!! %html %head - %title $pageTitle.p$ + %title $<pageTitle.p>$ ^pageHead.p^ %body ^pageBody.p^ @@ -176,31 +176,31 @@ defaultErrorHandler NotFound = do r <- waiRequest applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $string.toString.pathInfo.r$ +%p $toString.pathInfo.r$ |] where pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" $ [$hamlet| %h1 Permission denied -%p $string.msg$ +%p $msg$ |] defaultErrorHandler (InvalidArgs ia) = applyLayout' "Invalid Arguments" $ [$hamlet| %h1 Invalid Arguments %ul $forall ia msg - %li $string.msg$ + %li $msg$ |] defaultErrorHandler (InternalError e) = applyLayout' "Internal Server Error" $ [$hamlet| %h1 Internal Server Error -%p $string.e$ +%p $e$ |] defaultErrorHandler (BadMethod m) = applyLayout' "Bad Method" $ [$hamlet| %h1 Method Not Supported -%p Method "$string.m$" not supported +%p Method "$m$" not supported |] class YesodPersist y where From c71821a5c9c464113084b97ed4124d8264a5654c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 4 Jul 2010 08:21:41 +0300 Subject: [PATCH 337/624] Added time field --- Yesod/Form.hs | 42 +++++++++++++++++++++++++++++++++++++++++- hellowidget.hs | 17 +++++++++-------- 2 files changed, 50 insertions(+), 9 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index c9fa6859..66345121 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -34,6 +34,7 @@ module Yesod.Form , stringField , intField , dayField + , timeField , boolField , htmlField , selectField @@ -51,7 +52,7 @@ import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) -import Data.Time (Day) +import Data.Time (Day, TimeOfDay (TimeOfDay)) import Data.Maybe (fromMaybe, isJust) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) @@ -278,6 +279,45 @@ instance IsFormField Day where instance IsFormField (Maybe Day) where toFormField = optionalField dayField +parseTime :: String -> Either String TimeOfDay +parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0'] +parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper [h1, h2, m1, m2, '0', '0'] +parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = + parseTimeHelper [h1, h2, m1, m2, s1, s2] +parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" + +parseTimeHelper :: String -> Either String TimeOfDay +parseTimeHelper (h1:h2:m1:m2:s1:s2:[]) + | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h + | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m + | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s + | otherwise = Right $ TimeOfDay h m s + where + h = read [h1, h2] + m = read [m1, m2] + s = fromInteger $ read [s1, s2] + +timeField :: FieldProfile sub y TimeOfDay +timeField = FieldProfile + { fpParse = parseTime + , fpRender = show + , fpHamlet = \name val isReq -> [$hamlet| +%input#$<name>$!name=$<name>$!:isReq:required!value=$<val>$ +|] + , fpWidget = \name -> do + return () + {- + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] + -} + } +instance IsFormField TimeOfDay where + toFormField = requiredField timeField +instance IsFormField (Maybe TimeOfDay) where + toFormField = optionalField timeField + boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do name <- newFormIdent diff --git a/hellowidget.hs b/hellowidget.hs index c06264f4..682ae152 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -15,16 +15,16 @@ wrapper h = [$hamlet| #wrapper ^h^ %footer Brought to you by Yesod Widgets™ |] -getRootR = applyLayoutW $ wrapWidget wrapper $ do +getRootR = applyLayoutW $ flip wrapWidget wrapper $ do i <- newIdent setTitle $ string "Hello Widgets" - addStyle [$hamlet|\#$string.i${color:red}|] + addStyle [$hamlet|\#$i${color:red}|] addStylesheet $ StaticR $ StaticRoute ["style.css"] addStylesheetRemote "http://localhost:3000/static/style2.css" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" addScript $ StaticR $ StaticRoute ["script.js"] addBody [$hamlet| -%h1#$string.i$ Welcome to my first widget!!! +%h1#$i$ Welcome to my first widget!!! %p %a!href=@RootR@ Recursive link. %p @@ -34,28 +34,29 @@ getRootR = applyLayoutW $ wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,,) + (res, form, enctype) <- runFormPost $ (,,,,,,) <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing <*> requiredField stringField (string "Another field") (string "") (Just "some default text") <*> requiredField intField (string "A number field") (string "some nums") (Just 5) <*> requiredField dayField (string "A day field") (string "") Nothing + <*> requiredField timeField (string "A time field") (string "") Nothing <*> boolField (string "A checkbox") (string "") (Just False) <*> requiredField htmlField (string "HTML") (string "") (Just $ string "You can put rich text here") let mhtml = case res of - FormSuccess (_, _, _, _, _, x) -> Just x + FormSuccess (_, _, _, _, _, _, x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] - flip wrapWidget (fieldsToTable form) $ \h -> [$hamlet| -%form!method=post!enctype=$string.show.enctype$ + wrapWidget (fieldsToTable form) $ \h -> [$hamlet| +%form!method=post!enctype=$show.enctype$ %table ^h^ %tr %td!colspan=2 %input!type=submit $maybe mhtml html - $html$ + $<html>$ |] setTitle $ string "Form" From 6d05c9ec30e1dc62ee6039cf7b4c7a602d5335c8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 5 Jul 2010 22:43:41 +0300 Subject: [PATCH 338/624] Specify label and tooltip in field attributes --- Yesod/Form.hs | 16 +++++++++++++--- Yesod/Helpers/Auth.hs | 2 +- blog.hs | 17 +++++++++-------- 3 files changed, 23 insertions(+), 12 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 66345121..1de50d89 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -64,6 +64,7 @@ import Data.Char (toUpper, isUpper) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget +import Control.Arrow ((&&&)) data FormResult a = FormMissing | FormFailure [String] @@ -513,10 +514,18 @@ share2 f g a = do mkIsForm :: [EntityDef] -> Q [Dec] mkIsForm = mapM derive where + getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z + getLabel' [] = Nothing + getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x + getLabel' (_:x) = getLabel' x + getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z + getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x + getTooltip' (_:x) = getTooltip' x + getTooltip' [] = Nothing derive :: EntityDef -> Q Dec derive t = do let fst3 (x, _, _) = x - let cols = map (toLabel . fst3) $ entityColumns t + let cols = map (getLabel &&& getTooltip) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] @@ -542,10 +551,11 @@ mkIsForm = mapM derive go ap just' string' mem mfx ftt a = let x = foldl (ap' ap) just' $ map (go' string' mem) a in mfx `AppE` ftt `AppE` x - go' string' mempty' (label, ex) = + go' string' mempty' ((label, tooltip), ex) = let label' = string' `AppE` LitE (StringL label) + tooltip' = string' `AppE` LitE (StringL tooltip) in VarE (mkName "toFormField") `AppE` label' - `AppE` mempty' `AppE` ex + `AppE` tooltip' `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 2b5b4b99..6f224739 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -335,7 +335,7 @@ getEmailVerifyR lid key = do redirect RedirectTemporary $ toMaster EmailPasswordR _ -> applyLayout "Invalid verification key" mempty [$hamlet| %p I'm sorry, but that was an invalid verification key. - |] +|] getEmailLoginR :: Yesod master => GHandler Auth master RepHtml getEmailLoginR = do diff --git a/blog.hs b/blog.hs index 0a9b50c1..24d7c974 100644 --- a/blog.hs +++ b/blog.hs @@ -8,7 +8,7 @@ import Data.Time (Day) type Html' = Html () share2 mkPersist mkIsForm [$persist| Entry - title String + title String "label=Entry title" "tooltip=Make it something cool" posted Day Desc content Html' deriving @@ -44,8 +44,9 @@ instance Yesod Blog where !!! %html %head - %title $pageTitle.p$ + %title $<pageTitle.p>$ ^pageHead.p^ + %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666} %body %p %a!href=@RootR@ Homepage @@ -56,9 +57,9 @@ instance Yesod Blog where $maybe mcreds c Welcome $ $maybe credsDisplayName.c dn - $string.dn$ + $dn$ $nothing - $string.credsIdent.c$ + $credsIdent.c$ \ $ %a!href=@AuthR.Logout@ Logout $nothing @@ -90,7 +91,7 @@ getRootR = do %ul $forall entries entry %li - %a!href=@EntryR.fst.entry@ $string.entryTitle.snd.entry$ + %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ |] getEntryR :: EntryId -> Handler Blog RepHtml @@ -99,9 +100,9 @@ getEntryR eid = do applyLayoutW $ do setTitle $ string $ entryTitle entry addBody [$hamlet| -%h1 $string.entryTitle.entry$ -%h2 $string.show.entryPosted.entry$ -#content $entryContent.entry$ +%h1 $entryTitle.entry$ +%h2 $show.entryPosted.entry$ +#content $<entryContent.entry>$ |] main = withSqlite "blog.db3" $ \conn -> do flip runSqlite conn $ initialize (undefined :: Entry) From 55e0af467d6f0d64c16e8db1375167866b05015b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 09:14:18 +0300 Subject: [PATCH 339/624] Added JqueryDay and NicHtml newtypes --- Yesod/Form.hs | 58 ++++++++++++++++++++++++++++++++++++++++++++------- blog.hs | 9 ++++---- 2 files changed, 54 insertions(+), 13 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1de50d89..eb34510c 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -16,6 +16,9 @@ module Yesod.Form , Enctype (..) , FieldInfo (..) , FieldProfile (..) + -- * Newtype wrappers + , JqueryDay (..) + , NicHtml (..) -- * Unwrapping functions , runFormGet , runFormPost @@ -59,7 +62,7 @@ import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) import Control.Monad.Trans.State import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..)) +import Database.Persist.Base (EntityDef (..), PersistField) import Data.Char (toUpper, isUpper) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 as U @@ -268,6 +271,23 @@ dayField = FieldProfile , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| %input#$<name>$!name=$<name>$!type=date!:isReq:required!value=$<val>$ +|] + , fpWidget = const $ return () + } +instance IsFormField Day where + toFormField = requiredField dayField +instance IsFormField (Maybe Day) where + toFormField = optionalField dayField + +jqueryDayField :: FieldProfile sub y JqueryDay +jqueryDayField = dayField + { fpParse = maybe + (Left "Invalid day, must be in YYYY-MM-DD format") + (Right . JqueryDay) + . readMay + , fpRender = show . unJqueryDay + , fpHamlet = \name val isReq -> [$hamlet| +%input#$<name>$!name=$<name>$!type=date!:isReq:required!value=$<val>$ |] , fpWidget = \name -> do addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" @@ -275,10 +295,15 @@ dayField = FieldProfile addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] } -instance IsFormField Day where - toFormField = requiredField dayField -instance IsFormField (Maybe Day) where - toFormField = optionalField dayField + +-- | A newtype wrapper around 'Day', using jQuery UI date picker for the +-- 'IsFormField' instance. +newtype JqueryDay = JqueryDay { unJqueryDay :: Day } + deriving PersistField +instance IsFormField JqueryDay where + toFormField = requiredField jqueryDayField +instance IsFormField (Maybe JqueryDay) where + toFormField = optionalField jqueryDayField parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0'] @@ -350,15 +375,32 @@ htmlField = FieldProfile , fpHamlet = \name val _isReq -> [$hamlet| %textarea.html#$<name>$!name=$<name>$ $<val>$ |] - , fpWidget = \name -> do - addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" - addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] + , fpWidget = const $ return () } instance IsFormField (Html ()) where toFormField = requiredField htmlField instance IsFormField (Maybe (Html ())) where toFormField = optionalField htmlField +newtype NicHtml = NicHtml { unNicHtml :: Html () } + deriving PersistField + +nicHtmlField :: FieldProfile sub y NicHtml +nicHtmlField = FieldProfile + { fpParse = Right . NicHtml . preEscapedString + , fpRender = U.toString . renderHtml . unNicHtml + , fpHamlet = \name val _isReq -> [$hamlet| +%textarea.html#$<name>$!name=$<name>$ $<val>$ +|] + , fpWidget = \name -> do + addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" + addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] + } +instance IsFormField NicHtml where + toFormField = requiredField nicHtmlField +instance IsFormField (Maybe NicHtml) where + toFormField = optionalField nicHtmlField + readMay :: Read a => String -> Maybe a readMay s = case reads s of (x, _):_ -> Just x diff --git a/blog.hs b/blog.hs index 24d7c974..10c8c387 100644 --- a/blog.hs +++ b/blog.hs @@ -5,12 +5,11 @@ import Yesod.Helpers.Crud import Database.Persist.Sqlite import Data.Time (Day) -type Html' = Html () share2 mkPersist mkIsForm [$persist| Entry title String "label=Entry title" "tooltip=Make it something cool" - posted Day Desc - content Html' + posted JqueryDay Desc + content NicHtml deriving |] instance Item Entry where @@ -101,8 +100,8 @@ getEntryR eid = do setTitle $ string $ entryTitle entry addBody [$hamlet| %h1 $entryTitle.entry$ -%h2 $show.entryPosted.entry$ -#content $<entryContent.entry>$ +%h2 $show.unJqueryDay.entryPosted.entry$ +#content $<unNicHtml.entryContent.entry>$ |] main = withSqlite "blog.db3" $ \conn -> do flip runSqlite conn $ initialize (undefined :: Entry) From af46ece3ed87d57e7816afa0284df3d210ebdadc Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 09:15:55 +0300 Subject: [PATCH 340/624] Hamlet adds ToHtml typeclass --- Yesod/Form.hs | 22 +++++++++++----------- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Auth.hs | 6 +++--- Yesod/Widget.hs | 2 +- Yesod/Yesod.hs | 2 +- blog.hs | 4 ++-- 6 files changed, 19 insertions(+), 19 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index eb34510c..6f9aba6d 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -137,12 +137,12 @@ fieldsToTable = mapM_ go wrapWidget (fiInput fi) $ \w -> [$hamlet| %tr %td - %label!for=$fiIdent.fi$ $<fiLabel.fi>$ - .tooltip $<fiTooltip.fi>$ + %label!for=$fiIdent.fi$ $fiLabel.fi$ + .tooltip $fiTooltip.fi$ %td ^w^ $maybe fiErrors.fi err - %td.errors $<err>$ + %td.errors $err$ |] class IsForm a where @@ -218,7 +218,7 @@ stringField = FieldProfile { fpParse = Right , fpRender = id , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!type=text!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () } @@ -232,7 +232,7 @@ intField = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!type=number!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () } @@ -255,7 +255,7 @@ doubleField = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!type=number!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () } @@ -270,7 +270,7 @@ dayField = FieldProfile . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!type=date!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = const $ return () } @@ -287,7 +287,7 @@ jqueryDayField = dayField . readMay , fpRender = show . unJqueryDay , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!type=date!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" @@ -328,7 +328,7 @@ timeField = FieldProfile { fpParse = parseTime , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| -%input#$<name>$!name=$<name>$!:isReq:required!value=$<val>$ +%input#$name$!name=$name$!:isReq:required!value=$val$ |] , fpWidget = \name -> do return () @@ -373,7 +373,7 @@ htmlField = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$<name>$!name=$<name>$ $<val>$ +%textarea.html#$name$!name=$name$ $val$ |] , fpWidget = const $ return () } @@ -390,7 +390,7 @@ nicHtmlField = FieldProfile { fpParse = Right . NicHtml . preEscapedString , fpRender = U.toString . renderHtml . unNicHtml , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$<name>$!name=$<name>$ $<val>$ +%textarea.html#$name$!name=$name$ $val$ |] , fpWidget = \name -> do addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 53455585..23e99e34 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -67,5 +67,5 @@ entryTemplate arg = [$xhamlet| %link!href=@atomEntryLink.arg@ %updated $formatW3.atomEntryUpdated.arg$ %title $atomEntryTitle.arg$ - %content!type=html $<cdata.atomEntryContent.arg>$ + %content!type=html $cdata.atomEntryContent.arg$ |] diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 6f224739..f5e30d3e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -172,7 +172,7 @@ getOpenIdR = do message <- getMessage applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg - %p.message $<msg>$ + %p.message $msg$ %form!method=get!action=@rtom.OpenIdForward@ %label!for=openid OpenID: $ %input#openid!type=text!name=openid @@ -344,7 +344,7 @@ getEmailLoginR = do msg <- getMessage applyLayout "Login" mempty [$hamlet| $maybe msg ms - %p.message $<ms>$ + %p.message $ms$ %p Please log in to your account. %p %a!href=@toMaster.EmailRegisterR@ I don't have an account @@ -399,7 +399,7 @@ getEmailPasswordR = do msg <- getMessage applyLayout "Set password" mempty [$hamlet| $maybe msg ms - %p.message $<ms>$ + %p.message $ms$ %h3 Set a new password %form!method=post!action=@toMaster.EmailPasswordR@ %table diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 00d1dfb0..05c964b2 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -29,7 +29,7 @@ import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State -import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html, string) +import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) import Yesod.Handler (Routes, GHandler) import Yesod.Yesod (Yesod, defaultLayout) import Yesod.Content (RepHtml (..)) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 64f4f475..3d53130f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -83,7 +83,7 @@ class Eq (Routes a) => Yesod a where !!! %html %head - %title $<pageTitle.p>$ + %title $pageTitle.p$ ^pageHead.p^ %body ^pageBody.p^ diff --git a/blog.hs b/blog.hs index 10c8c387..722e0515 100644 --- a/blog.hs +++ b/blog.hs @@ -43,7 +43,7 @@ instance Yesod Blog where !!! %html %head - %title $<pageTitle.p>$ + %title $pageTitle.p$ ^pageHead.p^ %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666} %body @@ -101,7 +101,7 @@ getEntryR eid = do addBody [$hamlet| %h1 $entryTitle.entry$ %h2 $show.unJqueryDay.entryPosted.entry$ -#content $<unNicHtml.entryContent.entry>$ +#content $unNicHtml.entryContent.entry$ |] main = withSqlite "blog.db3" $ \conn -> do flip runSqlite conn $ initialize (undefined :: Entry) From ef7d27df7c3d13356ed4e31d67db0d751f2f8db1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 10:42:58 +0300 Subject: [PATCH 341/624] Renamings in Form --- Yesod/Form.hs | 245 +++++++++++++++++++++++++++--------------- Yesod/Helpers/Crud.hs | 2 +- 2 files changed, 157 insertions(+), 90 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 6f9aba6d..20b531f5 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -12,10 +12,10 @@ module Yesod.Form , Form , Formlet , FormField + , FormletField , FormResult (..) , Enctype (..) , FieldInfo (..) - , FieldProfile (..) -- * Newtype wrappers , JqueryDay (..) , NicHtml (..) @@ -25,30 +25,46 @@ module Yesod.Form , runFormGet' , runFormPost' -- * Type classes - , IsForm (..) - , IsFormField (..) + , ToForm (..) + , ToFormField (..) -- * Field/form helpers - , requiredField - , optionalField + , requiredFieldHelper + , optionalFieldHelper , mapFormXml , newFormIdent , fieldsToTable + -- * Field profiles + , FieldProfile (..) + , stringFieldProfile + , intFieldProfile + , dayFieldProfile + , timeFieldProfile + , htmlFieldProfile -- * Pre-built fields , stringField + , maybeStringField , intField + , maybeIntField + , doubleField + , maybeDoubleField , dayField + , maybeDayField , timeField - , boolField + , maybeTimeField , htmlField + , maybeHtmlField , selectField , maybeSelectField + , boolField -- * Pre-built inputs , stringInput , maybeStringInput , boolInput + , dayInput + , maybeDayInput -- * Template Haskell , share2 - , mkIsForm + , mkToForm ) where import Text.Hamlet @@ -100,6 +116,7 @@ newtype GForm sub y xml a = GForm type Form sub y = GForm sub y (GWidget sub y ()) type Formlet sub y a = Maybe a -> Form sub y a type FormField sub y = GForm sub y [FieldInfo sub y] +type FormletField sub y a = Maybe a -> FormField sub y a mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a mapFormXml f (GForm g) = GForm $ \e fe -> do @@ -145,14 +162,14 @@ fieldsToTable = mapM_ go %td.errors $err$ |] -class IsForm a where +class ToForm a where toForm :: Maybe a -> Form sub y a -class IsFormField a where +class ToFormField a where toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a -requiredField :: FieldProfile sub y a +requiredFieldHelper :: FieldProfile sub y a -> Html () -> Html () -> Maybe a -> FormField sub y a -requiredField (FieldProfile parse render mkXml w) label tooltip orig = +requiredFieldHelper (FieldProfile parse render mkXml w) label tooltip orig = GForm $ \env _ -> do name <- newFormIdent let (res, val) = @@ -176,10 +193,10 @@ requiredField (FieldProfile parse render mkXml w) label tooltip orig = } return (res, [fi], UrlEncoded) -optionalField :: FieldProfile sub y a +optionalFieldHelper :: FieldProfile sub y a -> Html () -> Html () -> Maybe (Maybe a) -> FormField sub y (Maybe a) -optionalField (FieldProfile parse render mkXml w) label tooltip orig' = +optionalFieldHelper (FieldProfile parse render mkXml w) label tooltip orig' = GForm $ \env _ -> do let orig = join orig' name <- newFormIdent @@ -213,8 +230,14 @@ data FieldProfile sub y a = FieldProfile --------------------- Begin prebuilt forms -stringField :: FieldProfile sub y String -stringField = FieldProfile +stringField :: Html () -> Html () -> FormletField sub y String +stringField = requiredFieldHelper stringFieldProfile + +maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String) +maybeStringField = optionalFieldHelper stringFieldProfile + +stringFieldProfile :: FieldProfile sub y String +stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id , fpHamlet = \name val isReq -> [$hamlet| @@ -222,13 +245,19 @@ stringField = FieldProfile |] , fpWidget = \_name -> return () } -instance IsFormField String where - toFormField = requiredField stringField -instance IsFormField (Maybe String) where - toFormField = optionalField stringField +instance ToFormField String where + toFormField = requiredFieldHelper stringFieldProfile +instance ToFormField (Maybe String) where + toFormField = optionalFieldHelper stringFieldProfile -intField :: Integral i => FieldProfile sub y i -intField = FieldProfile +intField :: Html () -> Html () -> FormletField sub y Int +intField = requiredFieldHelper intFieldProfile + +maybeIntField :: Html () -> Html () -> FormletField sub y (Maybe Int) +maybeIntField = optionalFieldHelper intFieldProfile + +intFieldProfile :: Integral i => FieldProfile sub y i +intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI , fpHamlet = \name val isReq -> [$hamlet| @@ -241,17 +270,23 @@ intField = FieldProfile readMayI s = case reads s of (x, _):_ -> Just $ fromInteger x [] -> Nothing -instance IsFormField Int where - toFormField = requiredField intField -instance IsFormField (Maybe Int) where - toFormField = optionalField intField -instance IsFormField Int64 where - toFormField = requiredField intField -instance IsFormField (Maybe Int64) where - toFormField = optionalField intField +instance ToFormField Int where + toFormField = requiredFieldHelper intFieldProfile +instance ToFormField (Maybe Int) where + toFormField = optionalFieldHelper intFieldProfile +instance ToFormField Int64 where + toFormField = requiredFieldHelper intFieldProfile +instance ToFormField (Maybe Int64) where + toFormField = optionalFieldHelper intFieldProfile -doubleField :: FieldProfile sub y Double -doubleField = FieldProfile +doubleField :: Html () -> Html () -> FormletField sub y Double +doubleField = requiredFieldHelper doubleFieldProfile + +maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double) +maybeDoubleField = optionalFieldHelper doubleFieldProfile + +doubleFieldProfile :: FieldProfile sub y Double +doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| @@ -259,13 +294,19 @@ doubleField = FieldProfile |] , fpWidget = \_name -> return () } -instance IsFormField Double where - toFormField = requiredField doubleField -instance IsFormField (Maybe Double) where - toFormField = optionalField doubleField +instance ToFormField Double where + toFormField = requiredFieldHelper doubleFieldProfile +instance ToFormField (Maybe Double) where + toFormField = optionalFieldHelper doubleFieldProfile -dayField :: FieldProfile sub y Day -dayField = FieldProfile +dayField :: Html () -> Html () -> FormletField sub y Day +dayField = requiredFieldHelper dayFieldProfile + +maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) +maybeDayField = optionalFieldHelper dayFieldProfile + +dayFieldProfile :: FieldProfile sub y Day +dayFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right . readMay , fpRender = show @@ -274,13 +315,13 @@ dayField = FieldProfile |] , fpWidget = const $ return () } -instance IsFormField Day where - toFormField = requiredField dayField -instance IsFormField (Maybe Day) where - toFormField = optionalField dayField +instance ToFormField Day where + toFormField = requiredFieldHelper dayFieldProfile +instance ToFormField (Maybe Day) where + toFormField = optionalFieldHelper dayFieldProfile -jqueryDayField :: FieldProfile sub y JqueryDay -jqueryDayField = dayField +jqueryDayFieldProfile :: FieldProfile sub y JqueryDay +jqueryDayFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") (Right . JqueryDay) @@ -297,23 +338,24 @@ jqueryDayField = dayField } -- | A newtype wrapper around 'Day', using jQuery UI date picker for the --- 'IsFormField' instance. +-- 'ToFormField' instance. newtype JqueryDay = JqueryDay { unJqueryDay :: Day } deriving PersistField -instance IsFormField JqueryDay where - toFormField = requiredField jqueryDayField -instance IsFormField (Maybe JqueryDay) where - toFormField = optionalField jqueryDayField +instance ToFormField JqueryDay where + toFormField = requiredFieldHelper jqueryDayFieldProfile +instance ToFormField (Maybe JqueryDay) where + toFormField = optionalFieldHelper jqueryDayFieldProfile parseTime :: String -> Either String TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ['0', h2, m1, m2, '0', '0'] -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper [h1, h2, m1, m2, '0', '0'] +parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper [h1, h2, m1, m2, s1, s2] + parseTimeHelper (h1, h2, m1, m2, s1, s2) parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" -parseTimeHelper :: String -> Either String TimeOfDay -parseTimeHelper (h1:h2:m1:m2:s1:s2:[]) +parseTimeHelper :: (Char, Char, Char, Char, Char, Char) + -> Either [Char] TimeOfDay +parseTimeHelper (h1, h2, m1, m2, s1, s2) | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s @@ -323,26 +365,25 @@ parseTimeHelper (h1:h2:m1:m2:s1:s2:[]) m = read [m1, m2] s = fromInteger $ read [s1, s2] -timeField :: FieldProfile sub y TimeOfDay -timeField = FieldProfile +timeField :: Html () -> Html () -> FormletField sub y TimeOfDay +timeField = requiredFieldHelper timeFieldProfile + +maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField = optionalFieldHelper timeFieldProfile + +timeFieldProfile :: FieldProfile sub y TimeOfDay +timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!:isReq:required!value=$val$ |] - , fpWidget = \name -> do - return () - {- - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] - -} + , fpWidget = const $ return () } -instance IsFormField TimeOfDay where - toFormField = requiredField timeField -instance IsFormField (Maybe TimeOfDay) where - toFormField = optionalField timeField +instance ToFormField TimeOfDay where + toFormField = requiredFieldHelper timeFieldProfile +instance ToFormField (Maybe TimeOfDay) where + toFormField = optionalFieldHelper timeFieldProfile boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do @@ -365,11 +406,17 @@ boolField label tooltip orig = GForm $ \env _ -> do _ -> Nothing } return (res, [fi], UrlEncoded) -instance IsFormField Bool where +instance ToFormField Bool where toFormField = boolField -htmlField :: FieldProfile sub y (Html ()) -htmlField = FieldProfile +htmlField :: Html () -> Html () -> FormletField sub y (Html ()) +htmlField = requiredFieldHelper htmlFieldProfile + +maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) +maybeHtmlField = optionalFieldHelper htmlFieldProfile + +htmlFieldProfile :: FieldProfile sub y (Html ()) +htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml , fpHamlet = \name val _isReq -> [$hamlet| @@ -377,16 +424,16 @@ htmlField = FieldProfile |] , fpWidget = const $ return () } -instance IsFormField (Html ()) where - toFormField = requiredField htmlField -instance IsFormField (Maybe (Html ())) where - toFormField = optionalField htmlField +instance ToFormField (Html ()) where + toFormField = requiredFieldHelper htmlFieldProfile +instance ToFormField (Maybe (Html ())) where + toFormField = optionalFieldHelper htmlFieldProfile newtype NicHtml = NicHtml { unNicHtml :: Html () } deriving PersistField -nicHtmlField :: FieldProfile sub y NicHtml -nicHtmlField = FieldProfile +nicHtmlFieldProfile :: FieldProfile sub y NicHtml +nicHtmlFieldProfile = FieldProfile { fpParse = Right . NicHtml . preEscapedString , fpRender = U.toString . renderHtml . unNicHtml , fpHamlet = \name val _isReq -> [$hamlet| @@ -396,10 +443,10 @@ nicHtmlField = FieldProfile addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] } -instance IsFormField NicHtml where - toFormField = requiredField nicHtmlField -instance IsFormField (Maybe NicHtml) where - toFormField = optionalField nicHtmlField +instance ToFormField NicHtml where + toFormField = requiredFieldHelper nicHtmlFieldProfile +instance ToFormField (Maybe NicHtml) where + toFormField = optionalFieldHelper nicHtmlFieldProfile readMay :: Read a => String -> Maybe a readMay s = case reads s of @@ -502,6 +549,28 @@ boolInput :: String -> Form sub master Bool boolInput n = GForm $ \env _ -> return (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) +dayInput :: String -> Form sub master Day +dayInput n = GForm $ \env _ -> return + (case lookup n env of + Nothing -> FormMissing + Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] + Just x -> + case readMay x of + Just y -> FormSuccess y + Nothing -> FormFailure [n ++ ": Invalid date"] + , mempty, UrlEncoded) + +maybeDayInput :: String -> Form sub master (Maybe Day) +maybeDayInput n = GForm $ \env _ -> return + (case lookup n env of + Nothing -> FormSuccess Nothing + Just "" -> FormSuccess Nothing + Just x -> + case readMay x of + Just y -> FormSuccess $ Just y + Nothing -> FormFailure [n ++ ": Invalid date"] + , mempty, UrlEncoded) + --------------------- End prebuilt inputs newFormIdent :: Monad m => StateT Int m String @@ -553,8 +622,8 @@ share2 f g a = do g' <- g a return $ f' ++ g' -mkIsForm :: [EntityDef] -> Q [Dec] -mkIsForm = mapM derive +mkToForm :: [EntityDef] -> Q [Dec] +mkToForm = mapM derive where getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z getLabel' [] = Nothing @@ -566,17 +635,15 @@ mkIsForm = mapM derive getTooltip' [] = Nothing derive :: EntityDef -> Q Dec derive t = do - let fst3 (x, _, _) = x let cols = map (getLabel &&& getTooltip) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ entityName t) string' <- [|string|] - mempty' <- [|mempty|] mfx <- [|mapFormXml|] ftt <- [|fieldsToTable|] - let go_ = go ap just' string' mempty' mfx ftt + let go_ = go ap just' string' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go_ $ zip cols $ map (const nothing) cols) @@ -587,13 +654,13 @@ mkIsForm = mapM derive $ map VarP xs]] (NormalB $ go_ $ zip cols xs') [] - return $ InstanceD [] (ConT ''IsForm + return $ InstanceD [] (ConT ''ToForm `AppT` ConT (mkName $ entityName t)) [FunD (mkName "toForm") [c1, c2]] - go ap just' string' mem mfx ftt a = - let x = foldl (ap' ap) just' $ map (go' string' mem) a + go ap just' string' mfx ftt a = + let x = foldl (ap' ap) just' $ map (go' string') a in mfx `AppE` ftt `AppE` x - go' string' mempty' ((label, tooltip), ex) = + go' string' ((label, tooltip), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip) in VarE (mkName "toFormField") `AppE` label' diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 9fd93c23..d91c8f42 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -19,7 +19,7 @@ import Text.Hamlet import Yesod.Form import Data.Monoid (mempty) -class IsForm a => Item a where +class ToForm a => Item a where itemTitle :: a -> String data Crud master item = Crud From 32ef86c295905e397b6bfad8565b45f668a3baed Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 12:59:39 +0300 Subject: [PATCH 342/624] AuthResult --- Yesod/Dispatch.hs | 11 ++++++++++- Yesod/Yesod.hs | 19 +++++++++++++++---- 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index dcf46e4a..f4115ca2 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -257,7 +257,16 @@ toWaiApp' y segments env = do case eurl of Left _ -> errorHandler NotFound Right url -> do - isAuthorized url >>= maybe (return ()) permissionDenied + ar <- isAuthorized url + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute y of + Nothing -> + permissionDenied "Authentication required" + Just url -> + redirect RedirectTemporary url + Unauthorized s -> permissionDenied s case handleSite site render url method of Nothing -> errorHandler $ BadMethod method Just h' -> h' diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3d53130f..3ec2be0a 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -21,6 +21,8 @@ module Yesod.Yesod , maybeAuthorized -- * Defaults , defaultErrorHandler + -- * Data types + , AuthResult (..) ) where import Yesod.Content @@ -36,7 +38,6 @@ import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) import Database.Persist import Web.Routes.Site (Site) -import Data.Maybe (isNothing) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -104,8 +105,18 @@ class Eq (Routes a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Routes a -> GHandler s a (Maybe String) -- FIXME use a data type that specifies whether authentication is required - isAuthorized _ = return Nothing + isAuthorized :: Routes a -> GHandler s a AuthResult + isAuthorized _ = return Authorized + + -- | The default route for authentication. + -- + -- Used in particular by 'isAuthorized', but library users can do whatever + -- they want with it. + authRoute :: a -> Maybe (Routes a) + authRoute _ = Nothing + +data AuthResult = Authorized | AuthenticationRequired | Unauthorized String + deriving (Eq, Show, Read) -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if @@ -214,4 +225,4 @@ class YesodPersist y where maybeAuthorized :: Yesod a => Routes a -> GHandler s a (Maybe (Routes a)) maybeAuthorized r = do x <- isAuthorized r - return $ if isNothing x then Just r else Nothing + return $ if x == Authorized then Just r else Nothing From 5d8ee5e7fb24acd816a77c93e1164422674d3d98 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 20:17:00 +0300 Subject: [PATCH 343/624] Renamed Routes to Route --- Yesod/Dispatch.hs | 8 +++---- Yesod/Form.hs | 2 +- Yesod/Hamlet.hs | 4 ++-- Yesod/Handler.hs | 44 +++++++++++++++++++-------------------- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Helpers/Auth.hs | 6 +++--- Yesod/Helpers/Crud.hs | 2 +- Yesod/Helpers/Sitemap.hs | 4 ++-- Yesod/Helpers/Static.hs | 4 ++-- Yesod/Widget.hs | 32 ++++++++++++++-------------- Yesod/Yesod.hs | 36 ++++++++++++++++---------------- 11 files changed, 72 insertions(+), 72 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f4115ca2..f61fb563 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -141,9 +141,9 @@ mkYesodGeneral name args clazzes isSub res = do $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th - let routesName = mkName $ name ++ "Routes" + let routesName = mkName $ name ++ "Route" let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] - let x = TySynInstD ''Routes [arg] $ ConT routesName + let x = TySynInstD ''Route [arg] $ ConT routesName parse' <- createParse th parse'' <- newName "parse" @@ -189,7 +189,7 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) (ConT ''GHandler `AppT` stype' `AppT` master `AppT` ConT ''ChooseRep) let typ = ConT ''Site `AppT` - (ConT ''Routes `AppT` stype') `AppT` + (ConT ''Route `AppT` stype') `AppT` (ArrowT `AppT` ConT ''String `AppT` inside) let gss' = gss `SigE` typ parse' <- [|parsePathSegments|] @@ -199,7 +199,7 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' return (n, SubSite - { ssType = ConT ''Routes `AppT` stype' + { ssType = ConT ''Route `AppT` stype' , ssParse = parse , ssRender = render , ssDispatch = dispatch diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 20b531f5..d0846611 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -224,7 +224,7 @@ optionalFieldHelper (FieldProfile parse render mkXml w) label tooltip orig' = data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String - , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Routes y) + , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y) , fpWidget :: String -> GWidget sub y () } diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 7aa6992b..a30b5eba 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -30,11 +30,11 @@ data PageContent url = PageContent -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: Hamlet (Routes master) -> GHandler sub master Content +hamletToContent :: Hamlet (Route master) -> GHandler sub master Content hamletToContent h = do render <- getUrlRender return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Routes master) -> GHandler sub master RepHtml +hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 6b1f4e3a..0168f20f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -22,7 +22,7 @@ --------------------------------------------------------- module Yesod.Handler ( -- * Type families - Routes + Route -- * Handler monad , Handler , GHandler @@ -30,7 +30,7 @@ module Yesod.Handler , getYesod , getYesodSub , getUrlRender - , getRoute + , getCurrentRoute , getRouteToMaster -- * Special responses -- ** Redirecting @@ -96,20 +96,20 @@ import Numeric (showIntAtBase) import Data.Char (ord, chr) -- | The type-safe URLs associated with a site argument. -type family Routes a +type family Route a data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub , handlerMaster :: master - , handlerRoute :: Maybe (Routes sub) - , handlerRender :: (Routes master -> String) - , handlerToMaster :: Routes sub -> Routes master + , handlerRoute :: Maybe (Route sub) + , handlerRender :: (Route master -> String) + , handlerToMaster :: Route sub -> Route master } -handlerSubData :: (Routes sub -> Routes master) +handlerSubData :: (Route sub -> Route master) -> (master -> sub) - -> Routes sub + -> Route sub -> HandlerData oldSub master -> HandlerData sub master handlerSubData tm ts route hd = hd @@ -120,9 +120,9 @@ handlerSubData tm ts route hd = hd -- | Used internally for promoting subsite handler functions to master site -- handler functions. Should not be needed by users. -toMasterHandler :: (Routes sub -> Routes master) +toMasterHandler :: (Route sub -> Route master) -> (master -> sub) - -> Routes sub + -> Route sub -> GHandler sub master a -> Handler master a toMasterHandler tm ts route (GHandler h) = @@ -181,17 +181,17 @@ getYesod :: GHandler sub master master getYesod = handlerMaster <$> GHandler ask -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Routes master -> String) +getUrlRender :: GHandler sub master (Route master -> String) getUrlRender = handlerRender <$> GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. -getRoute :: GHandler sub master (Maybe (Routes sub)) -getRoute = handlerRoute <$> GHandler ask +getCurrentRoute :: GHandler sub master (Maybe (Route sub)) +getCurrentRoute = handlerRoute <$> GHandler ask -- | Get the function to promote a route for a subsite to a route for the -- master site. -getRouteToMaster :: GHandler sub master (Routes sub -> Routes master) +getRouteToMaster :: GHandler sub master (Route sub -> Route master) getRouteToMaster = handlerToMaster <$> GHandler ask modifySession :: [(String, String)] -> (String, Maybe String) @@ -208,9 +208,9 @@ dropKeys k = filter $ \(x, _) -> x /= k -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c - -> (Routes master -> String) - -> Maybe (Routes sub) - -> (Routes sub -> Routes master) + -> (Route master -> String) + -> Maybe (Route sub) + -> (Route sub -> Route master) -> master -> (master -> sub) -> YesodApp @@ -260,11 +260,11 @@ safeEh er = YesodApp $ \_ _ _ -> do return (W.Status500, [], typePlain, toContent "Internal Server Error", []) -- | Redirect to the given route. -redirect :: RedirectType -> Routes master -> GHandler sub master a +redirect :: RedirectType -> Route master -> GHandler sub master a redirect rt url = redirectParams rt url [] -- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Routes master -> [(String, String)] +redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRender @@ -302,7 +302,7 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: Routes master -> GHandler sub master () +setUltDest :: Route master -> GHandler sub master () setUltDest dest = do render <- getUrlRender setUltDestString $ render dest @@ -317,7 +317,7 @@ setUltDestString = setSession ultDestKey -- nothing. setUltDest' :: GHandler sub master () setUltDest' = do - route <- getRoute + route <- getCurrentRoute tm <- getRouteToMaster maybe (return ()) setUltDest $ tm <$> route @@ -326,7 +326,7 @@ setUltDest' = do -- -- The ultimate destination is set with 'setUltDest'. redirectUltDest :: RedirectType - -> Routes master -- ^ default destination if nothing in session + -> Route master -- ^ default destination if nothing in session -> GHandler sub master () redirectUltDest rt def = do mdest <- lookupSession ultDestKey diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 23e99e34..bcb25937 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -29,7 +29,7 @@ newtype RepAtom = RepAtom Content instance HasReps RepAtom where chooseRep (RepAtom c) _ = return (typeAtom, c) -atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom +atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f5e30d3e..80b2b84a 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -22,7 +22,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..) - , AuthRoutes (..) + , AuthRoute (..) -- * Settings , YesodAuth (..) , Creds (..) @@ -55,10 +55,10 @@ import Data.Object class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other -- destination exists. - defaultDest :: master -> Routes master + defaultDest :: master -> Route master -- | Default page to redirect user to for logging in. - defaultLoginRoute :: master -> Routes master + defaultLoginRoute :: master -> Route master -- | Callback for a successful login. -- diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index d91c8f42..9b25cdde 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -6,7 +6,7 @@ module Yesod.Helpers.Crud ( Item (..) , Crud (..) - , CrudRoutes (..) + , CrudRoute (..) , defaultCrud ) where diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 82c12eba..5b009553 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -61,11 +61,11 @@ template urls = [$hamlet| %priority $show.priority.url$ |] -sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml +sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml sitemap = fmap RepXml . hamletToContent . template -- | A basic robots file which just lists the "Sitemap: " line. -robots :: Routes sub -- ^ sitemap url +robots :: Route sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do tm <- getRouteToMaster diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index f62d4bac..f498dfbd 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,7 +27,7 @@ module Yesod.Helpers.Static ( -- * Subsite Static (..) - , StaticRoutes (..) + , StaticRoute (..) -- * Lookup files in filesystem , fileLookupDir , staticFiles @@ -127,7 +127,7 @@ staticFiles fp = do f' <- lift f let sr = ConE $ mkName "StaticRoute" return - [ SigD name $ ConT ''Routes `AppT` ConT ''Static + [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name [ Clause [] (NormalB $ sr `AppE` f') [] ] diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 05c964b2..a287c9f5 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -30,7 +30,7 @@ import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) -import Yesod.Handler (Routes, GHandler) +import Yesod.Handler (Route, GHandler) import Yesod.Yesod (Yesod, defaultLayout) import Yesod.Content (RepHtml (..)) import Control.Applicative (Applicative) @@ -66,12 +66,12 @@ newtype Body url = Body (Hamlet url) deriving Monoid newtype GWidget sub master a = GWidget ( - WriterT (Body (Routes master)) ( + WriterT (Body (Route master)) ( WriterT (Last Title) ( - WriterT (UniqueList (Script (Routes master))) ( - WriterT (UniqueList (Stylesheet (Routes master))) ( - WriterT (Style (Routes master)) ( - WriterT (Head (Routes master)) ( + WriterT (UniqueList (Script (Route master))) ( + WriterT (UniqueList (Stylesheet (Route master))) ( + WriterT (Style (Route master)) ( + WriterT (Head (Route master)) ( StateT Int ( GHandler sub master ))))))) a) @@ -84,10 +84,10 @@ type Widget y = GWidget y y setTitle :: Html () -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title -addHead :: Hamlet (Routes master) -> GWidget sub master () +addHead :: Hamlet (Route master) -> GWidget sub master () addHead = GWidget . lift . lift . lift . lift . lift . tell . Head -addBody :: Hamlet (Routes master) -> GWidget sub master () +addBody :: Hamlet (Route master) -> GWidget sub master () addBody = GWidget . tell . Body newIdent :: GWidget sub master String @@ -97,30 +97,30 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ do put i' return $ "w" ++ show i' -addStyle :: Hamlet (Routes master) -> GWidget sub master () +addStyle :: Hamlet (Route master) -> GWidget sub master () addStyle = GWidget . lift . lift . lift . lift . tell . Style -addStylesheet :: Routes master -> GWidget sub master () +addStylesheet :: Route master -> GWidget sub master () addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local addStylesheetRemote :: String -> GWidget sub master () addStylesheetRemote = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote -addScript :: Routes master -> GWidget sub master () +addScript :: Route master -> GWidget sub master () addScript = GWidget . lift . lift . tell . toUnique . Script . Local addScriptRemote :: String -> GWidget sub master () addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -applyLayoutW :: (Eq (Routes m), Yesod m) +applyLayoutW :: (Eq (Route m), Yesod m) => GWidget sub m () -> GHandler sub m RepHtml applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout -widgetToPageContent :: Eq (Routes master) +widgetToPageContent :: Eq (Route master) => GWidget sub master () - -> GHandler sub master (PageContent (Routes master)) + -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do w' <- flip evalStateT 0 $ runWriterT $ runWriterT $ runWriterT $ runWriterT @@ -148,14 +148,14 @@ $forall stylesheets s return $ PageContent title head'' body wrapWidget :: GWidget s m a - -> (Hamlet (Routes m) -> Hamlet (Routes m)) + -> (Hamlet (Route m) -> Hamlet (Route m)) -> GWidget s m a wrapWidget (GWidget w) wrap = GWidget $ mapWriterT (fmap go) w where go (a, Body h) = (a, Body $ wrap h) -extractBody :: GWidget s m () -> GWidget s m (Hamlet (Routes m)) +extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m)) extractBody (GWidget w) = GWidget $ mapWriterT (fmap go) w where diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3ec2be0a..5fbfb233 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -41,18 +41,18 @@ import Web.Routes.Site (Site) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. -class Eq (Routes y) => YesodSite y where - getSite :: Site (Routes y) (Method -> Maybe (Handler y ChooseRep)) +class Eq (Route y) => YesodSite y where + getSite :: Site (Route y) (Method -> Maybe (Handler y ChooseRep)) type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need -- to deal with it directly, as the mkYesodSub creates instances appropriately. -class Eq (Routes s) => YesodSubSite s y where - getSubSite :: Site (Routes s) (Method -> Maybe (GHandler s y ChooseRep)) +class Eq (Route s) => YesodSubSite s y where + getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. -class Eq (Routes a) => Yesod a where +class Eq (Route a) => Yesod a where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- @@ -79,7 +79,7 @@ class Eq (Routes a) => Yesod a where errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: PageContent (Routes a) -> GHandler sub a Content + defaultLayout :: PageContent (Route a) -> GHandler sub a Content defaultLayout p = hamletToContent [$hamlet| !!! %html @@ -97,7 +97,7 @@ class Eq (Routes a) => Yesod a where -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Routes a -> Maybe String + urlRenderOverride :: a -> Route a -> Maybe String urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -105,14 +105,14 @@ class Eq (Routes a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Routes a -> GHandler s a AuthResult + isAuthorized :: Route a -> GHandler s a AuthResult isAuthorized _ = return Authorized -- | The default route for authentication. -- -- Used in particular by 'isAuthorized', but library users can do whatever -- they want with it. - authRoute :: a -> Maybe (Routes a) + authRoute :: a -> Maybe (Route a) authRoute _ = Nothing data AuthResult = Authorized | AuthenticationRequired | Unauthorized String @@ -124,13 +124,13 @@ data AuthResult = Authorized | AuthenticationRequired | Unauthorized String class YesodBreadcrumbs y where -- | Returns the title and the parent resource, if available. If you return -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Routes y -> GHandler sub y (String, Maybe (Routes y)) + breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Routes y, String)]) +breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) breadcrumbs = do - x' <- getRoute + x' <- getCurrentRoute tm <- getRouteToMaster let x = fmap tm x' case x of @@ -148,8 +148,8 @@ breadcrumbs = do -- | Apply the default layout ('defaultLayout') to the given title and body. applyLayout :: Yesod master => String -- ^ title - -> Hamlet (Routes master) -- ^ head - -> Hamlet (Routes master) -- ^ body + -> Hamlet (Route master) -- ^ head + -> Hamlet (Route master) -- ^ body -> GHandler sub master RepHtml applyLayout t h b = RepHtml `fmap` defaultLayout PageContent @@ -162,8 +162,8 @@ applyLayout t h b = -- the default layout for the HTML output ('defaultLayout'). applyLayoutJson :: Yesod master => String -- ^ title - -> Hamlet (Routes master) -- ^ head - -> Hamlet (Routes master) -- ^ body + -> Hamlet (Route master) -- ^ head + -> Hamlet (Route master) -- ^ body -> Json -> GHandler sub master RepHtmlJson applyLayoutJson t h html json = do @@ -177,7 +177,7 @@ applyLayoutJson t h html json = do applyLayout' :: Yesod master => String -- ^ title - -> Hamlet (Routes master) -- ^ body + -> Hamlet (Route master) -- ^ body -> GHandler sub master ChooseRep applyLayout' s = fmap chooseRep . applyLayout s mempty @@ -222,7 +222,7 @@ class YesodPersist y where -- -- Built on top of 'isAuthorized'. This is useful for building page that only -- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a => Routes a -> GHandler s a (Maybe (Routes a)) +maybeAuthorized :: Yesod a => Route a -> GHandler s a (Maybe (Route a)) maybeAuthorized r = do x <- isAuthorized r return $ if x == Authorized then Just r else Nothing From 5354c03a2ce4423c0e3aef73b82dac63681e779c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 6 Jul 2010 22:36:20 +0300 Subject: [PATCH 344/624] Autocomplete form widget --- Yesod/Form.hs | 19 +++++++++++++++++++ Yesod/Widget.hs | 1 + hellowidget.hs | 31 ++++++++++++++++++++++--------- 3 files changed, 42 insertions(+), 9 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index d0846611..89d1cf9f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -38,6 +38,7 @@ module Yesod.Form , stringFieldProfile , intFieldProfile , dayFieldProfile + , jqueryDayFieldProfile , timeFieldProfile , htmlFieldProfile -- * Pre-built fields @@ -56,6 +57,7 @@ module Yesod.Form , selectField , maybeSelectField , boolField + , jqueryAutocompleteField -- * Pre-built inputs , stringInput , maybeStringInput @@ -675,3 +677,20 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs + +jqueryAutocompleteField src = requiredFieldHelper + $ jqueryAutocompleteFieldProfile src + +jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String +jqueryAutocompleteFieldProfile src = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \name val isReq -> [$hamlet| +%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + addHead [$hamlet|%script $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});|] + } diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index a287c9f5..e1cfea6d 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -25,6 +25,7 @@ module Yesod.Widget , extractBody ) where +-- FIXME add support for script contents import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer diff --git a/hellowidget.hs b/hellowidget.hs index 682ae152..5ea9aa77 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -9,6 +9,7 @@ mkYesod "HW" [$parseRoutes| / RootR GET /form FormR /static StaticR Static hwStatic +/autocomplete AutoCompleteR GET |] instance Yesod HW where approot _ = "" wrapper h = [$hamlet| @@ -33,18 +34,21 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do |] addHead [$hamlet|%meta!keywords=haskell|] +-- FIXME add coolness to day and html below handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,,,) - <$> requiredField stringField (string "My Field") (string "Some tooltip info") Nothing - <*> requiredField stringField (string "Another field") (string "") (Just "some default text") - <*> requiredField intField (string "A number field") (string "some nums") (Just 5) - <*> requiredField dayField (string "A day field") (string "") Nothing - <*> requiredField timeField (string "A time field") (string "") Nothing + (res, form, enctype) <- runFormPost $ (,,,,,,,) + <$> stringField (string "My Field") (string "Some tooltip info") Nothing + <*> stringField (string "Another field") (string "") (Just "some default text") + <*> intField (string "A number field") (string "some nums") (Just 5) + <*> dayField (string "A day field") (string "") Nothing + <*> timeField (string "A time field") (string "") Nothing <*> boolField (string "A checkbox") (string "") (Just False) - <*> requiredField htmlField (string "HTML") (string "") + <*> jqueryAutocompleteField AutoCompleteR + (string "Autocomplete") (string "Try it!") Nothing + <*> htmlField (string "HTML") (string "") (Just $ string "You can put rich text here") let mhtml = case res of - FormSuccess (_, _, _, _, _, _, x) -> Just x + FormSuccess (_, _, _, _, _, _, _, x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] @@ -56,8 +60,17 @@ handleFormR = do %td!colspan=2 %input!type=submit $maybe mhtml html - $<html>$ + $html$ |] setTitle $ string "Form" main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000 + +getAutoCompleteR :: Handler HW RepJson +getAutoCompleteR = do + term <- runFormGet' $ stringInput "term" + jsonToRepJson $ jsonList + [ jsonScalar $ string $ term ++ "foo" + , jsonScalar $ string $ term ++ "bar" + , jsonScalar $ string $ term ++ "baz" + ] From 9fde607bd842bb9e45d83c9d1bd063b4ebc7973d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 7 Jul 2010 06:21:32 +0300 Subject: [PATCH 345/624] Fancy form widgets --- Yesod/Form.hs | 13 +++++++++++++ hellowidget.hs | 8 ++++---- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 89d1cf9f..b6d38f19 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -50,14 +50,19 @@ module Yesod.Form , maybeDoubleField , dayField , maybeDayField + , jqueryDayField + , maybeJqueryDayField , timeField , maybeTimeField , htmlField , maybeHtmlField + , nicHtmlField + , maybeNicHtmlField , selectField , maybeSelectField , boolField , jqueryAutocompleteField + , maybeJqueryAutocompleteField -- * Pre-built inputs , stringInput , maybeStringInput @@ -322,6 +327,9 @@ instance ToFormField Day where instance ToFormField (Maybe Day) where toFormField = optionalFieldHelper dayFieldProfile +jqueryDayField = requiredFieldHelper jqueryDayFieldProfile +maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile + jqueryDayFieldProfile :: FieldProfile sub y JqueryDay jqueryDayFieldProfile = FieldProfile { fpParse = maybe @@ -434,6 +442,9 @@ instance ToFormField (Maybe (Html ())) where newtype NicHtml = NicHtml { unNicHtml :: Html () } deriving PersistField +nicHtmlField = requiredFieldHelper nicHtmlFieldProfile +maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile + nicHtmlFieldProfile :: FieldProfile sub y NicHtml nicHtmlFieldProfile = FieldProfile { fpParse = Right . NicHtml . preEscapedString @@ -680,6 +691,8 @@ toLabel (x:rest) = toUpper x : go rest jqueryAutocompleteField src = requiredFieldHelper $ jqueryAutocompleteFieldProfile src +maybeJqueryAutocompleteField src = optionalFieldHelper + $ jqueryAutocompleteFieldProfile src jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile src = FieldProfile diff --git a/hellowidget.hs b/hellowidget.hs index 5ea9aa77..a223effa 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -40,15 +40,15 @@ handleFormR = do <$> stringField (string "My Field") (string "Some tooltip info") Nothing <*> stringField (string "Another field") (string "") (Just "some default text") <*> intField (string "A number field") (string "some nums") (Just 5) - <*> dayField (string "A day field") (string "") Nothing + <*> jqueryDayField (string "A day field") (string "") Nothing <*> timeField (string "A time field") (string "") Nothing <*> boolField (string "A checkbox") (string "") (Just False) <*> jqueryAutocompleteField AutoCompleteR (string "Autocomplete") (string "Try it!") Nothing - <*> htmlField (string "HTML") (string "") - (Just $ string "You can put rich text here") + <*> nicHtmlField (string "HTML") (string "") + (Just $ NicHtml $ string "You can put rich text here") let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, x) -> Just x + FormSuccess (_, _, _, _, _, _, _, NicHtml x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] From 2a71c7ab9b3eef0fafebe6fd860a708bbc25329f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 7 Jul 2010 07:12:04 +0300 Subject: [PATCH 346/624] Unified fields and inputs --- Yesod/Form.hs | 255 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 170 insertions(+), 85 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index b6d38f19..be59ab27 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -13,6 +13,7 @@ module Yesod.Form , Formlet , FormField , FormletField + , FormInput , FormResult (..) , Enctype (..) , FieldInfo (..) @@ -33,6 +34,8 @@ module Yesod.Form , mapFormXml , newFormIdent , fieldsToTable + , fieldsToPlain + , fieldsToInput -- * Field profiles , FieldProfile (..) , stringFieldProfile @@ -124,6 +127,7 @@ type Form sub y = GForm sub y (GWidget sub y ()) type Formlet sub y a = Maybe a -> Form sub y a type FormField sub y = GForm sub y [FieldInfo sub y] type FormletField sub y a = Maybe a -> FormField sub y a +type FormInput sub y = GForm sub y [GWidget sub y ()] mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a mapFormXml f (GForm g) = GForm $ \e fe -> do @@ -154,6 +158,12 @@ instance Monoid xml => Applicative (GForm sub url xml) where (g1, g2, g3) <- g env fe return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) +fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y () +fieldsToPlain = mapM_ fiInput + +fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] +fieldsToInput = map fiInput + fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () fieldsToTable = mapM_ go where @@ -174,11 +184,10 @@ class ToForm a where class ToFormField a where toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a -requiredFieldHelper :: FieldProfile sub y a - -> Html () -> Html () -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) label tooltip orig = +requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig = GForm $ \env _ -> do - name <- newFormIdent + name <- maybe newFormIdent return name' let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -200,13 +209,12 @@ requiredFieldHelper (FieldProfile parse render mkXml w) label tooltip orig = } return (res, [fi], UrlEncoded) -optionalFieldHelper :: FieldProfile sub y a - -> Html () -> Html () -> Maybe (Maybe a) - -> FormField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) label tooltip orig' = +optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a) + -> FormField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' = GForm $ \env _ -> do let orig = join orig' - name <- newFormIdent + name <- maybe newFormIdent return name' let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -233,15 +241,24 @@ data FieldProfile sub y a = FieldProfile , fpRender :: a -> String , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y) , fpWidget :: String -> GWidget sub y () + , fpName :: Maybe String + , fpLabel :: Html () + , fpTooltip :: Html () } --------------------- Begin prebuilt forms stringField :: Html () -> Html () -> FormletField sub y String -stringField = requiredFieldHelper stringFieldProfile +stringField label tooltip = requiredFieldHelper stringFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String) -maybeStringField = optionalFieldHelper stringFieldProfile +maybeStringField label tooltip = optionalFieldHelper stringFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile @@ -251,17 +268,27 @@ stringFieldProfile = FieldProfile %input#$name$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField String where - toFormField = requiredFieldHelper stringFieldProfile + toFormField = stringField instance ToFormField (Maybe String) where - toFormField = optionalFieldHelper stringFieldProfile + toFormField = maybeStringField -intField :: Html () -> Html () -> FormletField sub y Int -intField = requiredFieldHelper intFieldProfile +intField :: Integral i => Html () -> Html () -> FormletField sub y i +intField l t = requiredFieldHelper intFieldProfile + { fpLabel = l + , fpTooltip = t + } -maybeIntField :: Html () -> Html () -> FormletField sub y (Maybe Int) -maybeIntField = optionalFieldHelper intFieldProfile +maybeIntField :: Integral i => + Html () -> Html () -> FormletField sub y (Maybe i) +maybeIntField l t = optionalFieldHelper intFieldProfile + { fpLabel = l + , fpTooltip = t + } intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile @@ -271,6 +298,9 @@ intFieldProfile = FieldProfile %input#$name$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } where showI x = show (fromIntegral x :: Integer) @@ -278,19 +308,25 @@ intFieldProfile = FieldProfile (x, _):_ -> Just $ fromInteger x [] -> Nothing instance ToFormField Int where - toFormField = requiredFieldHelper intFieldProfile + toFormField = intField instance ToFormField (Maybe Int) where - toFormField = optionalFieldHelper intFieldProfile + toFormField = maybeIntField instance ToFormField Int64 where - toFormField = requiredFieldHelper intFieldProfile + toFormField = intField instance ToFormField (Maybe Int64) where - toFormField = optionalFieldHelper intFieldProfile + toFormField = maybeIntField doubleField :: Html () -> Html () -> FormletField sub y Double -doubleField = requiredFieldHelper doubleFieldProfile +doubleField l t = requiredFieldHelper doubleFieldProfile + { fpLabel = l + , fpTooltip = t + } maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double) -maybeDoubleField = optionalFieldHelper doubleFieldProfile +maybeDoubleField l t = optionalFieldHelper doubleFieldProfile + { fpLabel = l + , fpTooltip = t + } doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile @@ -300,17 +336,26 @@ doubleFieldProfile = FieldProfile %input#$name$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField Double where - toFormField = requiredFieldHelper doubleFieldProfile + toFormField = doubleField instance ToFormField (Maybe Double) where - toFormField = optionalFieldHelper doubleFieldProfile + toFormField = maybeDoubleField dayField :: Html () -> Html () -> FormletField sub y Day -dayField = requiredFieldHelper dayFieldProfile +dayField l t = requiredFieldHelper dayFieldProfile + { fpLabel = l + , fpTooltip = t + } maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) -maybeDayField = optionalFieldHelper dayFieldProfile +maybeDayField l t = optionalFieldHelper dayFieldProfile + { fpLabel = l + , fpTooltip = t + } dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile @@ -321,14 +366,23 @@ dayFieldProfile = FieldProfile %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = const $ return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField Day where - toFormField = requiredFieldHelper dayFieldProfile + toFormField = dayField instance ToFormField (Maybe Day) where - toFormField = optionalFieldHelper dayFieldProfile + toFormField = maybeDayField -jqueryDayField = requiredFieldHelper jqueryDayFieldProfile -maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile +jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile + { fpLabel = l + , fpTooltip = t + } +maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile + { fpLabel = l + , fpTooltip = t + } jqueryDayFieldProfile :: FieldProfile sub y JqueryDay jqueryDayFieldProfile = FieldProfile @@ -345,6 +399,9 @@ jqueryDayFieldProfile = FieldProfile addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } -- | A newtype wrapper around 'Day', using jQuery UI date picker for the @@ -352,9 +409,9 @@ jqueryDayFieldProfile = FieldProfile newtype JqueryDay = JqueryDay { unJqueryDay :: Day } deriving PersistField instance ToFormField JqueryDay where - toFormField = requiredFieldHelper jqueryDayFieldProfile + toFormField = jqueryDayField instance ToFormField (Maybe JqueryDay) where - toFormField = optionalFieldHelper jqueryDayFieldProfile + toFormField = maybeJqueryDayField parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') @@ -376,10 +433,16 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2) s = fromInteger $ read [s1, s2] timeField :: Html () -> Html () -> FormletField sub y TimeOfDay -timeField = requiredFieldHelper timeFieldProfile +timeField label tooltip = requiredFieldHelper timeFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay) -maybeTimeField = optionalFieldHelper timeFieldProfile +maybeTimeField label tooltip = optionalFieldHelper timeFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile @@ -389,11 +452,14 @@ timeFieldProfile = FieldProfile %input#$name$!name=$name$!:isReq:required!value=$val$ |] , fpWidget = const $ return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField TimeOfDay where - toFormField = requiredFieldHelper timeFieldProfile + toFormField = timeField instance ToFormField (Maybe TimeOfDay) where - toFormField = optionalFieldHelper timeFieldProfile + toFormField = maybeTimeField boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool boolField label tooltip orig = GForm $ \env _ -> do @@ -420,10 +486,16 @@ instance ToFormField Bool where toFormField = boolField htmlField :: Html () -> Html () -> FormletField sub y (Html ()) -htmlField = requiredFieldHelper htmlFieldProfile +htmlField label tooltip = requiredFieldHelper htmlFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } -maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) -maybeHtmlField = optionalFieldHelper htmlFieldProfile +maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) -- FIXME make label and tooltip Strings instead +maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } htmlFieldProfile :: FieldProfile sub y (Html ()) htmlFieldProfile = FieldProfile @@ -433,17 +505,26 @@ htmlFieldProfile = FieldProfile %textarea.html#$name$!name=$name$ $val$ |] , fpWidget = const $ return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField (Html ()) where - toFormField = requiredFieldHelper htmlFieldProfile + toFormField = htmlField instance ToFormField (Maybe (Html ())) where - toFormField = optionalFieldHelper htmlFieldProfile + toFormField = maybeHtmlField newtype NicHtml = NicHtml { unNicHtml :: Html () } deriving PersistField -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile +nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } +maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } nicHtmlFieldProfile :: FieldProfile sub y NicHtml nicHtmlFieldProfile = FieldProfile @@ -455,11 +536,14 @@ nicHtmlFieldProfile = FieldProfile , fpWidget = \name -> do addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } instance ToFormField NicHtml where - toFormField = requiredFieldHelper nicHtmlFieldProfile + toFormField = nicHtmlField instance ToFormField (Maybe NicHtml) where - toFormField = optionalFieldHelper nicHtmlFieldProfile + toFormField = maybeNicHtmlField readMay :: Read a => String -> Maybe a readMay s = case reads s of @@ -544,45 +628,37 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do --------------------- Begin prebuilt inputs -stringInput :: String -> Form sub master String -stringInput n = GForm $ \env _ -> return - (case lookup n env of - Nothing -> FormMissing - Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] - Just x -> FormSuccess x, mempty, UrlEncoded) +stringInput :: String -> FormInput sub master String +stringInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper stringFieldProfile + { fpName = Just n + } Nothing -maybeStringInput :: String -> Form sub master (Maybe String) -maybeStringInput n = GForm $ \env _ -> return - (case lookup n env of - Nothing -> FormSuccess Nothing - Just "" -> FormSuccess Nothing - Just x -> FormSuccess $ Just x, mempty, UrlEncoded) +maybeStringInput :: String -> FormInput sub master (Maybe String) +maybeStringInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper stringFieldProfile + { fpName = Just n + } Nothing -boolInput :: String -> Form sub master Bool +boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ \env _ -> return - (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) + (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) -- FIXME -dayInput :: String -> Form sub master Day -dayInput n = GForm $ \env _ -> return - (case lookup n env of - Nothing -> FormMissing - Just "" -> FormFailure [n ++ ": You must provide a non-empty string"] - Just x -> - case readMay x of - Just y -> FormSuccess y - Nothing -> FormFailure [n ++ ": Invalid date"] - , mempty, UrlEncoded) +dayInput :: String -> FormInput sub master Day +dayInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper dayFieldProfile + { fpName = Just n + } Nothing -maybeDayInput :: String -> Form sub master (Maybe Day) -maybeDayInput n = GForm $ \env _ -> return - (case lookup n env of - Nothing -> FormSuccess Nothing - Just "" -> FormSuccess Nothing - Just x -> - case readMay x of - Just y -> FormSuccess $ Just y - Nothing -> FormFailure [n ++ ": Invalid date"] - , mempty, UrlEncoded) +maybeDayInput :: String -> FormInput sub master (Maybe Day) +maybeDayInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper dayFieldProfile + { fpName = Just n + } Nothing --------------------- End prebuilt inputs @@ -614,7 +690,7 @@ runFormPost' = helper <=< runFormPost -- | Run a form against GET parameters, disregarding the resulting HTML and -- returning an error response on invalid input. -runFormGet' :: Form sub y a -> GHandler sub y a +runFormGet' :: GForm sub y xml a -> GHandler sub y a runFormGet' = helper <=< runFormGet helper :: (FormResult a, b, c) -> GHandler sub y a @@ -689,10 +765,16 @@ toLabel (x:rest) = toUpper x : go rest | isUpper c = ' ' : c : go cs | otherwise = c : go cs -jqueryAutocompleteField src = requiredFieldHelper - $ jqueryAutocompleteFieldProfile src -maybeJqueryAutocompleteField src = optionalFieldHelper - $ jqueryAutocompleteFieldProfile src +jqueryAutocompleteField src l t = + requiredFieldHelper $ (jqueryAutocompleteFieldProfile src) + { fpLabel = l + , fpTooltip = t + } +maybeJqueryAutocompleteField src l t = + optionalFieldHelper $ (jqueryAutocompleteFieldProfile src) + { fpLabel = l + , fpTooltip = t + } jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile src = FieldProfile @@ -706,4 +788,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" addHead [$hamlet|%script $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});|] + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty } From d6509266f47283ac8bce7ce099d8d801e1d88271 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 7 Jul 2010 17:20:24 +0300 Subject: [PATCH 347/624] Fix optionalFieldHelper --- Yesod/Form.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index be59ab27..4d658344 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -217,7 +217,7 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig name <- maybe newFormIdent return name' let (res, val) = if null env - then (FormMissing, maybe "" render orig) + then (FormSuccess Nothing, maybe "" render orig) else case lookup name env of Nothing -> (FormSuccess Nothing, "") Just "" -> (FormSuccess Nothing, "") From 43494c05578e72c9ec2df67473ddc43f65efbcbe Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 7 Jul 2010 22:55:17 +0300 Subject: [PATCH 348/624] Setting ultimate dest with the isAuthorized function --- Yesod/Dispatch.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f61fb563..3d08ccd0 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -264,7 +264,8 @@ toWaiApp' y segments env = do case authRoute y of Nothing -> permissionDenied "Authentication required" - Just url -> + Just url -> do + setUltDest' redirect RedirectTemporary url Unauthorized s -> permissionDenied s case handleSite site render url method of From 5cdd7c82d7362ffe136addb3ec390fa2f7769062 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 9 Jul 2010 15:16:09 +0300 Subject: [PATCH 349/624] wai-extra bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 8ee7494d..ad7cae56 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, wai >= 0.1.0 && < 0.2, - wai-extra >= 0.1.3 && < 0.2, + wai-extra >= 0.1.3.1 && < 0.2, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, From a14f232f180a1aa68eb90133cd151e2ef34a8cbc Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 9 Jul 2010 15:21:46 +0300 Subject: [PATCH 350/624] New sig for basicHandler --- Yesod/Dispatch.hs | 25 +++++++++++++++++++++---- hellowidget.hs | 2 +- helloworld.hs | 2 +- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 3d08ccd0..9363c5c4 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -16,6 +16,7 @@ module Yesod.Dispatch -- * Convert to WAI , toWaiApp , basicHandler + , basicHandler' -- * Utilities , fullRender #if TEST @@ -307,13 +308,29 @@ httpAccept = map B.unpack -- | 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 +basicHandler :: (Yesod y, YesodSite y) + => Int -- ^ port number + -> y + -> IO () +basicHandler port y = basicHandler' port (Just "localhost") y + + +-- | Same as 'basicHandler', but allows you to specify the hostname to display +-- to the user. If 'Nothing' is provided, then no output is produced. +basicHandler' :: (Yesod y, YesodSite y) + => Int -- ^ port number + -> Maybe String -- ^ host name, 'Nothing' to show nothing + -> y + -> IO () +basicHandler' port mhost y = do + app <- toWaiApp y vars <- getEnvironment case lookup "PATH_INFO" vars of Nothing -> do - putStrLn $ "http://localhost:" ++ show port ++ "/" + case mhost of + Nothing -> return () + Just h -> putStrLn $ concat + ["http://", h, ":", show port, "/"] SS.run port app Just _ -> CGI.run app diff --git a/hellowidget.hs b/hellowidget.hs index a223effa..11a330a0 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -64,7 +64,7 @@ handleFormR = do |] setTitle $ string "Form" -main = toWaiApp (HW $ fileLookupDir "static" typeByExt) >>= basicHandler 3000 +main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt getAutoCompleteR :: Handler HW RepJson getAutoCompleteR = do diff --git a/helloworld.hs b/helloworld.hs index 2e26b7a8..2a3f8723 100644 --- a/helloworld.hs +++ b/helloworld.hs @@ -4,4 +4,4 @@ data HelloWorld = HelloWorld mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] instance Yesod HelloWorld where approot _ = "" getHome = return $ RepPlain $ toContent "Hello World!" -main = toWaiApp HelloWorld >>= basicHandler 3000 +main = basicHandler 3000 HelloWorld From 7d273861e229133ca657d5809c02cb928538155e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 10 Jul 2010 21:44:10 +0300 Subject: [PATCH 351/624] Better doc for setSession --- Yesod/Handler.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0168f20f..eb17e74f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -338,6 +338,9 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- +-- The message set here will not be visible within the current request; +-- instead, it will only appear in the next request. +-- -- See 'getMessage'. setMessage :: Html () -> GHandler sub master () setMessage = setSession msgKey . L.toString . renderHtml From 2c0434c43129c2e929c9bffdae6f04e20682a56e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 10 Jul 2010 21:48:16 +0300 Subject: [PATCH 352/624] Added addJavaScript for widgets --- Yesod/Widget.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index e1cfea6d..d88de5fd 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -20,6 +20,7 @@ module Yesod.Widget , addScriptRemote , addHead , addBody + , addJavaScript -- * Manipulating , wrapWidget , extractBody @@ -65,6 +66,8 @@ newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid +newtype JavaScript url = JavaScript (Hamlet url) + deriving Monoid newtype GWidget sub master a = GWidget ( WriterT (Body (Route master)) ( @@ -72,10 +75,11 @@ newtype GWidget sub master a = GWidget ( WriterT (UniqueList (Script (Route master))) ( WriterT (UniqueList (Stylesheet (Route master))) ( WriterT (Style (Route master)) ( + WriterT (JavaScript (Route master)) ( WriterT (Head (Route master)) ( StateT Int ( GHandler sub master - ))))))) a) + )))))))) a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) instance Monoid (GWidget sub master ()) where mempty = return () @@ -86,13 +90,13 @@ setTitle :: Html () -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title addHead :: Hamlet (Route master) -> GWidget sub master () -addHead = GWidget . lift . lift . lift . lift . lift . tell . Head +addHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head addBody :: Hamlet (Route master) -> GWidget sub master () addBody = GWidget . tell . Body newIdent :: GWidget sub master String -newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ do +newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do i <- get let i' = i + 1 put i' @@ -115,6 +119,9 @@ addScriptRemote :: String -> GWidget sub master () addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote +addJavaScript :: Hamlet (Route master) -> GWidget sub master () +addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . JavaScript + applyLayoutW :: (Eq (Route m), Yesod m) => GWidget sub m () -> GHandler sub m RepHtml applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout @@ -125,13 +132,14 @@ widgetToPageContent :: Eq (Route master) widgetToPageContent (GWidget w) = do w' <- flip evalStateT 0 $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT w - let (((((((), + $ runWriterT $ runWriterT $ runWriterT w + let ((((((((), Body body), Last mTitle), scripts'), stylesheets'), Style style), + JavaScript jscript), Head head') = w' let title = maybe mempty unTitle mTitle let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' @@ -142,8 +150,8 @@ $forall scripts s %script!src=^s^ $forall stylesheets s %link!rel=stylesheet!href=^s^ -%style - ^style^ +%style ^style^ +%script ^jscript^ ^head'^ |] return $ PageContent title head'' body From 0f1378a013487c996fe3b0c64a4e6baf04756c60 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 10 Jul 2010 21:56:35 +0300 Subject: [PATCH 353/624] Widgets only create script and style tags when necessary --- Yesod/Form.hs | 6 +++--- Yesod/Widget.hs | 15 +++++++++------ hellowidget.hs | 2 +- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4d658344..1add7800 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -398,7 +398,7 @@ jqueryDayFieldProfile = FieldProfile addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addHead [$hamlet|%script $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})})|] + addJavaScript [$hamlet|$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});|] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty @@ -535,7 +535,7 @@ nicHtmlFieldProfile = FieldProfile |] , fpWidget = \name -> do addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" - addHead [$hamlet|%script bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")})|] + addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty @@ -787,7 +787,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addHead [$hamlet|%script $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});|] + addJavaScript [$hamlet|$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});|] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index d88de5fd..ea8dfe58 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -60,13 +60,13 @@ newtype Script url = Script { unScript :: Location url } newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } deriving (Show, Eq) newtype Title = Title { unTitle :: Html () } -newtype Style url = Style (Hamlet url) +newtype Style url = Style (Maybe (Hamlet url)) deriving Monoid newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid -newtype JavaScript url = JavaScript (Hamlet url) +newtype JavaScript url = JavaScript (Maybe (Hamlet url)) deriving Monoid newtype GWidget sub master a = GWidget ( @@ -103,7 +103,7 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do return $ "w" ++ show i' addStyle :: Hamlet (Route master) -> GWidget sub master () -addStyle = GWidget . lift . lift . lift . lift . tell . Style +addStyle = GWidget . lift . lift . lift . lift . tell . Style . Just addStylesheet :: Route master -> GWidget sub master () addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local @@ -120,7 +120,8 @@ addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote addJavaScript :: Hamlet (Route master) -> GWidget sub master () -addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . JavaScript +addJavaScript = GWidget . lift . lift . lift . lift . lift. tell + . JavaScript . Just applyLayoutW :: (Eq (Route m), Yesod m) => GWidget sub m () -> GHandler sub m RepHtml @@ -150,8 +151,10 @@ $forall scripts s %script!src=^s^ $forall stylesheets s %link!rel=stylesheet!href=^s^ -%style ^style^ -%script ^jscript^ +$maybe style s + %style ^s^ +$maybe jscript j + %script ^j^ ^head'^ |] return $ PageContent title head'' body diff --git a/hellowidget.hs b/hellowidget.hs index 11a330a0..f29aff1c 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -34,7 +34,6 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do |] addHead [$hamlet|%meta!keywords=haskell|] --- FIXME add coolness to day and html below handleFormR = do (res, form, enctype) <- runFormPost $ (,,,,,,,) <$> stringField (string "My Field") (string "Some tooltip info") Nothing @@ -52,6 +51,7 @@ handleFormR = do _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] + addStyle [$hamlet|textarea.html{width:300px;height:150px};|] wrapWidget (fieldsToTable form) $ \h -> [$hamlet| %form!method=post!enctype=$show.enctype$ %table From 9f75a77fcc04f961fdacaae01d42e2939cdf9632 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 10 Jul 2010 22:15:24 +0300 Subject: [PATCH 354/624] Unwrapped type for jqueryDayField et al --- Yesod/Dispatch.hs | 4 ++-- Yesod/Form.hs | 39 +++++++++++++++++++++++++++++---------- hellowidget.hs | 4 ++-- 3 files changed, 33 insertions(+), 14 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 9363c5c4..24ea7d30 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -265,9 +265,9 @@ toWaiApp' y segments env = do case authRoute y of Nothing -> permissionDenied "Authentication required" - Just url -> do + Just url' -> do setUltDest' - redirect RedirectTemporary url + redirect RedirectTemporary url' Unauthorized s -> permissionDenied s case handleSite site render url method of Nothing -> errorHandler $ BadMethod method diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1add7800..5a60d614 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -375,22 +375,25 @@ instance ToFormField Day where instance ToFormField (Maybe Day) where toFormField = maybeDayField +jqueryDayField :: Html () -> Html () -> FormletField sub y Day jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile { fpLabel = l , fpTooltip = t } + +maybeJqueryDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile { fpLabel = l , fpTooltip = t } -jqueryDayFieldProfile :: FieldProfile sub y JqueryDay +jqueryDayFieldProfile :: FieldProfile sub y Day jqueryDayFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") - (Right . JqueryDay) + Right . readMay - , fpRender = show . unJqueryDay + , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] @@ -409,9 +412,10 @@ jqueryDayFieldProfile = FieldProfile newtype JqueryDay = JqueryDay { unJqueryDay :: Day } deriving PersistField instance ToFormField JqueryDay where - toFormField = jqueryDayField + toFormField = applyFormTypeWrappers JqueryDay unJqueryDay jqueryDayField instance ToFormField (Maybe JqueryDay) where - toFormField = maybeJqueryDayField + toFormField = applyFormTypeWrappers (fmap JqueryDay) (fmap unJqueryDay) + maybeJqueryDayField parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') @@ -517,19 +521,22 @@ instance ToFormField (Maybe (Html ())) where newtype NicHtml = NicHtml { unNicHtml :: Html () } deriving PersistField +nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ()) nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile { fpLabel = label , fpTooltip = tooltip } + +maybeNicHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile { fpLabel = label , fpTooltip = tooltip } -nicHtmlFieldProfile :: FieldProfile sub y NicHtml +nicHtmlFieldProfile :: FieldProfile sub y (Html ()) nicHtmlFieldProfile = FieldProfile - { fpParse = Right . NicHtml . preEscapedString - , fpRender = U.toString . renderHtml . unNicHtml + { fpParse = Right . preEscapedString + , fpRender = U.toString . renderHtml , fpHamlet = \name val _isReq -> [$hamlet| %textarea.html#$name$!name=$name$ $val$ |] @@ -541,9 +548,16 @@ nicHtmlFieldProfile = FieldProfile , fpTooltip = mempty } instance ToFormField NicHtml where - toFormField = nicHtmlField + toFormField = applyFormTypeWrappers NicHtml unNicHtml nicHtmlField instance ToFormField (Maybe NicHtml) where - toFormField = maybeNicHtmlField + toFormField = applyFormTypeWrappers (fmap NicHtml) (fmap unNicHtml) + maybeNicHtmlField + +applyFormTypeWrappers :: (a -> b) -> (b -> a) + -> (f -> g -> FormletField s y a) + -> (f -> g -> FormletField s y b) +applyFormTypeWrappers wrap unwrap field l t orig = + fmap wrap $ field l t $ fmap unwrap orig readMay :: Read a => String -> Maybe a readMay s = case reads s of @@ -765,11 +779,16 @@ toLabel (x:rest) = toUpper x : go rest | isUpper c = ' ' : c : go cs | otherwise = c : go cs +jqueryAutocompleteField :: + Route y -> Html () -> Html () -> FormletField sub y String jqueryAutocompleteField src l t = requiredFieldHelper $ (jqueryAutocompleteFieldProfile src) { fpLabel = l , fpTooltip = t } + +maybeJqueryAutocompleteField :: + Route y -> Html () -> Html () -> FormletField sub y (Maybe String) maybeJqueryAutocompleteField src l t = optionalFieldHelper $ (jqueryAutocompleteFieldProfile src) { fpLabel = l diff --git a/hellowidget.hs b/hellowidget.hs index f29aff1c..d5d1d28a 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -45,9 +45,9 @@ handleFormR = do <*> jqueryAutocompleteField AutoCompleteR (string "Autocomplete") (string "Try it!") Nothing <*> nicHtmlField (string "HTML") (string "") - (Just $ NicHtml $ string "You can put rich text here") + (Just $ string "You can put rich text here") let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, NicHtml x) -> Just x + FormSuccess (_, _, _, _, _, _, _, x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] From ecd39ed5873a44f060b6b9c49a4b83f78862cab9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 11 Jul 2010 07:25:56 +0300 Subject: [PATCH 355/624] Added jsonRaw function --- Yesod/Json.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 1a12518b..2ae8ccde 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -10,6 +10,7 @@ module Yesod.Json , jsonScalar , jsonList , jsonMap + , jsonRaw #if TEST , testSuite #endif @@ -114,6 +115,12 @@ jsonMap (x:xs) = mconcat , v ] +-- | Outputs raw JSON data without performing any escaping. Use with caution: +-- this is the only function in this module that allows you to create broken +-- JSON documents. +jsonRaw :: S.ByteString -> Json +jsonRaw bs = Json $ unsafeByteString bs + #if TEST testSuite :: Test From 93d71a477938488b6a59e589a787b32b0c48ecca Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 11 Jul 2010 10:05:05 +0300 Subject: [PATCH 356/624] Added email field --- Yesod/Form.hs | 42 ++++++++++++++++++++++++++++++++++++++++-- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Widget.hs | 1 - 3 files changed, 42 insertions(+), 5 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 5a60d614..9c38e2de 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -44,6 +44,7 @@ module Yesod.Form , jqueryDayFieldProfile , timeFieldProfile , htmlFieldProfile + , emailFieldProfile -- * Pre-built fields , stringField , maybeStringField @@ -66,12 +67,15 @@ module Yesod.Form , boolField , jqueryAutocompleteField , maybeJqueryAutocompleteField + , emailField + , maybeEmailField -- * Pre-built inputs , stringInput , maybeStringInput , boolInput , dayInput , maybeDayInput + , emailInput -- * Template Haskell , share2 , mkToForm @@ -495,7 +499,7 @@ htmlField label tooltip = requiredFieldHelper htmlFieldProfile , fpTooltip = tooltip } -maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) -- FIXME make label and tooltip Strings instead +maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile { fpLabel = label , fpTooltip = tooltip @@ -658,7 +662,9 @@ maybeStringInput n = boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ \env _ -> return - (FormSuccess $ isJust $ lookup n env, mempty, UrlEncoded) -- FIXME + (FormSuccess $ isJust $ lookup n env, return $ addBody [$hamlet| +%input#$n$!type=checkbox!name=$n$ +|], UrlEncoded) dayInput :: String -> FormInput sub master Day dayInput n = @@ -811,3 +817,35 @@ jqueryAutocompleteFieldProfile src = FieldProfile , fpLabel = mempty , fpTooltip = mempty } + +emailFieldProfile :: FieldProfile s y String +emailFieldProfile = FieldProfile + { fpParse = Right -- FIXME validation + , fpRender = id + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=email!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty + } + +emailField :: Html () -> Html () -> FormletField sub y String +emailField label tooltip = requiredFieldHelper emailFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } + +maybeEmailField :: Html () -> Html () -> FormletField sub y (Maybe String) +maybeEmailField label tooltip = optionalFieldHelper emailFieldProfile + { fpLabel = label + , fpTooltip = tooltip + } + +emailInput :: String -> FormInput sub master String +emailInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper emailFieldProfile + { fpName = Just n + } Nothing diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 80b2b84a..9a01c7b9 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -302,7 +302,7 @@ getEmailRegisterR = do postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings - email <- runFormPost' $ stringInput "email" -- FIXME checkEmail + email <- runFormPost' $ emailInput "email" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <- @@ -367,7 +367,7 @@ postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost' $ (,) - <$> stringInput "email" -- FIXME valid e-mail? + <$> emailInput "email" <*> stringInput "password" y <- getYesod mecreds <- liftIO $ getEmailCreds ae email diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ea8dfe58..bfbc6581 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -26,7 +26,6 @@ module Yesod.Widget , extractBody ) where --- FIXME add support for script contents import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer From d5704fb65d066d42c75bc7f51d18d4920a77954f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 11 Jul 2010 10:12:33 +0300 Subject: [PATCH 357/624] E-mail validation via email-validate --- Yesod/Form.hs | 5 ++++- hellowidget.hs | 5 +++-- yesod.cabal | 3 ++- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 9c38e2de..fc6b2b9c 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -98,6 +98,7 @@ import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&)) +import qualified Text.Email.Validate as Email data FormResult a = FormMissing | FormFailure [String] @@ -820,7 +821,9 @@ jqueryAutocompleteFieldProfile src = FieldProfile emailFieldProfile :: FieldProfile s y String emailFieldProfile = FieldProfile - { fpParse = Right -- FIXME validation + { fpParse = \s -> if Email.isValid s + then Right s + else Left "Invalid e-mail address" , fpRender = id , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!type=email!:isReq:required!value=$val$ diff --git a/hellowidget.hs b/hellowidget.hs index d5d1d28a..844a66c5 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -35,7 +35,7 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,,,,) + (res, form, enctype) <- runFormPost $ (,,,,,,,,) <$> stringField (string "My Field") (string "Some tooltip info") Nothing <*> stringField (string "Another field") (string "") (Just "some default text") <*> intField (string "A number field") (string "some nums") (Just 5) @@ -46,8 +46,9 @@ handleFormR = do (string "Autocomplete") (string "Try it!") Nothing <*> nicHtmlField (string "HTML") (string "") (Just $ string "You can put rich text here") + <*> maybeEmailField (string "An e-mail addres") mempty Nothing let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, x) -> Just x + FormSuccess (_, _, _, _, _, _, _, x, _) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] diff --git a/yesod.cabal b/yesod.cabal index ad7cae56..89a37385 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -43,7 +43,8 @@ library persistent >= 0.1.0 && < 0.2, neither >= 0.0.0 && < 0.1, MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, - data-object >= 0.3.1 && < 0.4 + data-object >= 0.3.1 && < 0.4, + email-validate >= 0.2.5 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From e2eb7d3315de6e051c7e1bbf493126913cdb3410 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 9 Jul 2010 00:06:46 +0300 Subject: [PATCH 358/624] Migrated to WAI 0.2 --- Yesod/Content.hs | 29 +++++++---------------------- Yesod/Dispatch.hs | 24 ++++++++++++------------ Yesod/Handler.hs | 24 ++++++++++++------------ yesod.cabal | 4 ++-- 4 files changed, 33 insertions(+), 48 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 0dea1d78..b21e0f59 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content - Content (..) + Content , emptyContent , ToContent (..) -- * Mime types @@ -56,7 +56,6 @@ import Data.Text.Lazy (Text) import qualified Data.Text as T import qualified Network.Wai as W -import qualified Network.Wai.Enumerator as WE import Data.Time import System.Locale @@ -72,22 +71,11 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif --- | There are two different methods available for providing content in the --- response: via files and enumerators. The former allows server to use --- optimizations (usually the sendfile system call) for serving static files. --- The latter is a space-efficient approach to content. --- --- It can be tedious to write enumerators; often times, you will be well served --- to use 'toContent'. -data Content = ContentFile FilePath - | ContentEnum (forall a. - (a -> B.ByteString -> IO (Either a a)) - -> a - -> IO (Either a a)) +type Content = W.ResponseBody -- | Zero-length enumerator. emptyContent :: Content -emptyContent = ContentEnum $ \_ -> return . Right +emptyContent = W.ResponseLBS L.empty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -97,15 +85,15 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent bs = ContentEnum $ \f a -> f a bs + toContent = W.ResponseLBS . L.fromChunks . return instance ToContent L.ByteString where - toContent = swapEnum . WE.fromLBS + toContent = W.ResponseLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent = toContent . Data.ByteString.Lazy.UTF8.fromString + toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString -- | A function which gives targetted representations of content based on the -- content-types the user accepts. @@ -113,9 +101,6 @@ type ChooseRep = [ContentType] -- ^ list of content-types user accepts, ordered by preference -> IO (ContentType, Content) -swapEnum :: W.Enumerator -> Content -swapEnum (W.Enumerator e) = ContentEnum e - -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 24ea7d30..dbe607ec 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -64,6 +65,7 @@ import Data.Serialize import qualified Data.Serialize as Ser import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP +import Data.String (fromString) #if TEST import Test.Framework (testGroup, Test) @@ -241,11 +243,11 @@ toWaiApp' y segments env = do let exp' = getExpires $ clientSessionDuration y let host = W.remoteHost env let session' = fromMaybe [] $ do - raw <- lookup W.Cookie $ W.requestHeaders env + raw <- lookup "Cookie" $ W.requestHeaders env val <- lookup (B.pack sessionName) $ parseCookies raw decodeSession key' now host val let site = getSite - method = B.unpack $ W.methodToBS $ W.requestMethod env + method = B.unpack $ W.requestMethod env types = httpAccept env pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments @@ -281,10 +283,8 @@ toWaiApp' y segments env = do (S.toString sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = (W.ContentType, S.fromString ct) : hs'' - return $ W.Response s hs''' $ case c of - ContentFile fp -> Left fp - ContentEnum e -> Right $ W.Enumerator e + hs''' = ("Content-Type", S.fromString ct) : hs'' + return $ W.Response s hs''' c -- | Fully render a route to an absolute URL. Since Yesod does this for you -- internally, you will rarely need access to this. However, if you need to @@ -303,7 +303,7 @@ httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack . parseHttpAccept . fromMaybe B.empty - . lookup W.Accept + . lookup "Accept" . W.requestHeaders -- | Runs an application with CGI if CGI variables are present (namely @@ -347,10 +347,10 @@ parseWaiRequest :: W.Request parseWaiRequest env session' = do let gets' = map (S.toString *** S.toString) $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup W.Cookie + let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie - acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env + acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map S.toString $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey session' of Nothing -> langs @@ -389,14 +389,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes - in (W.SetCookie, S.fromString + in ("Set-Cookie", S.fromString $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) = - (W.SetCookie, S.fromString $ + ("Set-Cookie", S.fromString $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = - (W.responseHeaderFromBS $ S.fromString key, S.fromString value) + (fromString key, S.fromString value) encodeSession :: CS.Key -> UTCTime -- ^ expire time diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index eb17e74f..ce81516f 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -240,11 +240,11 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.Status200, headers [], ct, ContentFile fp, finalSession) + return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) case contents of HCContent a -> do (ct, c) <- chooseRep a cts - return (W.Status200, headers [], ct, c, finalSession) + return (W.status200, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] @@ -257,7 +257,7 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.Status500, [], typePlain, toContent "Internal Server Error", []) + return (W.status500, [], typePlain, toContent "Internal Server Error", []) -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -373,7 +373,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ toString $ W.methodToBS $ W.requestMethod w + failure $ BadMethod $ toString $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a @@ -422,16 +422,16 @@ addHeader :: Header -> GHandler sub master () addHeader = GHandler . lift . lift . tell . (:) getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.Status404 -getStatus (InternalError _) = W.Status500 -getStatus (InvalidArgs _) = W.Status400 -getStatus (PermissionDenied _) = W.Status403 -getStatus (BadMethod _) = W.Status405 +getStatus NotFound = W.status404 +getStatus (InternalError _) = W.status500 +getStatus (InvalidArgs _) = W.status400 +getStatus (PermissionDenied _) = W.status403 +getStatus (BadMethod _) = W.status405 getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.Status301 -getRedirectStatus RedirectTemporary = W.Status302 -getRedirectStatus RedirectSeeOther = W.Status303 +getRedirectStatus RedirectPermanent = W.status301 +getRedirectStatus RedirectTemporary = W.status302 +getRedirectStatus RedirectSeeOther = W.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent diff --git a/yesod.cabal b/yesod.cabal index 89a37385..9b10d12b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -22,8 +22,8 @@ flag buildtests library build-depends: base >= 4 && < 5, time >= 1.1.3 && < 1.2, - wai >= 0.1.0 && < 0.2, - wai-extra >= 0.1.3.1 && < 0.2, + wai >= 0.2.0 && < 0.3, + wai-extra >= 0.2.0 && < 0.3, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, From 6f544d0d270e402f28646c119821344b0d35603e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 00:39:49 +0300 Subject: [PATCH 359/624] Time version bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 9b10d12b..96c8266b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -21,7 +21,7 @@ flag buildtests library build-depends: base >= 4 && < 5, - time >= 1.1.3 && < 1.2, + time >= 1.2 && < 1.3, wai >= 0.2.0 && < 0.3, wai-extra >= 0.2.0 && < 0.3, authenticate >= 0.6.3 && < 0.7, From 62878e53cfba5caa558b985bdfc9776817e3ba81 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 08:47:39 +0300 Subject: [PATCH 360/624] Added scaffolder --- CodeGen.hs | 44 +++++++++++ LICENSE | 2 +- scaffold.hs | 200 +++++++++++++++++++++++++++++++++++++++++++++++ static/style.css | 11 ++- yesod.cabal | 5 ++ 5 files changed, 260 insertions(+), 2 deletions(-) create mode 100644 CodeGen.hs create mode 100644 scaffold.hs diff --git a/CodeGen.hs b/CodeGen.hs new file mode 100644 index 00000000..e533ad2f --- /dev/null +++ b/CodeGen.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | A code generation quasi-quoter. Everything is taken as literal text, with ~var~ variable interpolation, and ~~ is completely ignored. +module CodeGen (codegen) where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Text.ParserCombinators.Parsec + +codegen :: QuasiQuoter +codegen = QuasiQuoter codegen' $ error "codegen cannot be a pattern" + +data Token = VarToken String | LitToken String | EmptyToken + +codegen' :: String -> Q Exp +codegen' s' = do + let s = killFirstBlank s' + case parse (many parseToken) s s of + Left e -> error $ show e + Right tokens -> do + let tokens' = map toExp tokens + concat' <- [|concat|] + return $ concat' `AppE` ListE tokens' + where + killFirstBlank ('\n':x) = x + killFirstBlank ('\r':'\n':x) = x + killFirstBlank x = x + +toExp :: Token -> Exp +toExp (LitToken s) = LitE $ StringL s +toExp (VarToken s) = VarE $ mkName s +toExp EmptyToken = LitE $ StringL "" + +parseToken :: Parser Token +parseToken = + parseVar <|> parseLit + where + parseVar = do + _ <- char '~' + s <- many alphaNum + _ <- char '~' + return $ if null s then EmptyToken else VarToken s + parseLit = do + s <- many1 $ noneOf "~" + return $ LitToken s diff --git a/LICENSE b/LICENSE index 81e3ec6a..8643e5d8 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2009, Michael Snoyman. All rights reserved. +Copyright 2010, 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: diff --git a/scaffold.hs b/scaffold.hs new file mode 100644 index 00000000..f596feab --- /dev/null +++ b/scaffold.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE QuasiQuotes #-} +import CodeGen +import System.IO +import System.Directory + +main :: IO () +main = do + putStr [$codegen|Welcome to the Yesod scaffolder. +I'm going to be creating a skeleton Yesod project for you. +Please make sure you are in the directory where you'd like the files created. + +What is your name? We're going to put this in the cabal and LICENSE files. + +Your name: |] + hFlush stdout + name <- getLine + + putStr [$codegen| +Welcome ~name~. +What do you want to call your project? We'll use this for the cabal name and +executable filenames. + +Project name: |] + hFlush stdout + project <- getLine + putStr [$codegen| +Great, we'll be creating ~project~ today. What's going to be the name of +your site argument datatype? This name must start with a capital letter; +I recommend picking something short, as this name gets typed a lot. + +Site argument: |] + hFlush stdout + sitearg <- getLine + putStr [$codegen| +That's it! I'm creating your files now... +|] + + putStrLn $ "Generating " ++ project ++ ".cabal" + writeFile (project ++ ".cabal") [$codegen| +name: ~project~ +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: ~name~ +maintainer: ~name~ +synopsis: The greatest Yesod web application ever. +description: I'm sure you can say something clever here if you try. +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com/~project~ + +executable ~project~ + build-depends: base >= 4 && < 5, + yesod >= 0.4.0 && < 0.5.0, + persistent-sqlite >= 0.1.0 && < 0.2 + ghc-options: -Wall + main-is: ~project~.hs +|] + + putStrLn "Generating LICENSE" + writeFile "LICENSE" [$codegen| +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, ~name~. 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. +|] + + putStrLn ("Generating " ++ project ++ ".hs") + writeFile (project ++ ".hs") [$codegen| +import Yesod +import App + +main :: IO () +main = with~sitearg~ $ basicHandler 3000 +|] + + putStrLn "Generating App.hs" + writeFile "App.hs" [$codegen| +{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} +module App + ( ~sitearg~ (..) + , with~sitearg~ + ) where +import Yesod +import Yesod.Helpers.Crud +import Yesod.Helpers.Static +import Database.Persist.Sqlite +import Model + +data ~sitearg~ = ~sitearg~ + { connPool :: Pool Connection + , static :: Static + } + +with~sitearg~ :: (~sitearg~ -> IO a) -> IO a +with~sitearg~ f = withSqlite "~project~.db3" 8 $ \pool -> do + flip runSqlite pool $ do + -- This is where you can initialize your database. + initialize (undefined :: Person) + f $ ~sitearg~ pool $ fileLookupDir "static" typeByExt + +type PersonCrud = Crud ~sitearg~ Person + +mkYesod "~sitearg~" [$parseRoutes| +/ RootR GET +/people PeopleR PersonCrud defaultCrud +/static StaticR Static static +|~~] + +instance Yesod ~sitearg~ where + approot _ = "http://localhost:3000" + defaultLayout (PageContent title head' body) = hamletToContent [$hamlet| +!!! +%html + %head + %title $title$ + %link!rel=stylesheet!href=@stylesheet@ + ^head'^ + %body + #wrapper + ^body^ +|~~] + where + stylesheet = StaticR $ StaticRoute ["style.css"] + +instance YesodPersist ~sitearg~ where + type YesodDB ~sitearg~ = SqliteReader + runDB db = fmap connPool getYesod >>= runSqlite db + +getRootR :: Handler ~sitearg~ RepHtml +getRootR = applyLayoutW $ do + setTitle "Welcome to the ~project~ project" + addBody [$hamlet| +%h1 Welcome to ~project~ +%h2 The greatest Yesod web application ever! +%p + %a!href=@PeopleR.CrudListR@ Manage people +|~~] +|] + + putStrLn "Generating Model.hs" + writeFile "Model.hs" [$codegen| +{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TypeFamilies #-} + +-- We don't explicitly state our export list, since there are funny things +-- that happen with type family constructors. +module Model where + +import Yesod +import Yesod.Helpers.Crud + +share2 mkPersist mkToForm [$persist| +Person + name String + age Int +|~~] + +instance Item Person where + itemTitle = personName +|] + + putStrLn "Generating static/style.css" + createDirectoryIfMissing True "static" + writeFile "static/style.css" [$codegen| +body { + font-family: sans-serif; + background: #eee; +} + +#wrapper { + width: 760px; + margin: 1em auto; + border: 2px solid #000; + padding: 0.5em; + background: #fff; +} +|] diff --git a/static/style.css b/static/style.css index 39895bcc..d09c6b08 100644 --- a/static/style.css +++ b/static/style.css @@ -1,3 +1,12 @@ body { - background-color: #ffd; + font-family: sans-serif; + background: #eee; +} + +#wrapper { + width: 760px; + margin: 1em auto; + border: 2px solid #000; + padding: 0.5em; + background: #fff; } diff --git a/yesod.cabal b/yesod.cabal index 96c8266b..706f9107 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -63,6 +63,11 @@ library Yesod.Helpers.Static ghc-options: -Wall +executable yesod + build-depends: parsec >= 2.1 && < 4 + ghc-options: -Wall + main-is: scaffold.hs + executable runtests if flag(buildtests) Buildable: True From d8ece1db78fa3daa3fcbb3ae340601aff8262faa Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 09:36:20 +0300 Subject: [PATCH 361/624] Updated documentation --- Yesod/Dispatch.hs | 10 ++++----- Yesod/Form.hs | 48 ++++++++++++++++++++++++++++++++++------- Yesod/Helpers/Auth.hs | 8 +++++-- Yesod/Helpers/Crud.hs | 6 ++++++ Yesod/Helpers/Static.hs | 6 ++++++ Yesod/Widget.hs | 42 ++++++++++++++++++++++++++++++++++++ 6 files changed, 105 insertions(+), 15 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index dbe607ec..0e3dfe36 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -80,7 +80,7 @@ import Yesod.Content #endif -- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. +-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- Use 'parseRoutes' to create the 'Resource's. mkYesod :: String -- ^ name of the argument datatype -> [Resource] @@ -88,7 +88,7 @@ mkYesod :: String -- ^ name of the argument datatype mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. +-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. -- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not -- executable by itself, but instead provides functionality to -- be embedded in other sites. @@ -103,8 +103,8 @@ mkYesodSub name clazzes = -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a --- monolithic file into smaller parts. This function, paired with --- 'mkYesodDispatch', do just that. +-- monolithic file into smaller parts. Use this function, paired with +-- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [Resource] -> Q [Dec] mkYesodData name res = do (x, _) <- mkYesodGeneral name [] [] False res @@ -288,7 +288,7 @@ toWaiApp' y segments env = do -- | Fully render a route to an absolute URL. Since Yesod does this for you -- internally, you will rarely need access to this. However, if you need to --- generate links *outside* of the Handler monad, this may be useful. +-- generate links /outside/ of the Handler monad, this may be useful. -- -- For example, if you want to generate an e-mail which links to your site, -- this is the function you would want to use. diff --git a/Yesod/Form.hs b/Yesod/Form.hs index fc6b2b9c..e2870883 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -100,6 +100,11 @@ import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email +-- | A form can produce three different results: there was no data available, +-- the data was invalid, or there was a successful parse. +-- +-- The 'Applicative' instance will concatenate the failure messages in two +-- 'FormResult's. data FormResult a = FormMissing | FormFailure [String] | FormSuccess a @@ -116,6 +121,8 @@ instance Applicative FormResult where _ <*> (FormFailure y) = FormFailure y _ <*> _ = FormMissing +-- | The encoding type required by a form. The 'Show' instance produces values +-- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart instance Show Enctype where show UrlEncoded = "application/x-www-form-urlencoded" @@ -125,6 +132,8 @@ instance Monoid Enctype where mappend UrlEncoded UrlEncoded = UrlEncoded mappend _ _ = Multipart +-- | A generic form, allowing you to specifying the subsite datatype, master +-- site datatype, a datatype for the form XML and the return type. newtype GForm sub y xml a = GForm { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype) } @@ -134,11 +143,15 @@ type FormField sub y = GForm sub y [FieldInfo sub y] type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] +-- | Convert the XML in a 'GForm'. mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a mapFormXml f (GForm g) = GForm $ \e fe -> do (res, xml, enc) <- g e fe return (res, f xml, enc) +-- | Using this as the intermediate XML representation for fields allows us to +-- write generic field functions and then different functions for producing +-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () @@ -163,12 +176,15 @@ instance Monoid xml => Applicative (GForm sub url xml) where (g1, g2, g3) <- g env fe return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) +-- | Display only the actual input widget code, without any decoration. fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y () fieldsToPlain = mapM_ fiInput fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] fieldsToInput = map fiInput +-- | Display the label, tooltip, input code and errors in a single row of a +-- table. fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () fieldsToTable = mapM_ go where @@ -189,6 +205,8 @@ class ToForm a where class ToFormField a where toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a +-- | Create a required field (ie, one that cannot be blank) from a +-- 'FieldProfile'. requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig = GForm $ \env _ -> do @@ -214,6 +232,8 @@ requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig } return (res, [fi], UrlEncoded) +-- | Create an optional field (ie, one that can be blank) from a +-- 'FieldProfile'. optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a) -> FormField sub y (Maybe a) optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' = @@ -241,6 +261,9 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig } return (res, [fi], UrlEncoded) +-- | A generic definition of a form field that can be used for generating both +-- required and optional fields. See 'requiredFieldHelper and +-- 'optionalFieldHelper'. data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String @@ -403,10 +426,12 @@ jqueryDayFieldProfile = FieldProfile %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addJavaScript [$hamlet|$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})});|] + addScriptRemote urlJqueryJs + addScriptRemote urlJqueryUiJs + addStylesheetRemote urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); +|] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty @@ -683,6 +708,7 @@ maybeDayInput n = --------------------- End prebuilt inputs +-- | Get a unique identifier. newFormIdent :: Monad m => StateT Int m String newFormIdent = do i <- get @@ -726,12 +752,16 @@ runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f +-- | This function allows two different monadic functions to share the same +-- input and have their results concatenated. This is particularly useful for +-- allowing 'mkToForm' to share its input with mkPersist. share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] share2 f g a = do f' <- f a g' <- g a return $ f' ++ g' +-- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. mkToForm :: [EntityDef] -> Q [Dec] mkToForm = mapM derive where @@ -810,10 +840,12 @@ jqueryAutocompleteFieldProfile src = FieldProfile %input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \name -> do - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - addStylesheetRemote "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - addJavaScript [$hamlet|$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})});|] + addScriptRemote urlJqueryJs + addScriptRemote urlJqueryUiJs + addStylesheetRemote urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); +|] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 9a01c7b9..d8837345 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -52,6 +52,7 @@ import Control.Monad.Attempt import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object +-- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'. class Yesod master => YesodAuth master where -- | Default destination on successful login or logout, if no other -- destination exists. @@ -75,8 +76,8 @@ class Yesod master => YesodAuth master where stdgen <- newStdGen return $ take 10 $ randomRs ('A', 'Z') stdgen --- | Each authentication subsystem (OpenId, Rpxnow, Email) has its own --- settings. If those settings are not present, then relevant handlers will +-- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its +-- own settings. If those settings are not present, then relevant handlers will -- simply return a 404. data Auth = Auth { authIsOpenIdEnabled :: Bool @@ -456,6 +457,9 @@ saltPass pass = do saltPass' :: String -> String -> String saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) +-- | A simplistic set of email settings, useful only for testing purposes. In +-- particular, it doesn't actually send emails, but instead prints verification +-- URLs to stderr. inMemoryEmailSettings :: IO AuthEmailSettings inMemoryEmailSettings = do mm <- newMVar [] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 9b25cdde..bf8462c4 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -19,9 +19,14 @@ import Text.Hamlet import Yesod.Form import Data.Monoid (mempty) +-- | An entity which can be displayed by the Crud subsite. class ToForm a => Item a where + -- | The title of an entity, to be displayed in the list of all entities. itemTitle :: a -> String +-- | Defines all of the CRUD operations (Create, Read, Update, Delete) +-- necessary to implement this subsite. When using the "Yesod.Form" module and +-- 'ToForm' typeclass, you can probably just use 'defaultCrud'. data Crud master item = Crud { crudSelect :: GHandler (Crud master item) master [(Key item, item)] , crudReplace :: Key item -> item -> GHandler (Crud master item) master () @@ -159,6 +164,7 @@ crudHelper title me isPost = do %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete |] +-- | A default 'Crud' value which relies about persistent and "Yesod.Form". defaultCrud :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)), YesodPersist a) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index f498dfbd..734dac8b 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -68,6 +68,8 @@ mkYesodSub "Static" [] [$parseRoutes| -- probably are), the handler itself checks that no unsafe paths are being -- requested. In particular, no path segments may begin with a single period, -- so hidden files and parent directories are safe. +-- +-- For the second argument to this function, you can just use 'typeByExt'. fileLookupDir :: FilePath -> [(String, ContentType)] -> Static fileLookupDir dir = Static $ \fp -> do let fp' = dir ++ '/' : fp @@ -114,6 +116,10 @@ getFileList = flip go id dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs return $ concat $ files' : dirs' +-- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: +-- +-- > style_css = StaticRoute ["style.css"] +-- > js_script_js = StaticRoute ["js/script.js"] staticFiles :: FilePath -> Q [Dec] staticFiles fp = do fs <- qRunIO $ getFileList fp diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index bfbc6581..1e081c69 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-} +-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier +-- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype GWidget @@ -24,6 +26,10 @@ module Yesod.Widget -- * Manipulating , wrapWidget , extractBody + -- * Default library URLs + , urlJqueryJs + , urlJqueryUiJs + , urlJqueryUiCss ) where import Data.List (nub) @@ -68,6 +74,9 @@ newtype Body url = Body (Hamlet url) newtype JavaScript url = JavaScript (Maybe (Hamlet url)) deriving Monoid +-- | A generic widget, allowing specification of both the subsite and master +-- site datatypes. This is basically a large 'WriterT' stack keeping track of +-- dependencies along with a 'StateT' to track unique identifiers. newtype GWidget sub master a = GWidget ( WriterT (Body (Route master)) ( WriterT (Last Title) ( @@ -83,17 +92,23 @@ newtype GWidget sub master a = GWidget ( instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y +-- | A 'GWidget' specialized to when the subsite and master site are the same. type Widget y = GWidget y y +-- | Set the page title. Calling 'setTitle' multiple times overrides previously +-- set values. setTitle :: Html () -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title +-- | Add some raw HTML to the head tag. addHead :: Hamlet (Route master) -> GWidget sub master () addHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head +-- | Add some raw HTML to the body tag. addBody :: Hamlet (Route master) -> GWidget sub master () addBody = GWidget . tell . Body +-- | Get a unique identifier. newIdent :: GWidget sub master String newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do i <- get @@ -101,31 +116,39 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do put i' return $ "w" ++ show i' +-- | Add some raw CSS to the style tag. addStyle :: Hamlet (Route master) -> GWidget sub master () addStyle = GWidget . lift . lift . lift . lift . tell . Style . Just +-- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master () addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local +-- | Link to the specified remote stylesheet. addStylesheetRemote :: String -> GWidget sub master () addStylesheetRemote = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote +-- | Link to the specified local script. addScript :: Route master -> GWidget sub master () addScript = GWidget . lift . lift . tell . toUnique . Script . Local +-- | Link to the specified remote script. addScriptRemote :: String -> GWidget sub master () addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote +-- | Include raw Javascript in the page's script tag. addJavaScript :: Hamlet (Route master) -> GWidget sub master () addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . JavaScript . Just +-- | Apply the default layout to the given widget. applyLayoutW :: (Eq (Route m), Yesod m) => GWidget sub m () -> GHandler sub m RepHtml applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout +-- | Convert a widget to a 'PageContent'. widgetToPageContent :: Eq (Route master) => GWidget sub master () -> GHandler sub master (PageContent (Route master)) @@ -158,6 +181,8 @@ $maybe jscript j |] return $ PageContent title head'' body +-- | Modify the given 'GWidget' by wrapping the body tag HTML code with the +-- given function. You might also consider using 'extractBody'. wrapWidget :: GWidget s m a -> (Hamlet (Route m) -> Hamlet (Route m)) -> GWidget s m a @@ -166,8 +191,25 @@ wrapWidget (GWidget w) wrap = where go (a, Body h) = (a, Body $ wrap h) +-- | Pull out the HTML tag contents and return it. Useful for performing some +-- manipulations. It can be easier to use this sometimes than 'wrapWidget'. extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m)) extractBody (GWidget w) = GWidget $ mapWriterT (fmap go) w where go ((), Body h) = (h, Body mempty) + +-- | The Google-hosted jQuery 1.4.2 file. +urlJqueryJs :: String +urlJqueryJs = + "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + +-- | The Google-hosted jQuery UI 1.8.1 javascript file. +urlJqueryUiJs :: String +urlJqueryUiJs = + "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + +-- | The Google-hosted jQuery UI 1.8.1 CSS file with cupertino theme. +urlJqueryUiCss :: String +urlJqueryUiCss = + "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" From db7dfcbefde3fa5f0c7ba4470ad4ea4582bc3bab Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 11:17:25 +0300 Subject: [PATCH 362/624] Added Html' and get404 --- Yesod/Form.hs | 3 +++ Yesod/Yesod.hs | 14 ++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index e2870883..ec18b046 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -20,6 +20,7 @@ module Yesod.Form -- * Newtype wrappers , JqueryDay (..) , NicHtml (..) + , Html' -- * Unwrapping functions , runFormGet , runFormPost @@ -551,6 +552,8 @@ instance ToFormField (Maybe (Html ())) where newtype NicHtml = NicHtml { unNicHtml :: Html () } deriving PersistField +type Html' = Html () + nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ()) nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile { fpLabel = label diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5fbfb233..9b800dfa 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -12,6 +12,7 @@ module Yesod.Yesod -- ** Persistence , YesodPersist (..) , module Database.Persist + , get404 -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -38,6 +39,8 @@ import Data.Monoid (mempty) import Data.ByteString.UTF8 (toString) import Database.Persist import Web.Routes.Site (Site) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Attempt (Failure) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -218,6 +221,17 @@ class YesodPersist y where type YesodDB y :: (* -> *) -> * -> * runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a + +-- Get the given entity by ID, or return a 404 not found if it doesn't exist. +get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m), + Failure ErrorResponse m, MonadTrans t) + => Key val -> t m val +get404 key = do + mres <- get key + case mres of + Nothing -> lift notFound + Just res -> return res + -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only From 79909019742e881ed18a576962114c7687cd6c2f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 12:25:55 +0300 Subject: [PATCH 363/624] Lowered time package dependency --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 706f9107..93710bf6 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -21,7 +21,7 @@ flag buildtests library build-depends: base >= 4 && < 5, - time >= 1.2 && < 1.3, + time >= 1.1.4 && < 1.3, wai >= 0.2.0 && < 0.3, wai-extra >= 0.2.0 && < 0.3, authenticate >= 0.6.3 && < 0.7, From 3637c8937072d21808de6892a71256de4e3ee4c8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 14:26:13 +0300 Subject: [PATCH 364/624] CodeGen -> CodeGenQ --- CodeGen.hs => CodeGenQ.hs | 2 +- scaffold.hs | 2 +- yesod.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) rename CodeGen.hs => CodeGenQ.hs (97%) diff --git a/CodeGen.hs b/CodeGenQ.hs similarity index 97% rename from CodeGen.hs rename to CodeGenQ.hs index e533ad2f..b1aab436 100644 --- a/CodeGen.hs +++ b/CodeGenQ.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -- | A code generation quasi-quoter. Everything is taken as literal text, with ~var~ variable interpolation, and ~~ is completely ignored. -module CodeGen (codegen) where +module CodeGenQ (codegen) where import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax diff --git a/scaffold.hs b/scaffold.hs index f596feab..8fc2f0e7 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -1,5 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} -import CodeGen +import CodeGenQ import System.IO import System.Directory diff --git a/yesod.cabal b/yesod.cabal index 93710bf6..e49c483b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.4.0 +version: 0.4.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From f3417b59c53085a6f0e71776623eceedbb7d36b7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 13 Jul 2010 20:49:51 +0300 Subject: [PATCH 365/624] Include CodeGenQ in the cabal file --- yesod.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index e49c483b..70b9d37d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.4.0.1 +version: 0.4.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -67,6 +67,7 @@ executable yesod build-depends: parsec >= 2.1 && < 4 ghc-options: -Wall main-is: scaffold.hs + other-modules: CodeGenQ executable runtests if flag(buildtests) From 839efad98ba51e9c2f401195187c905afc4ac059 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 15 Jul 2010 01:35:34 +0300 Subject: [PATCH 366/624] False instead of True in Crud --- Yesod/Helpers/Crud.hs | 2 +- yesod.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index bf8462c4..f465bef2 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -96,7 +96,7 @@ postCrudEditR s = do crudHelper "Edit item" (Just (itemId, item)) - False + True getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) => String -> GHandler (Crud master item) master RepHtml diff --git a/yesod.cabal b/yesod.cabal index 70b9d37d..e41020df 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.4.0.2 +version: 0.4.0.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From cb51f4fa8e50cbe38219a40e234e6d6549e23d04 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 15 Jul 2010 18:05:44 +0300 Subject: [PATCH 367/624] Added liftHandler function --- Yesod/Widget.hs | 6 ++++++ yesod.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 1e081c69..ef7491ef 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -9,6 +9,7 @@ module Yesod.Widget ( -- * Datatype GWidget , Widget + , liftHandler -- * Unwrapping , widgetToPageContent , applyLayoutW @@ -95,6 +96,11 @@ instance Monoid (GWidget sub master ()) where -- | A 'GWidget' specialized to when the subsite and master site are the same. type Widget y = GWidget y y +-- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' +-- monad. +liftHandler :: GHandler sub master a -> GWidget sub master a +liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift + -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Html () -> GWidget sub master () diff --git a/yesod.cabal b/yesod.cabal index e41020df..1bb7e12b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.4.0.3 +version: 0.4.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 8ca2f3e2b47e08e95cc940abc4294420b2679b94 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 16 Jul 2010 09:41:06 -0700 Subject: [PATCH 368/624] derive standard classes for JqueryDay field --- Yesod/Form.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ec18b046..d3e8d4a3 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -442,6 +442,14 @@ $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); -- 'ToFormField' instance. newtype JqueryDay = JqueryDay { unJqueryDay :: Day } deriving PersistField +instance Show JqueryDay where + show = show . unJqueryDay +instance Read JqueryDay where + readsPrec i s = let [(day, str)] = readsPrec i s :: [(Day, String)] + in [((JqueryDay day), str)] +instance Eq JqueryDay where + x == y = (unJqueryDay x) == (unJqueryDay y) + instance ToFormField JqueryDay where toFormField = applyFormTypeWrappers JqueryDay unJqueryDay jqueryDayField instance ToFormField (Maybe JqueryDay) where From a0bc2a1d2117826c2a713b0b4dc5a69ed7a8b859 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Jul 2010 16:54:54 +0300 Subject: [PATCH 369/624] persistent 0.2.0 --- Yesod/Helpers/Crud.hs | 2 +- yesod.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index f465bef2..e3d718c8 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -170,7 +170,7 @@ defaultCrud YesodPersist a) => a -> Crud a i defaultCrud = const Crud - { crudSelect = runDB $ select [] [] + { crudSelect = runDB $ selectList [] [] 0 0 , crudReplace = \a -> runDB . replace a , crudInsert = runDB . insert , crudGet = runDB . get diff --git a/yesod.cabal b/yesod.cabal index 1bb7e12b..25372373 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.4.1 +version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -40,7 +40,7 @@ library control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, old-locale >= 1.0.0.2 && < 1.1, - persistent >= 0.1.0 && < 0.2, + persistent >= 0.2.0 && < 0.3, neither >= 0.0.0 && < 0.1, MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, data-object >= 0.3.1 && < 0.4, From d4333814f77a37a1ef973b8587a646e31d700120 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 20 Jul 2010 22:14:07 +0300 Subject: [PATCH 370/624] Parsing toFormField attribute, dropping Form newtype wrappers --- Yesod/Form.hs | 47 ++++++++--------------------------------------- 1 file changed, 8 insertions(+), 39 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index d3e8d4a3..2c07e2d5 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -17,9 +17,6 @@ module Yesod.Form , FormResult (..) , Enctype (..) , FieldInfo (..) - -- * Newtype wrappers - , JqueryDay (..) - , NicHtml (..) , Html' -- * Unwrapping functions , runFormGet @@ -93,7 +90,7 @@ import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) import Control.Monad.Trans.State import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..), PersistField) +import Database.Persist.Base (EntityDef (..)) import Data.Char (toUpper, isUpper) import Data.Int (Int64) import qualified Data.ByteString.Lazy.UTF8 as U @@ -438,24 +435,6 @@ $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); , fpTooltip = mempty } --- | A newtype wrapper around 'Day', using jQuery UI date picker for the --- 'ToFormField' instance. -newtype JqueryDay = JqueryDay { unJqueryDay :: Day } - deriving PersistField -instance Show JqueryDay where - show = show . unJqueryDay -instance Read JqueryDay where - readsPrec i s = let [(day, str)] = readsPrec i s :: [(Day, String)] - in [((JqueryDay day), str)] -instance Eq JqueryDay where - x == y = (unJqueryDay x) == (unJqueryDay y) - -instance ToFormField JqueryDay where - toFormField = applyFormTypeWrappers JqueryDay unJqueryDay jqueryDayField -instance ToFormField (Maybe JqueryDay) where - toFormField = applyFormTypeWrappers (fmap JqueryDay) (fmap unJqueryDay) - maybeJqueryDayField - parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') @@ -557,9 +536,6 @@ instance ToFormField (Html ()) where instance ToFormField (Maybe (Html ())) where toFormField = maybeHtmlField -newtype NicHtml = NicHtml { unNicHtml :: Html () } - deriving PersistField - type Html' = Html () nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ()) @@ -588,17 +564,6 @@ nicHtmlFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField NicHtml where - toFormField = applyFormTypeWrappers NicHtml unNicHtml nicHtmlField -instance ToFormField (Maybe NicHtml) where - toFormField = applyFormTypeWrappers (fmap NicHtml) (fmap unNicHtml) - maybeNicHtmlField - -applyFormTypeWrappers :: (a -> b) -> (b -> a) - -> (f -> g -> FormletField s y a) - -> (f -> g -> FormletField s y b) -applyFormTypeWrappers wrap unwrap field l t orig = - fmap wrap $ field l t $ fmap unwrap orig readMay :: Read a => String -> Maybe a readMay s = case reads s of @@ -776,6 +741,10 @@ share2 f g a = do mkToForm :: [EntityDef] -> Q [Dec] mkToForm = mapM derive where + getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z + getTFF' [] = Nothing + getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x + getTFF' (_:x) = getTFF' x getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z getLabel' [] = Nothing getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x @@ -786,7 +755,7 @@ mkToForm = mapM derive getTooltip' [] = Nothing derive :: EntityDef -> Q Dec derive t = do - let cols = map (getLabel &&& getTooltip) $ entityColumns t + let cols = map ((getLabel &&& getTooltip) &&& getTFF) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] @@ -811,10 +780,10 @@ mkToForm = mapM derive go ap just' string' mfx ftt a = let x = foldl (ap' ap) just' $ map (go' string') a in mfx `AppE` ftt `AppE` x - go' string' ((label, tooltip), ex) = + go' string' (((label, tooltip), tff), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip) - in VarE (mkName "toFormField") `AppE` label' + in VarE (mkName tff) `AppE` label' `AppE` tooltip' `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) From 83057e1a5ff3d1e791c48c36e9c95692efcf64e7 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Mon, 19 Jul 2010 13:18:09 -0700 Subject: [PATCH 371/624] add jqueryDayTimeField for a datetime field widget --- Yesod/Form.hs | 79 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 76 insertions(+), 3 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 2c07e2d5..afc32b09 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -54,6 +54,8 @@ module Yesod.Form , maybeDayField , jqueryDayField , maybeJqueryDayField + , jqueryDayTimeField + , jqueryDayTimeFieldProfile , timeField , maybeTimeField , htmlField @@ -83,7 +85,8 @@ import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) -import Data.Time (Day, TimeOfDay (TimeOfDay)) +import Data.Time (UTCTime(..), Day, TimeOfDay(..)) +import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay) import Data.Maybe (fromMaybe, isJust) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) @@ -97,6 +100,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email +import Data.Char (isSpace) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -385,8 +389,7 @@ maybeDayField l t = optionalFieldHelper dayFieldProfile dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay + { fpParse = parseDate , fpRender = show , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ @@ -435,9 +438,79 @@ $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); , fpTooltip = mempty } +-- | Replaces all instances of a value in a list by another value. +-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) + +ifRight :: Either a b -> (b -> c) -> Either a c +ifRight e f = case e of + Left l -> Left l + Right r -> Right $ f r + +showLeadingZero :: (Show a) => a -> String +showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t + +parseUTCTime :: String -> Either String UTCTime +parseUTCTime s = + let (dateS, timeS) = break isSpace (dropWhile isSpace s) + in let dateE = (parseDate dateS) + in case dateE of + Left l -> Left l + Right date -> ifRight (parseTime timeS) + (\time -> UTCTime date (timeOfDayToTime time)) + +-- TODO - integrate with static helpers +jqueryUiDateTimePicker :: String +jqueryUiDateTimePicker = "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" + +jqueryDayTimeField :: Html () -> Html () -> FormletField sub y UTCTime +jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile + { fpLabel = l , fpTooltip = t } + +parseDate :: String -> Either String Day +parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay . replace '/' '-' + + +-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) +jqueryDayTimeUTCTime :: UTCTime -> String +jqueryDayTimeUTCTime (UTCTime day utcTime) = + let timeOfDay = timeToTimeOfDay utcTime + in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay + where + showTimeOfDay (TimeOfDay hour minute _) = + let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") + in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm + +jqueryDayTimeFieldProfile :: FieldProfile sub y UTCTime +jqueryDayTimeFieldProfile = FieldProfile + { fpParse = parseUTCTime + , fpRender = jqueryDayTimeUTCTime + , fpHamlet = \name val isReq -> [$hamlet| +%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScriptRemote urlJqueryJs + addScriptRemote urlJqueryUiJs + addScriptRemote jqueryUiDateTimePicker -- needs slashes, dashes are broken + addStylesheetRemote urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); +|] + , fpName = Nothing + , fpLabel = mempty + , fpTooltip = mempty + } + parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = + parseTimeHelper (h1, h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = + let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 + in parseTimeHelper (h1', h2', m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = parseTimeHelper (h1, h2, m1, m2, s1, s2) parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" From 23919956222c43c168a90b7b99ec752de00c8f7b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 21 Jul 2010 08:18:34 +0300 Subject: [PATCH 372/624] URLs are modifiable via IORefs --- Yesod/Form.hs | 29 +++++++++++++---------------- Yesod/Urls.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ Yesod/Widget.hs | 19 ------------------- yesod.cabal | 1 + 4 files changed, 57 insertions(+), 35 deletions(-) create mode 100644 Yesod/Urls.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index afc32b09..d6f08e4e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -101,6 +101,7 @@ import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email import Data.Char (isSpace) +import Yesod.Urls -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -427,9 +428,9 @@ jqueryDayFieldProfile = FieldProfile %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do - addScriptRemote urlJqueryJs - addScriptRemote urlJqueryUiJs - addStylesheetRemote urlJqueryUiCss + getSetting urlJqueryJs >>= addScriptRemote + getSetting urlJqueryUiJs >>= addScriptRemote + getSetting urlJqueryUiCss >>= addStylesheetRemote addJavaScript [$hamlet| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] @@ -460,10 +461,6 @@ parseUTCTime s = Right date -> ifRight (parseTime timeS) (\time -> UTCTime date (timeOfDayToTime time)) --- TODO - integrate with static helpers -jqueryUiDateTimePicker :: String -jqueryUiDateTimePicker = "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" - jqueryDayTimeField :: Html () -> Html () -> FormletField sub y UTCTime jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile { fpLabel = l , fpTooltip = t } @@ -485,23 +482,23 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) = jqueryDayTimeFieldProfile :: FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime + { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpHamlet = \name val isReq -> [$hamlet| %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do - addScriptRemote urlJqueryJs - addScriptRemote urlJqueryUiJs - addScriptRemote jqueryUiDateTimePicker -- needs slashes, dashes are broken - addStylesheetRemote urlJqueryUiCss + getSetting urlJqueryJs >>= addScriptRemote + getSetting urlJqueryUiJs >>= addScriptRemote + getSetting urlJqueryUiDateTimePicker >>= addScriptRemote -- needs slashes, dashes are broken + getSetting urlJqueryUiCss >>= addStylesheetRemote addJavaScript [$hamlet| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] , fpName = Nothing , fpLabel = mempty , fpTooltip = mempty - } + } parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') @@ -893,9 +890,9 @@ jqueryAutocompleteFieldProfile src = FieldProfile %input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \name -> do - addScriptRemote urlJqueryJs - addScriptRemote urlJqueryUiJs - addStylesheetRemote urlJqueryUiCss + getSetting urlJqueryJs >>= addScriptRemote + getSetting urlJqueryUiJs >>= addScriptRemote + getSetting urlJqueryUiCss >>= addStylesheetRemote addJavaScript [$hamlet| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] diff --git a/Yesod/Urls.hs b/Yesod/Urls.hs new file mode 100644 index 00000000..9b7c41c2 --- /dev/null +++ b/Yesod/Urls.hs @@ -0,0 +1,43 @@ +module Yesod.Urls + ( newSetting + , changeSetting + , getSetting + -- * Default library URLs + , urlJqueryJs + , urlJqueryUiJs + , urlJqueryUiCss + , urlJqueryUiDateTimePicker + ) where + +import Data.IORef (IORef, newIORef, writeIORef, readIORef) +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.IO.Class + +newSetting :: a -> IORef a +newSetting = unsafePerformIO . newIORef + +changeSetting :: MonadIO m => IORef a -> a -> m () +changeSetting x = liftIO . writeIORef x + +getSetting :: MonadIO m => IORef a -> m a +getSetting = liftIO . readIORef + +-- | The Google-hosted jQuery 1.4.2 file. +urlJqueryJs :: IORef String +urlJqueryJs = newSetting + "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + +-- | The Google-hosted jQuery UI 1.8.1 javascript file. +urlJqueryUiJs :: IORef String +urlJqueryUiJs = newSetting + "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + +-- | The Google-hosted jQuery UI 1.8.1 CSS file with cupertino theme. +urlJqueryUiCss :: IORef String +urlJqueryUiCss = newSetting + "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + +-- TODO - integrate with static helpers +urlJqueryUiDateTimePicker :: IORef String +urlJqueryUiDateTimePicker = newSetting + "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index ef7491ef..7630f15d 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -27,10 +27,6 @@ module Yesod.Widget -- * Manipulating , wrapWidget , extractBody - -- * Default library URLs - , urlJqueryJs - , urlJqueryUiJs - , urlJqueryUiCss ) where import Data.List (nub) @@ -204,18 +200,3 @@ extractBody (GWidget w) = GWidget $ mapWriterT (fmap go) w where go ((), Body h) = (h, Body mempty) - --- | The Google-hosted jQuery 1.4.2 file. -urlJqueryJs :: String -urlJqueryJs = - "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - --- | The Google-hosted jQuery UI 1.8.1 javascript file. -urlJqueryUiJs :: String -urlJqueryUiJs = - "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - --- | The Google-hosted jQuery UI 1.8.1 CSS file with cupertino theme. -urlJqueryUiCss :: String -urlJqueryUiCss = - "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" diff --git a/yesod.cabal b/yesod.cabal index 25372373..03ecbb55 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,6 +53,7 @@ library Yesod.Handler Yesod.Internal Yesod.Json + Yesod.Urls Yesod.Request Yesod.Widget Yesod.Yesod From 4b2b14e3acbfc79f1c8c67b2b9e7d5a48a59552a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 21 Jul 2010 09:41:25 +0300 Subject: [PATCH 373/624] Added intInput --- Yesod/Form.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index d6f08e4e..625548cc 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -72,6 +72,7 @@ module Yesod.Form -- * Pre-built inputs , stringInput , maybeStringInput + , intInput , boolInput , dayInput , maybeDayInput @@ -308,6 +309,13 @@ instance ToFormField String where instance ToFormField (Maybe String) where toFormField = maybeStringField +intInput :: Integral i => String -> FormInput sub master i +intInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper intFieldProfile + { fpName = Just n + } Nothing + intField :: Integral i => Html () -> Html () -> FormletField sub y i intField l t = requiredFieldHelper intFieldProfile { fpLabel = l From 71c835569844caa89ad4ff7cf32eab8bc61325e3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 22 Jul 2010 07:25:06 +0300 Subject: [PATCH 374/624] URL settings in Yesod typeclass --- Yesod/Form.hs | 56 +++++++++++++++++++++++++++++-------------------- Yesod/Urls.hs | 43 ------------------------------------- Yesod/Widget.hs | 8 +++++++ Yesod/Yesod.hs | 20 ++++++++++++++++++ yesod.cabal | 1 - 5 files changed, 61 insertions(+), 67 deletions(-) delete mode 100644 Yesod/Urls.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 625548cc..b9323ff9 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -102,7 +102,7 @@ import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email import Data.Char (isSpace) -import Yesod.Urls +import Yesod.Yesod (Yesod (..)) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -413,19 +413,19 @@ instance ToFormField Day where instance ToFormField (Maybe Day) where toFormField = maybeDayField -jqueryDayField :: Html () -> Html () -> FormletField sub y Day +jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile { fpLabel = l , fpTooltip = t } -maybeJqueryDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) +maybeJqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe Day) maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile { fpLabel = l , fpTooltip = t } -jqueryDayFieldProfile :: FieldProfile sub y Day +jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day jqueryDayFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") @@ -436,9 +436,9 @@ jqueryDayFieldProfile = FieldProfile %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do - getSetting urlJqueryJs >>= addScriptRemote - getSetting urlJqueryUiJs >>= addScriptRemote - getSetting urlJqueryUiCss >>= addStylesheetRemote + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss addJavaScript [$hamlet| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] @@ -469,7 +469,7 @@ parseUTCTime s = Right date -> ifRight (parseTime timeS) (\time -> UTCTime date (timeOfDayToTime time)) -jqueryDayTimeField :: Html () -> Html () -> FormletField sub y UTCTime +jqueryDayTimeField :: Yesod y => Html () -> Html () -> FormletField sub y UTCTime jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile { fpLabel = l , fpTooltip = t } @@ -488,7 +488,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) = let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm -jqueryDayTimeFieldProfile :: FieldProfile sub y UTCTime +jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime @@ -496,10 +496,10 @@ jqueryDayTimeFieldProfile = FieldProfile %input#$name$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do - getSetting urlJqueryJs >>= addScriptRemote - getSetting urlJqueryUiJs >>= addScriptRemote - getSetting urlJqueryUiDateTimePicker >>= addScriptRemote -- needs slashes, dashes are broken - getSetting urlJqueryUiCss >>= addStylesheetRemote + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addScript' urlJqueryUiDateTimePicker + addStylesheet' urlJqueryUiCss addJavaScript [$hamlet| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] @@ -616,19 +616,19 @@ instance ToFormField (Maybe (Html ())) where type Html' = Html () -nicHtmlField :: Html () -> Html () -> FormletField sub y (Html ()) +nicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Html ()) nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile { fpLabel = label , fpTooltip = tooltip } -maybeNicHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) +maybeNicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe (Html ())) maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile { fpLabel = label , fpTooltip = tooltip } -nicHtmlFieldProfile :: FieldProfile sub y (Html ()) +nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ()) nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml @@ -636,7 +636,7 @@ nicHtmlFieldProfile = FieldProfile %textarea.html#$name$!name=$name$ $val$ |] , fpWidget = \name -> do - addScriptRemote "http://js.nicedit.com/nicEdit-latest.js" + addScript' urlNicEdit addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] , fpName = Nothing , fpLabel = mempty @@ -874,7 +874,7 @@ toLabel (x:rest) = toUpper x : go rest | isUpper c = ' ' : c : go cs | otherwise = c : go cs -jqueryAutocompleteField :: +jqueryAutocompleteField :: Yesod y => Route y -> Html () -> Html () -> FormletField sub y String jqueryAutocompleteField src l t = requiredFieldHelper $ (jqueryAutocompleteFieldProfile src) @@ -882,7 +882,7 @@ jqueryAutocompleteField src l t = , fpTooltip = t } -maybeJqueryAutocompleteField :: +maybeJqueryAutocompleteField :: Yesod y => Route y -> Html () -> Html () -> FormletField sub y (Maybe String) maybeJqueryAutocompleteField src l t = optionalFieldHelper $ (jqueryAutocompleteFieldProfile src) @@ -890,7 +890,7 @@ maybeJqueryAutocompleteField src l t = , fpTooltip = t } -jqueryAutocompleteFieldProfile :: Route y -> FieldProfile sub y String +jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id @@ -898,9 +898,9 @@ jqueryAutocompleteFieldProfile src = FieldProfile %input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \name -> do - getSetting urlJqueryJs >>= addScriptRemote - getSetting urlJqueryUiJs >>= addScriptRemote - getSetting urlJqueryUiCss >>= addStylesheetRemote + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss addJavaScript [$hamlet| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] @@ -942,3 +942,13 @@ emailInput n = requiredFieldHelper emailFieldProfile { fpName = Just n } Nothing + +addScript' :: (y -> Either (Route y) String) -> GWidget sub y () +addScript' f = do + y <- liftHandler getYesod + addScriptEither $ f y + +addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () +addStylesheet' f = do + y <- liftHandler getYesod + addStylesheetEither $ f y diff --git a/Yesod/Urls.hs b/Yesod/Urls.hs deleted file mode 100644 index 9b7c41c2..00000000 --- a/Yesod/Urls.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Yesod.Urls - ( newSetting - , changeSetting - , getSetting - -- * Default library URLs - , urlJqueryJs - , urlJqueryUiJs - , urlJqueryUiCss - , urlJqueryUiDateTimePicker - ) where - -import Data.IORef (IORef, newIORef, writeIORef, readIORef) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.IO.Class - -newSetting :: a -> IORef a -newSetting = unsafePerformIO . newIORef - -changeSetting :: MonadIO m => IORef a -> a -> m () -changeSetting x = liftIO . writeIORef x - -getSetting :: MonadIO m => IORef a -> m a -getSetting = liftIO . readIORef - --- | The Google-hosted jQuery 1.4.2 file. -urlJqueryJs :: IORef String -urlJqueryJs = newSetting - "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - --- | The Google-hosted jQuery UI 1.8.1 javascript file. -urlJqueryUiJs :: IORef String -urlJqueryUiJs = newSetting - "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - --- | The Google-hosted jQuery UI 1.8.1 CSS file with cupertino theme. -urlJqueryUiCss :: IORef String -urlJqueryUiCss = newSetting - "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - --- TODO - integrate with static helpers -urlJqueryUiDateTimePicker :: IORef String -urlJqueryUiDateTimePicker = newSetting - "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 7630f15d..1737b867 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -19,8 +19,10 @@ module Yesod.Widget , addStyle , addStylesheet , addStylesheetRemote + , addStylesheetEither , addScript , addScriptRemote + , addScriptEither , addHead , addBody , addJavaScript @@ -131,6 +133,12 @@ addStylesheetRemote :: String -> GWidget sub master () addStylesheetRemote = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote +addStylesheetEither :: Either (Route master) String -> GWidget sub master () +addStylesheetEither = either addStylesheet addStylesheetRemote + +addScriptEither :: Either (Route master) String -> GWidget sub master () +addScriptEither = either addScript addScriptRemote + -- | Link to the specified local script. addScript :: Route master -> GWidget sub master () addScript = GWidget . lift . lift . tell . toUnique . Script . Local diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9b800dfa..3cba2a6f 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -118,6 +118,26 @@ class Eq (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing + -- | The jQuery Javascript file. + urlJqueryJs :: a -> Either (Route a) String + urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + + -- | The jQuery UI 1.8.1 Javascript file. + urlJqueryUiJs :: a -> Either (Route a) String + urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + + -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme. + urlJqueryUiCss :: a -> Either (Route a) String + urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + + -- | jQuery UI time picker add-on. + urlJqueryUiDateTimePicker :: a -> Either (Route a) String + urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" + + -- | NIC Editor. + urlNicEdit :: a -> Either (Route a) String + urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) diff --git a/yesod.cabal b/yesod.cabal index 03ecbb55..25372373 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,7 +53,6 @@ library Yesod.Handler Yesod.Internal Yesod.Json - Yesod.Urls Yesod.Request Yesod.Widget Yesod.Yesod From 0db163aea86ff923b9ab5ca5fca0aa840a8fb127 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 22 Jul 2010 12:27:26 +0300 Subject: [PATCH 375/624] ToForm and ToFormField take master site param --- Yesod/Dispatch.hs | 10 +++------- Yesod/Form.hs | 42 ++++++++++++++++++++++-------------------- Yesod/Helpers/Crud.hs | 24 +++++++++++++++--------- 3 files changed, 40 insertions(+), 36 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0e3dfe36..bc9b64d2 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -93,7 +93,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False -- executable by itself, but instead provides functionality to -- be embedded in other sites. mkYesodSub :: String -- ^ name of the argument datatype - -> [(String, [Name])] + -> Cxt -> [Resource] -> Q [Dec] mkYesodSub name clazzes = @@ -130,7 +130,7 @@ typeHelper = mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument - -> [(String, [Name])] -- ^ classes + -> Cxt -- ^ classes -> Bool -- ^ is subsite? -> [Resource] -> Q ([Dec], [Dec]) @@ -138,10 +138,6 @@ mkYesodGeneral name args clazzes isSub res = do let name' = mkName name args' = map mkName args arg = foldl AppT (ConT name') $ map VarT args' - let clazzes' = map (\(x, y) -> ClassP x [typeHelper y]) - $ concatMap (\(x, y) -> zip y $ repeat x) - $ compact - $ map (\x -> (x, [])) ("master" : args) ++ clazzes th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites w' <- createRoutes th let routesName = mkName $ name ++ "Route" @@ -166,7 +162,7 @@ mkYesodGeneral name args clazzes isSub res = do let site' = site `AppE` dispatch `AppE` render `AppE` parse let (ctx, ytyp, yfunc) = if isSub - then (clazzes', ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") + then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") else ([], ConT ''YesodSite `AppT` arg, "getSite") let y = InstanceD ctx ytyp [ FunD (mkName yfunc) [Clause [] (NormalB site') []] diff --git a/Yesod/Form.hs b/Yesod/Form.hs index b9323ff9..b75cf36d 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types @@ -204,9 +205,9 @@ fieldsToTable = mapM_ go %td.errors $err$ |] -class ToForm a where +class ToForm a y where toForm :: Maybe a -> Form sub y a -class ToFormField a where +class ToFormField a y where toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a -- | Create a required field (ie, one that cannot be blank) from a @@ -304,9 +305,9 @@ stringFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField String where +instance ToFormField String y where toFormField = stringField -instance ToFormField (Maybe String) where +instance ToFormField (Maybe String) y where toFormField = maybeStringField intInput :: Integral i => String -> FormInput sub master i @@ -346,13 +347,13 @@ intFieldProfile = FieldProfile readMayI s = case reads s of (x, _):_ -> Just $ fromInteger x [] -> Nothing -instance ToFormField Int where +instance ToFormField Int y where toFormField = intField -instance ToFormField (Maybe Int) where +instance ToFormField (Maybe Int) y where toFormField = maybeIntField -instance ToFormField Int64 where +instance ToFormField Int64 y where toFormField = intField -instance ToFormField (Maybe Int64) where +instance ToFormField (Maybe Int64) y where toFormField = maybeIntField doubleField :: Html () -> Html () -> FormletField sub y Double @@ -379,9 +380,9 @@ doubleFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField Double where +instance ToFormField Double y where toFormField = doubleField -instance ToFormField (Maybe Double) where +instance ToFormField (Maybe Double) y where toFormField = maybeDoubleField dayField :: Html () -> Html () -> FormletField sub y Day @@ -408,9 +409,9 @@ dayFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField Day where +instance ToFormField Day y where toFormField = dayField -instance ToFormField (Maybe Day) where +instance ToFormField (Maybe Day) y where toFormField = maybeDayField jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day @@ -556,9 +557,9 @@ timeFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField TimeOfDay where +instance ToFormField TimeOfDay y where toFormField = timeField -instance ToFormField (Maybe TimeOfDay) where +instance ToFormField (Maybe TimeOfDay) y where toFormField = maybeTimeField boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool @@ -582,7 +583,7 @@ boolField label tooltip orig = GForm $ \env _ -> do _ -> Nothing } return (res, [fi], UrlEncoded) -instance ToFormField Bool where +instance ToFormField Bool y where toFormField = boolField htmlField :: Html () -> Html () -> FormletField sub y (Html ()) @@ -609,9 +610,9 @@ htmlFieldProfile = FieldProfile , fpLabel = mempty , fpTooltip = mempty } -instance ToFormField (Html ()) where +instance ToFormField (Html ()) y where toFormField = htmlField -instance ToFormField (Maybe (Html ())) where +instance ToFormField (Maybe (Html ())) y where toFormField = maybeHtmlField type Html' = Html () @@ -816,8 +817,8 @@ share2 f g a = do return $ f' ++ g' -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: [EntityDef] -> Q [Dec] -mkToForm = mapM derive +mkToForm :: String -> [EntityDef] -> Q [Dec] +mkToForm name = mapM derive where getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z getTFF' [] = Nothing @@ -853,7 +854,8 @@ mkToForm = mapM derive (NormalB $ go_ $ zip cols xs') [] return $ InstanceD [] (ConT ''ToForm - `AppT` ConT (mkName $ entityName t)) + `AppT` ConT (mkName $ entityName t) + `AppT` ConT (mkName name)) [FunD (mkName "toForm") [c1, c2]] go ap just' string' mfx ftt a = let x = foldl (ap' ap) just' $ map (go' string') a diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index e3d718c8..446526c1 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -18,9 +18,10 @@ import Yesod.Handler import Text.Hamlet import Yesod.Form import Data.Monoid (mempty) +import Language.Haskell.TH.Syntax -- | An entity which can be displayed by the Crud subsite. -class ToForm a => Item a where +class Item a where -- | The title of an entity, to be displayed in the list of all entities. itemTitle :: a -> String @@ -36,9 +37,10 @@ data Crud master item = Crud } mkYesodSub "Crud master item" - [ ("master", [''Yesod]) - , ("item", [''Item]) - , ("Key item", [''SinglePiece]) + [ ClassP ''Yesod [VarT $ mkName "master"] + , ClassP ''Item [VarT $ mkName "item"] + , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] + , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] ] [$parseRoutes| / CrudListR GET /add CrudAddR GET POST @@ -62,21 +64,24 @@ getCrudListR = do %a!href=@toMaster.CrudAddR@ Add new item |] -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + ToForm item master) => GHandler (Crud master item) master RepHtml getCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) False -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), + ToForm item master) => GHandler (Crud master item) master RepHtml postCrudAddR = crudHelper "Add new" (Nothing :: Maybe (Key item, item)) True -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + ToForm item master) => String -> GHandler (Crud master item) master RepHtml getCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -87,7 +92,8 @@ getCrudEditR s = do (Just (itemId, item)) False -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item)) +postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), + ToForm item master) => String -> GHandler (Crud master item) master RepHtml postCrudEditR s = do itemId <- maybe notFound return $ itemReadId s @@ -128,7 +134,7 @@ itemReadId :: SinglePiece x => String -> Maybe x itemReadId = either (const Nothing) Just . fromSinglePiece crudHelper - :: (Item a, Yesod master, SinglePiece (Key a)) + :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) => String -> Maybe (Key a, a) -> Bool -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do From e6dc40d58284b7de33115b6e8540a36cff56e97a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 22 Jul 2010 13:03:07 +0300 Subject: [PATCH 376/624] Fixed auth module --- Yesod/Form.hs | 10 ---------- Yesod/Helpers/Auth.hs | 6 +++++- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index b75cf36d..fcb32fae 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -79,7 +79,6 @@ module Yesod.Form , maybeDayInput , emailInput -- * Template Haskell - , share2 , mkToForm ) where @@ -807,15 +806,6 @@ runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f --- | This function allows two different monadic functions to share the same --- input and have their results concatenated. This is particularly useful for --- allowing 'mkToForm' to share its input with mkPersist. -share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] -share2 f g a = do - f' <- f a - g' <- g a - return $ f' ++ g' - -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. mkToForm :: String -> [EntityDef] -> Q [Dec] mkToForm name = mapM derive diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d8837345..d0b71450 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -51,6 +51,7 @@ import System.IO import Control.Monad.Attempt import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object +import Language.Haskell.TH.Syntax -- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'. class Yesod master => YesodAuth master where @@ -143,7 +144,10 @@ maybeCreds = do (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth" [("master", [''YesodAuth])] [$parseRoutes| +mkYesodSub "Auth" + [ ClassP ''YesodAuth [VarT $ mkName "master"] + ] + [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET From 55e477110478c6c3f055684c82871882a1cf1d29 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 24 Jul 2010 22:34:08 +0300 Subject: [PATCH 377/624] Fixed bug in boolInput --- Yesod/Form.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index fcb32fae..5ce22c39 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -742,7 +742,7 @@ maybeStringInput n = boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ \env _ -> return - (FormSuccess $ isJust $ lookup n env, return $ addBody [$hamlet| + (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| %input#$n$!type=checkbox!name=$n$ |], UrlEncoded) From 1c6f8fb46cbc5e5148e280644014a29a7d8223be Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 12:01:18 +0300 Subject: [PATCH 378/624] FormFieldSettings --- Yesod/Form.hs | 343 ++++++++++++++++++++----------------------------- hellowidget.hs | 9 +- yesod.cabal | 4 +- 3 files changed, 145 insertions(+), 211 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 5ce22c39..ec4a0911 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -44,6 +44,7 @@ module Yesod.Form , timeFieldProfile , htmlFieldProfile , emailFieldProfile + , FormFieldSettings (..) -- * Pre-built fields , stringField , maybeStringField @@ -88,7 +89,7 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (UTCTime(..), Day, TimeOfDay(..)) import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) @@ -160,6 +161,7 @@ data FieldInfo sub y = FieldInfo { fiLabel :: Html () , fiTooltip :: Html () , fiIdent :: String + , fiName :: String , fiInput :: GWidget sub y () , fiErrors :: Maybe (Html ()) } @@ -207,14 +209,24 @@ fieldsToTable = mapM_ go class ToForm a y where toForm :: Maybe a -> Form sub y a class ToFormField a y where - toFormField :: Html () -> Html () -> Maybe a -> FormField sub y a + toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html () + , ffsTooltip :: Html () + , ffsId :: Maybe String + , ffsName :: Maybe String + } -- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper :: FieldProfile sub y a -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig = +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a +requiredFieldHelper + (FieldProfile parse render mkXml w) + (FormFieldSettings label tooltip name' theId') orig = GForm $ \env _ -> do name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' let (res, val) = if null env then (FormMissing, maybe "" render orig) @@ -228,8 +240,9 @@ requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name - , fiInput = w name >> addBody (mkXml (string name) (string val) True) + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -238,12 +251,14 @@ requiredFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> Maybe (Maybe a) - -> FormField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig' = +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) +optionalFieldHelper + (FieldProfile parse render mkXml w) + (FormFieldSettings label tooltip name' theId') orig' = GForm $ \env _ -> do let orig = join orig' name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' let (res, val) = if null env then (FormSuccess Nothing, maybe "" render orig) @@ -257,8 +272,9 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name - , fiInput = w name >> addBody (mkXml (string name) (string val) False) + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -271,38 +287,26 @@ optionalFieldHelper (FieldProfile parse render mkXml w name' label tooltip) orig data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String - , fpHamlet :: Html () -> Html () -> Bool -> Hamlet (Route y) + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) , fpWidget :: String -> GWidget sub y () - , fpName :: Maybe String - , fpLabel :: Html () - , fpTooltip :: Html () } --------------------- Begin prebuilt forms -stringField :: Html () -> Html () -> FormletField sub y String -stringField label tooltip = requiredFieldHelper stringFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +stringField :: FormFieldSettings -> FormletField sub y String +stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: Html () -> Html () -> FormletField sub y (Maybe String) -maybeStringField label tooltip = optionalFieldHelper stringFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField = optionalFieldHelper stringFieldProfile stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=text!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField String y where toFormField = stringField @@ -312,34 +316,22 @@ instance ToFormField (Maybe String) y where intInput :: Integral i => String -> FormInput sub master i intInput n = mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper intFieldProfile (nameSettings n) Nothing -intField :: Integral i => Html () -> Html () -> FormletField sub y i -intField l t = requiredFieldHelper intFieldProfile - { fpLabel = l - , fpTooltip = t - } +intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField = requiredFieldHelper intFieldProfile -maybeIntField :: Integral i => - Html () -> Html () -> FormletField sub y (Maybe i) -maybeIntField l t = optionalFieldHelper intFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField = optionalFieldHelper intFieldProfile intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } where showI x = show (fromIntegral x :: Integer) @@ -355,75 +347,51 @@ instance ToFormField Int64 y where instance ToFormField (Maybe Int64) y where toFormField = maybeIntField -doubleField :: Html () -> Html () -> FormletField sub y Double -doubleField l t = requiredFieldHelper doubleFieldProfile - { fpLabel = l - , fpTooltip = t - } +doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: Html () -> Html () -> FormletField sub y (Maybe Double) -maybeDoubleField l t = optionalFieldHelper doubleFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField = optionalFieldHelper doubleFieldProfile doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=number!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] , fpWidget = \_name -> return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField Double y where toFormField = doubleField instance ToFormField (Maybe Double) y where toFormField = maybeDoubleField -dayField :: Html () -> Html () -> FormletField sub y Day -dayField l t = requiredFieldHelper dayFieldProfile - { fpLabel = l - , fpTooltip = t - } +dayField :: FormFieldSettings -> FormletField sub y Day +dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: Html () -> Html () -> FormletField sub y (Maybe Day) -maybeDayField l t = optionalFieldHelper dayFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField = optionalFieldHelper dayFieldProfile dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField Day y where toFormField = dayField instance ToFormField (Maybe Day) y where toFormField = maybeDayField -jqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y Day -jqueryDayField l t = requiredFieldHelper jqueryDayFieldProfile - { fpLabel = l - , fpTooltip = t - } +jqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y Day +jqueryDayField = requiredFieldHelper jqueryDayFieldProfile -maybeJqueryDayField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe Day) -maybeJqueryDayField l t = optionalFieldHelper jqueryDayFieldProfile - { fpLabel = l - , fpTooltip = t - } +maybeJqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe Day) +maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day jqueryDayFieldProfile = FieldProfile @@ -432,8 +400,8 @@ jqueryDayFieldProfile = FieldProfile Right . readMay , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -442,9 +410,6 @@ jqueryDayFieldProfile = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } -- | Replaces all instances of a value in a list by another value. @@ -469,9 +434,8 @@ parseUTCTime s = Right date -> ifRight (parseTime timeS) (\time -> UTCTime date (timeOfDayToTime time)) -jqueryDayTimeField :: Yesod y => Html () -> Html () -> FormletField sub y UTCTime -jqueryDayTimeField l t = requiredFieldHelper jqueryDayTimeFieldProfile - { fpLabel = l , fpTooltip = t } +jqueryDayTimeField :: Yesod y => FormFieldSettings -> FormletField sub y UTCTime +jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile parseDate :: String -> Either String Day parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right @@ -492,8 +456,8 @@ jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=date!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -503,9 +467,6 @@ jqueryDayTimeFieldProfile = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } parseTime :: String -> Either String TimeOfDay @@ -532,38 +493,32 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2) m = read [m1, m2] s = fromInteger $ read [s1, s2] -timeField :: Html () -> Html () -> FormletField sub y TimeOfDay -timeField label tooltip = requiredFieldHelper timeFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: Html () -> Html () -> FormletField sub y (Maybe TimeOfDay) -maybeTimeField label tooltip = optionalFieldHelper timeFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField = optionalFieldHelper timeFieldProfile timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField TimeOfDay y where toFormField = timeField instance ToFormField (Maybe TimeOfDay) y where toFormField = maybeTimeField -boolField :: Html () -> Html () -> Maybe Bool -> FormField sub y Bool -boolField label tooltip orig = GForm $ \env _ -> do - name <- newFormIdent +boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool +boolField ffs orig = GForm $ \env _ -> do + let label = ffsLabel ffs + tooltip = ffsTooltip ffs + name <- maybe newFormIdent return $ ffsName ffs + theId <- maybe newFormIdent return $ ffsId ffs let (res, val) = if null env then (FormMissing, fromMaybe False orig) @@ -573,9 +528,10 @@ boolField label tooltip orig = GForm $ \env _ -> do let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = name + , fiIdent = theId + , fiName = name , fiInput = addBody [$hamlet| -%input#$name$!type=checkbox!name=$name$!:val:checked +%input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -585,29 +541,20 @@ boolField label tooltip orig = GForm $ \env _ -> do instance ToFormField Bool y where toFormField = boolField -htmlField :: Html () -> Html () -> FormletField sub y (Html ()) -htmlField label tooltip = requiredFieldHelper htmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +htmlField :: FormFieldSettings -> FormletField sub y (Html ()) +htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: Html () -> Html () -> FormletField sub y (Maybe (Html ())) -maybeHtmlField label tooltip = optionalFieldHelper htmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeHtmlField = optionalFieldHelper htmlFieldProfile htmlFieldProfile :: FieldProfile sub y (Html ()) htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$name$!name=$name$ $val$ + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } instance ToFormField (Html ()) y where toFormField = htmlField @@ -616,31 +563,22 @@ instance ToFormField (Maybe (Html ())) y where type Html' = Html () -nicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Html ()) -nicHtmlField label tooltip = requiredFieldHelper nicHtmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +nicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Html ()) +nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField :: Yesod y => Html () -> Html () -> FormletField sub y (Maybe (Html ())) -maybeNicHtmlField label tooltip = optionalFieldHelper nicHtmlFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeNicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ()) nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \name val _isReq -> [$hamlet| -%textarea.html#$name$!name=$name$ $val$ + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ |] , fpWidget = \name -> do addScript' urlNicEdit addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } readMay :: Read a => String -> Maybe a @@ -678,6 +616,7 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do { fiLabel = label , fiTooltip = tooltip , fiIdent = i + , fiName = i , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -715,6 +654,7 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do { fiLabel = label , fiTooltip = tooltip , fiIdent = i + , fiName = i , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -729,16 +669,12 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do stringInput :: String -> FormInput sub master String stringInput n = mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper stringFieldProfile (nameSettings n) Nothing maybeStringInput :: String -> FormInput sub master (Maybe String) maybeStringInput n = mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile - { fpName = Just n - } Nothing + optionalFieldHelper stringFieldProfile (nameSettings n) Nothing boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ \env _ -> return @@ -749,16 +685,12 @@ boolInput n = GForm $ \env _ -> return dayInput :: String -> FormInput sub master Day dayInput n = mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper dayFieldProfile (nameSettings n) Nothing maybeDayInput :: String -> FormInput sub master (Maybe Day) maybeDayInput n = mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile - { fpName = Just n - } Nothing + optionalFieldHelper dayFieldProfile (nameSettings n) Nothing --------------------- End prebuilt inputs @@ -822,9 +754,17 @@ mkToForm name = mapM derive getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x getTooltip' (_:x) = getTooltip' x getTooltip' [] = Nothing + getId (_, _, z) = fromMaybe "" $ getId' z + getId' (('i':'d':'=':x):_) = Just x + getId' (_:x) = getId' x + getId' [] = Nothing + getName (_, _, z) = fromMaybe "" $ getName' z + getName' (('n':'a':'m':'e':'=':x):_) = Just x + getName' (_:x) = getName' x + getName' [] = Nothing derive :: EntityDef -> Q Dec derive t = do - let cols = map ((getLabel &&& getTooltip) &&& getTFF) $ entityColumns t + let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t ap <- [|(<*>)|] just <- [|pure|] nothing <- [|Nothing|] @@ -832,7 +772,10 @@ mkToForm name = mapM derive string' <- [|string|] mfx <- [|mapFormXml|] ftt <- [|fieldsToTable|] - let go_ = go ap just' string' mfx ftt + ffs' <- [|FormFieldSettings|] + let stm "" = nothing + stm x = just `AppE` LitE (StringL x) + let go_ = go ap just' ffs' stm string' mfx ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go_ $ zip cols $ map (const nothing) cols) @@ -847,14 +790,18 @@ mkToForm name = mapM derive `AppT` ConT (mkName $ entityName t) `AppT` ConT (mkName name)) [FunD (mkName "toForm") [c1, c2]] - go ap just' string' mfx ftt a = - let x = foldl (ap' ap) just' $ map (go' string') a + go ap just' ffs' stm string' mfx ftt a = + let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a in mfx `AppE` ftt `AppE` x - go' string' (((label, tooltip), tff), ex) = + go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip) - in VarE (mkName tff) `AppE` label' - `AppE` tooltip' `AppE` ex + ffs = ffs' `AppE` + label' `AppE` + tooltip' `AppE` + (stm theId) `AppE` + (stm name) + in VarE (mkName tff) `AppE` ffs `AppE` ex ap' ap x y = InfixE (Just x) ap (Just y) toLabel :: String -> String @@ -867,27 +814,20 @@ toLabel (x:rest) = toUpper x : go rest | otherwise = c : go cs jqueryAutocompleteField :: Yesod y => - Route y -> Html () -> Html () -> FormletField sub y String -jqueryAutocompleteField src l t = - requiredFieldHelper $ (jqueryAutocompleteFieldProfile src) - { fpLabel = l - , fpTooltip = t - } + Route y -> FormFieldSettings -> FormletField sub y String +jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile maybeJqueryAutocompleteField :: Yesod y => - Route y -> Html () -> Html () -> FormletField sub y (Maybe String) -maybeJqueryAutocompleteField src l t = - optionalFieldHelper $ (jqueryAutocompleteFieldProfile src) - { fpLabel = l - , fpTooltip = t - } + Route y -> FormFieldSettings -> FormletField sub y (Maybe String) +maybeJqueryAutocompleteField src = + optionalFieldHelper $ jqueryAutocompleteFieldProfile src jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input.autocomplete#$name$!name=$name$!type=text!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] , fpWidget = \name -> do addScript' urlJqueryJs @@ -896,9 +836,6 @@ jqueryAutocompleteFieldProfile src = FieldProfile addJavaScript [$hamlet| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } emailFieldProfile :: FieldProfile s y String @@ -907,33 +844,25 @@ emailFieldProfile = FieldProfile then Right s else Left "Invalid e-mail address" , fpRender = id - , fpHamlet = \name val isReq -> [$hamlet| -%input#$name$!name=$name$!type=email!:isReq:required!value=$val$ + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] , fpWidget = const $ return () - , fpName = Nothing - , fpLabel = mempty - , fpTooltip = mempty } -emailField :: Html () -> Html () -> FormletField sub y String -emailField label tooltip = requiredFieldHelper emailFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +emailField :: FormFieldSettings -> FormletField sub y String +emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: Html () -> Html () -> FormletField sub y (Maybe String) -maybeEmailField label tooltip = optionalFieldHelper emailFieldProfile - { fpLabel = label - , fpTooltip = tooltip - } +maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField = optionalFieldHelper emailFieldProfile emailInput :: String -> FormInput sub master String emailInput n = mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile - { fpName = Just n - } Nothing + requiredFieldHelper emailFieldProfile (nameSettings n) Nothing + +nameSettings :: String -> FormFieldSettings +nameSettings = FormFieldSettings mempty mempty Nothing . Just addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' f = do diff --git a/hellowidget.hs b/hellowidget.hs index 844a66c5..7afe4641 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} import Yesod import Yesod.Widget import Yesod.Helpers.Static @@ -41,7 +41,12 @@ handleFormR = do <*> intField (string "A number field") (string "some nums") (Just 5) <*> jqueryDayField (string "A day field") (string "") Nothing <*> timeField (string "A time field") (string "") Nothing - <*> boolField (string "A checkbox") (string "") (Just False) + <*> boolField FormFieldSettings + { ffsLabel = "A checkbox" + , ffsTooltip = "" + , ffsId = Nothing + , ffsName = Nothing + } (Just False) <*> jqueryAutocompleteField AutoCompleteR (string "Autocomplete") (string "Try it!") Nothing <*> nicHtmlField (string "HTML") (string "") diff --git a/yesod.cabal b/yesod.cabal index 25372373..6471a351 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,7 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.5 && < 0.6, - hamlet >= 0.4.0 && < 0.5, + hamlet >= 0.4.1 && < 0.5, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, @@ -61,7 +61,7 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - ghc-options: -Wall + ghc-options: -Wall -Werror executable yesod build-depends: parsec >= 2.1 && < 4 From 74e1c8cbf9360ee3be4f504029510927710ac10c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 12:18:57 +0300 Subject: [PATCH 379/624] superclass in mkToForm --- Yesod/Form.hs | 17 +++++++++---- blog2.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+), 5 deletions(-) create mode 100644 blog2.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ec4a0911..2aac29bf 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -89,7 +89,7 @@ import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (UTCTime(..), Day, TimeOfDay(..)) import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) import Data.Monoid (Monoid (..)) @@ -739,8 +739,8 @@ runFormGet f = do runFormGeneric gs [] f -- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: String -> [EntityDef] -> Q [Dec] -mkToForm name = mapM derive +mkToForm :: [EntityDef] -> Q [Dec] +mkToForm = mapM derive where getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z getTFF' [] = Nothing @@ -762,6 +762,8 @@ mkToForm name = mapM derive getName' (('n':'a':'m':'e':'=':x):_) = Just x getName' (_:x) = getName' x getName' [] = Nothing + getSuperclass ('s':'u':'p':'e':'r':'c':'l':'a':'s':'s':'=':s) = Just s + getSuperclass _ = Nothing derive :: EntityDef -> Q Dec derive t = do let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t @@ -786,9 +788,14 @@ mkToForm name = mapM derive $ map VarP xs]] (NormalB $ go_ $ zip cols xs') [] - return $ InstanceD [] (ConT ''ToForm + let y = mkName "y" + let ctx = map (\x -> ClassP (mkName x) [VarT y]) + $ mapMaybe getSuperclass + $ concatMap (\(_, _, z) -> z) + $ entityColumns t + return $ InstanceD ctx ( ConT ''ToForm `AppT` ConT (mkName $ entityName t) - `AppT` ConT (mkName name)) + `AppT` VarT y) [FunD (mkName "toForm") [c1, c2]] go ap just' ffs' stm string' mfx ftt a = let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a diff --git a/blog2.hs b/blog2.hs new file mode 100644 index 00000000..7c46e706 --- /dev/null +++ b/blog2.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +import Yesod +import Yesod.Helpers.Crud +import Database.Persist.Sqlite +import Database.Persist.TH +import Data.Time (Day) + +share2 mkToForm mkPersist [$persist| +Entry + title String id=thetitle + day Day Desc toFormField=jqueryDayField name=day superclass=Yesod + content Html' toFormField=nicHtmlField + deriving +|] + +instance Item Entry where + itemTitle = entryTitle + +data Blog = Blog { pool :: Pool Connection } + +type EntryCrud = Crud Blog Entry + +mkYesod "Blog" [$parseRoutes| +/ RootR GET +/entry/#EntryId EntryR GET +/admin AdminR EntryCrud defaultCrud +|] + +instance Yesod Blog where + approot _ = "http://localhost:3000" + +instance YesodPersist Blog where + type YesodDB Blog = SqliteReader + runDB db = fmap pool getYesod>>= runSqlite db + +getRootR = do + entries <- runDB $ selectList [] [EntryDayDesc] 0 0 + applyLayoutW $ do + setTitle $ string "Yesod Blog Tutorial Homepage" + addBody [$hamlet| +%h1 Archive +%ul + $forall entries entry + %li + %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ +%p + %a!href=@AdminR.CrudListR@ Admin +|] + +getEntryR entryid = do + entry <- runDB $ get404 entryid + applyLayoutW $ do + setTitle $ string $ entryTitle entry + addBody [$hamlet| +%h1 $entryTitle.entry$ +%h2 $show.entryDay.entry$ +$entryContent.entry$ +|] + +withBlog f = withSqlite ":memory:" 8 $ \p -> do + flip runSqlite p $ do + initialize (undefined :: Entry) + f $ Blog p + +main = withBlog $ basicHandler 3000 From 50fa02953e0f715713fbbd0506183ae578a8466d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 12:47:42 +0300 Subject: [PATCH 380/624] Some convenience functions and bugfixes --- Yesod/Form.hs | 43 +++++++++++++++++++++++++++---------------- 1 file changed, 27 insertions(+), 16 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 2aac29bf..40a75e0c 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -45,6 +45,7 @@ module Yesod.Form , htmlFieldProfile , emailFieldProfile , FormFieldSettings (..) + , labelSettings -- * Pre-built fields , stringField , maybeStringField @@ -587,12 +588,15 @@ readMay s = case reads s of [] -> Nothing selectField :: Eq x => [(x, String)] - -> Html () -> Html () + -> FormFieldSettings -> Maybe x -> FormField sub master x -selectField pairs label tooltip initial = GForm $ \env _ -> do - i <- newFormIdent +selectField pairs ffs initial = GForm $ \env _ -> do + let label = ffsLabel ffs + tooltip = ffsTooltip ffs + theId <- maybe newFormIdent return $ ffsId ffs + name <- maybe newFormIdent return $ ffsName ffs let pairs' = zip [1 :: Int ..] pairs - let res = case lookup i env of + let res = case lookup name env of Nothing -> FormMissing Just "none" -> FormFailure ["Field is required"] Just x -> @@ -607,7 +611,7 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do FormSuccess y -> x == y _ -> Just x == initial let input = [$hamlet| -%select#$i$!name=$i$ +%select#$theId$!name=$name$ %option!value=none $forall pairs' pair %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ @@ -615,8 +619,8 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = i - , fiName = i + , fiIdent = theId + , fiName = name , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -625,12 +629,16 @@ selectField pairs label tooltip initial = GForm $ \env _ -> do return (res, [fi], UrlEncoded) maybeSelectField :: Eq x => [(x, String)] - -> Html () -> Html () - -> Maybe x -> FormField sub master (Maybe x) -maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do - i <- newFormIdent + -> FormFieldSettings + -> FormletField sub master (Maybe x) +maybeSelectField pairs ffs initial' = GForm $ \env _ -> do + let initial = join initial' + label = ffsLabel ffs + tooltip = ffsTooltip ffs + theId <- maybe newFormIdent return $ ffsId ffs + name <- maybe newFormIdent return $ ffsName ffs let pairs' = zip [1 :: Int ..] pairs - let res = case lookup i env of + let res = case lookup name env of Nothing -> FormMissing Just "none" -> FormSuccess Nothing Just x -> @@ -645,7 +653,7 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do FormSuccess y -> Just x == y _ -> Just x == initial let input = [$hamlet| -%select#$i$!name=$i$ +%select#$theId$!name=$name$ %option!value=none $forall pairs' pair %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ @@ -653,8 +661,8 @@ maybeSelectField pairs label tooltip initial = GForm $ \env _ -> do let fi = FieldInfo { fiLabel = label , fiTooltip = tooltip - , fiIdent = i - , fiName = i + , fiIdent = theId + , fiName = name , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -869,7 +877,7 @@ emailInput n = requiredFieldHelper emailFieldProfile (nameSettings n) Nothing nameSettings :: String -> FormFieldSettings -nameSettings = FormFieldSettings mempty mempty Nothing . Just +nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) addScript' :: (y -> Either (Route y) String) -> GWidget sub y () addScript' f = do @@ -880,3 +888,6 @@ addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () addStylesheet' f = do y <- liftHandler getYesod addStylesheetEither $ f y + +labelSettings :: String -> FormFieldSettings +labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing From 257bad8874cc387709a65bc1fdc45166870e8768 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 14:42:41 +0300 Subject: [PATCH 381/624] Fixed reversed id and name --- Yesod/Form.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 40a75e0c..07bb4fc8 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -224,7 +224,7 @@ data FormFieldSettings = FormFieldSettings requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a requiredFieldHelper (FieldProfile parse render mkXml w) - (FormFieldSettings label tooltip name' theId') orig = + (FormFieldSettings label tooltip theId' name') orig = GForm $ \env _ -> do name <- maybe newFormIdent return name' theId <- maybe newFormIdent return theId' @@ -255,7 +255,7 @@ requiredFieldHelper optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) optionalFieldHelper (FieldProfile parse render mkXml w) - (FormFieldSettings label tooltip name' theId') orig' = + (FormFieldSettings label tooltip theId' name') orig' = GForm $ \env _ -> do let orig = join orig' name <- maybe newFormIdent return name' From 93926654912d7100b54760811cac5f2f81f21791 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 15:38:39 +0300 Subject: [PATCH 382/624] getSuperclass is part of toFormField --- Yesod/Form.hs | 16 ++++++++++++---- blog2.hs | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 07bb4fc8..73cdb02d 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -105,6 +105,7 @@ import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email import Data.Char (isSpace) import Yesod.Yesod (Yesod (..)) +import Data.List (group, sort) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -750,7 +751,16 @@ runFormGet f = do mkToForm :: [EntityDef] -> Q [Dec] mkToForm = mapM derive where - getTFF (_, _, z) = fromMaybe "toFormField" $ getTFF' z + afterPeriod s = + case dropWhile (/= '.') s of + ('.':t) -> t + _ -> s + beforePeriod s = + case break (== '.') s of + (t, '.':_) -> Just t + _ -> Nothing + getSuperclass (_, _, z) = getTFF' z >>= beforePeriod + getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z getTFF' [] = Nothing getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x getTFF' (_:x) = getTFF' x @@ -770,8 +780,6 @@ mkToForm = mapM derive getName' (('n':'a':'m':'e':'=':x):_) = Just x getName' (_:x) = getName' x getName' [] = Nothing - getSuperclass ('s':'u':'p':'e':'r':'c':'l':'a':'s':'s':'=':s) = Just s - getSuperclass _ = Nothing derive :: EntityDef -> Q Dec derive t = do let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t @@ -798,8 +806,8 @@ mkToForm = mapM derive [] let y = mkName "y" let ctx = map (\x -> ClassP (mkName x) [VarT y]) + $ map head $ group $ sort $ mapMaybe getSuperclass - $ concatMap (\(_, _, z) -> z) $ entityColumns t return $ InstanceD ctx ( ConT ''ToForm `AppT` ConT (mkName $ entityName t) diff --git a/blog2.hs b/blog2.hs index 7c46e706..0e2034c0 100644 --- a/blog2.hs +++ b/blog2.hs @@ -10,7 +10,7 @@ import Data.Time (Day) share2 mkToForm mkPersist [$persist| Entry title String id=thetitle - day Day Desc toFormField=jqueryDayField name=day superclass=Yesod + day Day Desc toFormField=Yesod.jqueryDayField name=day content Html' toFormField=nicHtmlField deriving |] From 46be96e6c29fa5e71d108c2ac8348aed463bfafc Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 26 Jul 2010 15:55:35 +0300 Subject: [PATCH 383/624] Split jquery and nic code into separate modules --- Yesod/Dispatch.hs | 16 ----- Yesod/Form.hs | 151 +++--------------------------------------- Yesod/Form/Jquery.hs | 154 +++++++++++++++++++++++++++++++++++++++++++ Yesod/Form/Nic.hs | 40 +++++++++++ Yesod/Yesod.hs | 20 ------ blog2.hs | 8 ++- yesod.cabal | 2 + 7 files changed, 210 insertions(+), 181 deletions(-) create mode 100644 Yesod/Form/Jquery.hs create mode 100644 Yesod/Form/Nic.hs diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index bc9b64d2..5e3e7318 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -119,15 +119,6 @@ mkYesodData name res = do mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -typeHelper :: String -> Type -typeHelper = - foldl1 AppT . map go . words - where - go s@(x:_) - | isLower x = VarT $ mkName s - | otherwise = ConT $ mkName s - go [] = error "typeHelper: empty string to go" - mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument -> Cxt -- ^ classes @@ -208,13 +199,6 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) thResourceFromResource _ (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n -compact :: [(String, [a])] -> [(String, [a])] -compact [] = [] -compact ((x, x'):rest) = - let ys = filter (\(y, _) -> y == x) rest - zs = filter (\(z, _) -> z /= x) rest - in (x, x' ++ concatMap snd ys) : compact zs - sessionName :: String sessionName = "_SESSION" diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 73cdb02d..2052cad2 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -40,7 +40,6 @@ module Yesod.Form , stringFieldProfile , intFieldProfile , dayFieldProfile - , jqueryDayFieldProfile , timeFieldProfile , htmlFieldProfile , emailFieldProfile @@ -55,21 +54,13 @@ module Yesod.Form , maybeDoubleField , dayField , maybeDayField - , jqueryDayField - , maybeJqueryDayField - , jqueryDayTimeField - , jqueryDayTimeFieldProfile , timeField , maybeTimeField , htmlField , maybeHtmlField - , nicHtmlField - , maybeNicHtmlField , selectField , maybeSelectField , boolField - , jqueryAutocompleteField - , maybeJqueryAutocompleteField , emailField , maybeEmailField -- * Pre-built inputs @@ -82,14 +73,16 @@ module Yesod.Form , emailInput -- * Template Haskell , mkToForm + -- * Utilities + , parseDate + , parseTime ) where import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) -import Data.Time (UTCTime(..), Day, TimeOfDay(..)) -import Data.Time.LocalTime (timeOfDayToTime, timeToTimeOfDay) +import Data.Time (Day, TimeOfDay(..)) import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<), liftM, join) @@ -103,8 +96,6 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email -import Data.Char (isSpace) -import Yesod.Yesod (Yesod (..)) import Data.List (group, sort) -- | A form can produce three different results: there was no data available, @@ -389,94 +380,21 @@ instance ToFormField Day y where instance ToFormField (Maybe Day) y where toFormField = maybeDayField -jqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y Day -jqueryDayField = requiredFieldHelper jqueryDayFieldProfile - -maybeJqueryDayField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe Day) -maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile - -jqueryDayFieldProfile :: Yesod y => FieldProfile sub y Day -jqueryDayFieldProfile = FieldProfile - { fpParse = maybe - (Left "Invalid day, must be in YYYY-MM-DD format") - Right - . readMay - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - , fpWidget = \name -> do - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| -$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); -|] - } +parseDate :: String -> Either String Day +parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay . replace '/' '-' -- | Replaces all instances of a value in a list by another value. -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) -ifRight :: Either a b -> (b -> c) -> Either a c -ifRight e f = case e of - Left l -> Left l - Right r -> Right $ f r - -showLeadingZero :: (Show a) => a -> String -showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t - -parseUTCTime :: String -> Either String UTCTime -parseUTCTime s = - let (dateS, timeS) = break isSpace (dropWhile isSpace s) - in let dateE = (parseDate dateS) - in case dateE of - Left l -> Left l - Right date -> ifRight (parseTime timeS) - (\time -> UTCTime date (timeOfDayToTime time)) - -jqueryDayTimeField :: Yesod y => FormFieldSettings -> FormletField sub y UTCTime -jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - - --- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) -jqueryDayTimeUTCTime :: UTCTime -> String -jqueryDayTimeUTCTime (UTCTime day utcTime) = - let timeOfDay = timeToTimeOfDay utcTime - in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay - where - showTimeOfDay (TimeOfDay hour minute _) = - let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") - in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm - -jqueryDayTimeFieldProfile :: Yesod y => FieldProfile sub y UTCTime -jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime - , fpRender = jqueryDayTimeUTCTime - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - , fpWidget = \name -> do - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addScript' urlJqueryUiDateTimePicker - addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| -$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); -|] - } - parseTime :: String -> Either String TimeOfDay parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = +parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 in parseTimeHelper (h1', h2', m1, m2, '0', '0') parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = @@ -565,24 +483,6 @@ instance ToFormField (Maybe (Html ())) y where type Html' = Html () -nicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Html ()) -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile - -maybeNicHtmlField :: Yesod y => FormFieldSettings -> FormletField sub y (Maybe (Html ())) -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile - -nicHtmlFieldProfile :: Yesod y => FieldProfile sub y (Html ()) -nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString - , fpRender = U.toString . renderHtml - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea.html#$theId$!name=$name$ $val$ -|] - , fpWidget = \name -> do - addScript' urlNicEdit - addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] - } - readMay :: Read a => String -> Maybe a readMay s = case reads s of (x, _):_ -> Just x @@ -836,31 +736,6 @@ toLabel (x:rest) = toUpper x : go rest | isUpper c = ' ' : c : go cs | otherwise = c : go cs -jqueryAutocompleteField :: Yesod y => - Route y -> FormFieldSettings -> FormletField sub y String -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField :: Yesod y => - Route y -> FormFieldSettings -> FormletField sub y (Maybe String) -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: Yesod y => Route y -> FieldProfile sub y String -jqueryAutocompleteFieldProfile src = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - , fpWidget = \name -> do - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| -$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); -|] - } - emailFieldProfile :: FieldProfile s y String emailFieldProfile = FieldProfile { fpParse = \s -> if Email.isValid s @@ -887,15 +762,5 @@ emailInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () -addStylesheet' f = do - y <- liftHandler getYesod - addStylesheetEither $ f y - labelSettings :: String -> FormFieldSettings labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs new file mode 100644 index 00000000..d670fde1 --- /dev/null +++ b/Yesod/Form/Jquery.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Jquery + ( YesodJquery (..) + , jqueryDayField + , maybeJqueryDayField + , jqueryDayTimeField + , jqueryDayTimeFieldProfile + , jqueryAutocompleteField + , maybeJqueryAutocompleteField + , jqueryDayFieldProfile + ) where + +import Yesod.Handler +import Yesod.Form +import Yesod.Widget +import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, + timeToTimeOfDay) +import Yesod.Hamlet +import Data.Char (isSpace) + +class YesodJquery a where + -- | The jQuery Javascript file. + urlJqueryJs :: a -> Either (Route a) String + urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + + -- | The jQuery UI 1.8.1 Javascript file. + urlJqueryUiJs :: a -> Either (Route a) String + urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + + -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme. + urlJqueryUiCss :: a -> Either (Route a) String + urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + + -- | jQuery UI time picker add-on. + urlJqueryUiDateTimePicker :: a -> Either (Route a) String + urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" + +jqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y Day +jqueryDayField = requiredFieldHelper jqueryDayFieldProfile + +maybeJqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y (Maybe Day) +maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile + +jqueryDayFieldProfile :: YesodJquery y => FieldProfile sub y Day +jqueryDayFieldProfile = FieldProfile + { fpParse = maybe + (Left "Invalid day, must be in YYYY-MM-DD format") + Right + . readMay + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); +|] + } + +ifRight :: Either a b -> (b -> c) -> Either a c +ifRight e f = case e of + Left l -> Left l + Right r -> Right $ f r + +showLeadingZero :: (Show a) => a -> String +showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t + +jqueryDayTimeField :: YesodJquery y => FormFieldSettings -> FormletField sub y UTCTime +jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile + +-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) +jqueryDayTimeUTCTime :: UTCTime -> String +jqueryDayTimeUTCTime (UTCTime day utcTime) = + let timeOfDay = timeToTimeOfDay utcTime + in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay + where + showTimeOfDay (TimeOfDay hour minute _) = + let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") + in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm + +jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime +jqueryDayTimeFieldProfile = FieldProfile + { fpParse = parseUTCTime + , fpRender = jqueryDayTimeUTCTime + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addScript' urlJqueryUiDateTimePicker + addStylesheet' urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); +|] + } + +parseUTCTime :: String -> Either String UTCTime +parseUTCTime s = + let (dateS, timeS) = break isSpace (dropWhile isSpace s) + dateE = parseDate dateS + in case dateE of + Left l -> Left l + Right date -> + ifRight (parseTime timeS) + (UTCTime date . timeOfDayToTime) + +jqueryAutocompleteField :: YesodJquery y => + Route y -> FormFieldSettings -> FormletField sub y String +jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile + +maybeJqueryAutocompleteField :: YesodJquery y => + Route y -> FormFieldSettings -> FormletField sub y (Maybe String) +maybeJqueryAutocompleteField src = + optionalFieldHelper $ jqueryAutocompleteFieldProfile src + +jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String +jqueryAutocompleteFieldProfile src = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ +|] + , fpWidget = \name -> do + addScript' urlJqueryJs + addScript' urlJqueryUiJs + addStylesheet' urlJqueryUiCss + addJavaScript [$hamlet| +$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); +|] + } + +addScript' :: (y -> Either (Route y) String) -> GWidget sub y () +addScript' f = do + y <- liftHandler getYesod + addScriptEither $ f y + +addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () +addStylesheet' f = do + y <- liftHandler getYesod + addStylesheetEither $ f y + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing + +-- | Replaces all instances of a value in a list by another value. +-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs new file mode 100644 index 00000000..1b381b60 --- /dev/null +++ b/Yesod/Form/Nic.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Nic + ( YesodNic (..) + , nicHtmlField + , maybeNicHtmlField + ) where + +import Yesod.Handler +import Yesod.Form +import Yesod.Hamlet +import Yesod.Widget +import qualified Data.ByteString.Lazy.UTF8 as U + +class YesodNic a where + -- | NIC Editor. + urlNicEdit :: a -> Either (Route a) String + urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" + +nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Html ()) +nicHtmlField = requiredFieldHelper nicHtmlFieldProfile + +maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile + +nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y (Html ()) +nicHtmlFieldProfile = FieldProfile + { fpParse = Right . preEscapedString + , fpRender = U.toString . renderHtml + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ +|] + , fpWidget = \name -> do + addScript' urlNicEdit + addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] + } + +addScript' :: (y -> Either (Route y) String) -> GWidget sub y () +addScript' f = do + y <- liftHandler getYesod + addScriptEither $ f y diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 3cba2a6f..9b800dfa 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -118,26 +118,6 @@ class Eq (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing - -- | The jQuery Javascript file. - urlJqueryJs :: a -> Either (Route a) String - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - - -- | The jQuery UI 1.8.1 Javascript file. - urlJqueryUiJs :: a -> Either (Route a) String - urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" - - -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme. - urlJqueryUiCss :: a -> Either (Route a) String - urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) String - urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" - - -- | NIC Editor. - urlNicEdit :: a -> Either (Route a) String - urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" - data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) diff --git a/blog2.hs b/blog2.hs index 0e2034c0..3a58325f 100644 --- a/blog2.hs +++ b/blog2.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} import Yesod import Yesod.Helpers.Crud +import Yesod.Form.Jquery +import Yesod.Form.Nic import Database.Persist.Sqlite import Database.Persist.TH import Data.Time (Day) @@ -10,8 +12,8 @@ import Data.Time (Day) share2 mkToForm mkPersist [$persist| Entry title String id=thetitle - day Day Desc toFormField=Yesod.jqueryDayField name=day - content Html' toFormField=nicHtmlField + day Day Desc toFormField=YesodJquery.jqueryDayField name=day + content Html' toFormField=YesodNic.nicHtmlField deriving |] @@ -30,6 +32,8 @@ mkYesod "Blog" [$parseRoutes| instance Yesod Blog where approot _ = "http://localhost:3000" +instance YesodJquery Blog +instance YesodNic Blog instance YesodPersist Blog where type YesodDB Blog = SqliteReader diff --git a/yesod.cabal b/yesod.cabal index 6471a351..27c6cc5a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -49,6 +49,8 @@ library Yesod.Content Yesod.Dispatch Yesod.Form + Yesod.Form.Jquery + Yesod.Form.Nic Yesod.Hamlet Yesod.Handler Yesod.Internal From 1aa19bcf927b9b5a472e0f77b6d4791ebefb778c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 27 Jul 2010 16:35:53 +0300 Subject: [PATCH 384/624] isAuthorized takes a isWrite parameter --- Yesod/Dispatch.hs | 3 ++- Yesod/Yesod.hs | 29 ++++++++++++++++++++++++----- 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5e3e7318..eb549e79 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -240,7 +240,8 @@ toWaiApp' y segments env = do case eurl of Left _ -> errorHandler NotFound Right url -> do - ar <- isAuthorized url + isWrite <- isWriteRequest url + ar <- isAuthorized url isWrite case ar of Authorized -> return () AuthenticationRequired -> diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 9b800dfa..835ba722 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes @@ -108,8 +109,23 @@ class Eq (Route a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. - isAuthorized :: Route a -> GHandler s a AuthResult - isAuthorized _ = return Authorized + isAuthorized :: Route a + -> Bool -- ^ is this a write request? + -> GHandler s a AuthResult + isAuthorized _ _ = return Authorized + + -- | Determines whether the current request is a write request. By default, + -- this assumes you are following RESTful principles, and determines this + -- from request method. In particular, all except the following request + -- methods are considered write: GET HEAD OPTIONS TRACE. + -- + -- This function is used to determine if a request is authorized; see + -- 'isAuthorized'. + isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest _ = do + wai <- waiRequest + return $ not $ W.requestMethod wai `elem` + ["GET", "HEAD", "OPTIONS", "TRACE"] -- | The default route for authentication. -- @@ -236,7 +252,10 @@ get404 key = do -- -- Built on top of 'isAuthorized'. This is useful for building page that only -- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a => Route a -> GHandler s a (Maybe (Route a)) -maybeAuthorized r = do - x <- isAuthorized r +maybeAuthorized :: Yesod a + => Route a + -> Bool -- ^ is this a write request? + -> GHandler s a (Maybe (Route a)) +maybeAuthorized r isWrite = do + x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing From 39818c8f5784ff8e0edace170400d4745b485233 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 4 Aug 2010 11:00:43 +0300 Subject: [PATCH 385/624] Error handlers get Nothing for current route --- Yesod/Dispatch.hs | 7 ++++--- Yesod/Handler.hs | 5 +++++ 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index eb549e79..33c31b0f 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -234,11 +234,12 @@ toWaiApp' y segments env = do render u = fromMaybe (fullRender (approot y) (formatPathSegments site) u) (urlRenderOverride y u) + let errorHandler' = localNoCurrent . errorHandler rr <- parseWaiRequest env session' let h = do onRequest case eurl of - Left _ -> errorHandler NotFound + Left _ -> errorHandler' NotFound Right url -> do isWrite <- isWriteRequest url ar <- isAuthorized url isWrite @@ -253,10 +254,10 @@ toWaiApp' y segments env = do redirect RedirectTemporary url' Unauthorized s -> permissionDenied s case handleSite site render url method of - Nothing -> errorHandler $ BadMethod method + Nothing -> errorHandler' $ BadMethod method Just h' -> h' let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler er) render eurl' id y id + let eh er = runHandler (errorHandler' er) render eurl' id y id let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ce81516f..509272bb 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -66,6 +66,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , toMasterHandler + , localNoCurrent ) where import Prelude hiding (catch) @@ -438,3 +439,7 @@ data RedirectType = RedirectPermanent | RedirectTemporary | RedirectSeeOther deriving (Show, Eq) + +localNoCurrent :: GHandler s m a -> GHandler s m a +localNoCurrent = + GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler From faf2669d635f059e51069410f479a6a9a50a1181 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 4 Aug 2010 17:36:10 +0300 Subject: [PATCH 386/624] Added textarea and hidden (hidden needs work) --- Yesod/Form.hs | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 2052cad2..8f6500a8 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -38,6 +38,8 @@ module Yesod.Form -- * Field profiles , FieldProfile (..) , stringFieldProfile + , textareaFieldProfile + , hiddenFieldProfile , intFieldProfile , dayFieldProfile , timeFieldProfile @@ -48,6 +50,10 @@ module Yesod.Form -- * Pre-built fields , stringField , maybeStringField + , textareaField + , maybeTextareaField + , hiddenField + , maybeHiddenField , intField , maybeIntField , doubleField @@ -764,3 +770,35 @@ nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) labelSettings :: String -> FormFieldSettings labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing + +textareaFieldProfile :: FieldProfile sub y String +textareaFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea#$theId$!name=$name$ $val$ +|] + , fpWidget = const $ return () + } + +textareaField :: FormFieldSettings -> FormletField sub y String +textareaField = requiredFieldHelper textareaFieldProfile + +maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeTextareaField = optionalFieldHelper textareaFieldProfile + +hiddenFieldProfile :: FieldProfile sub y String +hiddenFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%input!type=hidden#$theId$!name=$name$!value=$val$ +|] + , fpWidget = const $ return () + } + +hiddenField :: FormFieldSettings -> FormletField sub y String +hiddenField = requiredFieldHelper hiddenFieldProfile + +maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeHiddenField = optionalFieldHelper hiddenFieldProfile From 9fada88b6e205923e14d4dac3044ad78632c58b1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 4 Aug 2010 21:35:03 +0300 Subject: [PATCH 387/624] Configurable splitPath --- Yesod/Dispatch.hs | 4 ++-- Yesod/Yesod.hs | 16 ++++++++++++++++ yesod.cabal | 2 +- 3 files changed, 19 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 33c31b0f..adbe0e56 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -37,7 +37,7 @@ import Web.Routes.Site import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath +import Network.Wai.Middleware.CleanPath (cleanPathFunc) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -208,7 +208,7 @@ toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp a = return $ gzip $ jsonp - $ cleanPathRel (B.pack $ approot a) + $ cleanPathFunc (splitPath a) (B.pack $ approot a) $ toWaiApp' a toWaiApp' :: (Yesod y, YesodSite y) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 835ba722..2fcbd7ab 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -42,6 +42,8 @@ import Database.Persist import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) +import qualified Data.ByteString as S +import qualified Network.Wai.Middleware.CleanPath -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -134,6 +136,20 @@ class Eq (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing + -- | A function used to split a raw PATH_INFO value into path pieces. It + -- returns a 'Left' value when you should redirect to the given path, and a + -- 'Right' value on successful parse. + -- + -- By default, it splits paths on slashes, and ensures the following are true: + -- + -- * No double slashes + -- + -- * If the last path segment has a period, there is no trailing slash. + -- + -- * Otherwise, ensures there /is/ a trailing slash. + splitPath :: a -> S.ByteString -> Either S.ByteString [String] + splitPath _ = Network.Wai.Middleware.CleanPath.splitPath + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) diff --git a/yesod.cabal b/yesod.cabal index 27c6cc5a..0bdbfcb7 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5, time >= 1.1.4 && < 1.3, wai >= 0.2.0 && < 0.3, - wai-extra >= 0.2.0 && < 0.3, + wai-extra >= 0.2.2 && < 0.3, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, From 191b406fd57585d0fa34d8e44eb0394a0d9fecd1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 4 Aug 2010 23:07:27 +0300 Subject: [PATCH 388/624] joinPath --- Yesod/Dispatch.hs | 25 +------------------------ Yesod/Yesod.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+), 24 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index adbe0e56..5154ca70 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -18,8 +18,6 @@ module Yesod.Dispatch , toWaiApp , basicHandler , basicHandler' - -- * Utilities - , fullRender #if TEST , testSuite #endif @@ -46,7 +44,6 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B -import Web.Routes (encodePathInfo) import qualified Data.ByteString.UTF8 as S @@ -232,7 +229,7 @@ toWaiApp' y segments env = do pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments render u = fromMaybe - (fullRender (approot y) (formatPathSegments site) u) + (joinPath y (approot y) $ formatPathSegments site u) (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler rr <- parseWaiRequest env session' @@ -268,19 +265,6 @@ toWaiApp' y segments env = do hs''' = ("Content-Type", S.fromString ct) : hs'' return $ W.Response s hs''' c --- | Fully render a route to an absolute URL. Since Yesod does this for you --- internally, you will rarely need access to this. However, if you need to --- generate links /outside/ of the Handler monad, this may be useful. --- --- For example, if you want to generate an e-mail which links to your site, --- this is the function you would want to use. -fullRender :: String -- ^ approot, no trailing slash - -> (url -> [String]) - -> url - -> String -fullRender ar render route = - ar ++ '/' : encodePathInfo (fixSegs $ render route) - httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack . parseHttpAccept @@ -316,13 +300,6 @@ basicHandler' port mhost y = do SS.run port app Just _ -> CGI.run app -fixSegs :: [String] -> [String] -fixSegs [] = [] -fixSegs [x] - | any (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash -fixSegs (x:xs) = x : fixSegs xs - parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 2fcbd7ab..a792c321 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -44,6 +44,7 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath +import Web.Routes (encodePathInfo) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -150,6 +151,18 @@ class Eq (Route a) => Yesod a where splitPath :: a -> S.ByteString -> Either S.ByteString [String] splitPath _ = Network.Wai.Middleware.CleanPath.splitPath + -- | Join the pieces of a path together into an absolute URL. This should + -- be the inverse of 'splitPath'. + joinPath :: a -> String -> [String] -> String + joinPath _ ar pieces = + ar ++ '/' : encodePathInfo (fixSegs pieces) + where + fixSegs [] = [] + fixSegs [x] + | any (== '.') x = [x] + | otherwise = [x, ""] -- append trailing slash + fixSegs (x:xs) = x : fixSegs xs + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) From ce25f03e79e878dc3ffc9935aacf2eeb1c9f1070 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 6 Aug 2010 14:03:18 +0300 Subject: [PATCH 389/624] setUltDest' sets query string as well --- Yesod/Handler.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 509272bb..03bf02ea 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -269,10 +269,14 @@ redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do r <- getUrlRender - redirectString rt $ r url ++ - if null params then "" else '?' : encodeUrlPairs params + redirectString rt $ r url ++ encodeUrlPairs params + +encodeUrlPairs :: [(String, String)] -> String +encodeUrlPairs [] = "" +encodeUrlPairs pairs = + (:) '?' $ encodeUrlPairs' pairs where - encodeUrlPairs = intercalate "&" . map encodeUrlPair + encodeUrlPairs' = intercalate "&" . map encodeUrlPair encodeUrlPair (x, []) = escape x encodeUrlPair (x, y) = escape x ++ '=' : escape y escape = concatMap escape' @@ -319,8 +323,13 @@ setUltDestString = setSession ultDestKey setUltDest' :: GHandler sub master () setUltDest' = do route <- getCurrentRoute - tm <- getRouteToMaster - maybe (return ()) setUltDest $ tm <$> route + case route of + Nothing -> return () + Just r -> do + tm <- getRouteToMaster + gets <- reqGetParams <$> getRequest + render <- getUrlRender + setUltDestString $ render (tm r) ++ encodeUrlPairs gets -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. From a9a373073156abe4f94d8ceb3b96ab93489a9fc7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 8 Aug 2010 10:48:32 +0300 Subject: [PATCH 390/624] Camlet and Jamlet --- Yesod/Form/Jquery.hs | 6 +++--- Yesod/Form/Nic.hs | 2 +- Yesod/Hamlet.hs | 6 +++++- Yesod/Widget.hs | 38 +++++++++++++++++++++++--------------- hellowidget.hs | 42 +++++++++++++++++++++++++++++------------- yesod.cabal | 3 ++- 6 files changed, 63 insertions(+), 34 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index d670fde1..882fdcf2 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -55,7 +55,7 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| + addJavaScript [$jamlet| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] } @@ -93,7 +93,7 @@ jqueryDayTimeFieldProfile = FieldProfile addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| + addJavaScript [$jamlet| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -128,7 +128,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$hamlet| + addJavaScript [$jamlet| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 1b381b60..d40c9e56 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -31,7 +31,7 @@ nicHtmlFieldProfile = FieldProfile |] , fpWidget = \name -> do addScript' urlNicEdit - addJavaScript [$hamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] + addJavaScript [$jamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index a30b5eba..18af6ba4 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -6,6 +6,8 @@ module Yesod.Hamlet ( -- * Hamlet library module Text.Hamlet + , jamlet + , camlet -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -14,7 +16,9 @@ module Yesod.Hamlet ) where -import Text.Hamlet +import Text.Hamlet hiding (hamletFile) +import Text.Camlet +import Text.Jamlet import Yesod.Content import Yesod.Handler diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 1737b867..fc3e26c5 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -36,6 +36,8 @@ import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) +import Text.Camlet +import Text.Jamlet import Yesod.Handler (Route, GHandler) import Yesod.Yesod (Yesod, defaultLayout) import Yesod.Content (RepHtml (..)) @@ -43,6 +45,9 @@ import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +import Text.Blaze (unsafeByteString) data Location url = Local url | Remote String deriving (Show, Eq) @@ -64,14 +69,10 @@ newtype Script url = Script { unScript :: Location url } newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } deriving (Show, Eq) newtype Title = Title { unTitle :: Html () } -newtype Style url = Style (Maybe (Hamlet url)) - deriving Monoid newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid -newtype JavaScript url = JavaScript (Maybe (Hamlet url)) - deriving Monoid -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of @@ -81,8 +82,8 @@ newtype GWidget sub master a = GWidget ( WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) ( WriterT (UniqueList (Stylesheet (Route master))) ( - WriterT (Style (Route master)) ( - WriterT (JavaScript (Route master)) ( + WriterT (Maybe (Camlet (Route master))) ( + WriterT (Maybe (Jamlet (Route master))) ( WriterT (Head (Route master)) ( StateT Int ( GHandler sub master @@ -121,8 +122,8 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do return $ "w" ++ show i' -- | Add some raw CSS to the style tag. -addStyle :: Hamlet (Route master) -> GWidget sub master () -addStyle = GWidget . lift . lift . lift . lift . tell . Style . Just +addStyle :: Camlet (Route master) -> GWidget sub master () +addStyle = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master () @@ -149,9 +150,8 @@ addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag. -addJavaScript :: Hamlet (Route master) -> GWidget sub master () -addJavaScript = GWidget . lift . lift . lift . lift . lift. tell - . JavaScript . Just +addJavaScript :: Jamlet (Route master) -> GWidget sub master () +addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Apply the default layout to the given widget. applyLayoutW :: (Eq (Route m), Yesod m) @@ -171,22 +171,30 @@ widgetToPageContent (GWidget w) = do Last mTitle), scripts'), stylesheets'), - Style style), - JavaScript jscript), + style), + jscript), Head head') = w' let title = maybe mempty unTitle mTitle let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet) $ runUniqueList stylesheets' + -- FIXME the next functions can be optimized once blaze-html switches to + -- blaze-builder + let lbsToHtml = unsafeByteString . S.concat . L.toChunks + let celper :: Camlet url -> Hamlet url + celper c render = lbsToHtml $ renderCamlet render c + let jelper :: Jamlet url -> Hamlet url + jelper j render = lbsToHtml $ renderJamlet render j + let head'' = [$hamlet| $forall scripts s %script!src=^s^ $forall stylesheets s %link!rel=stylesheet!href=^s^ $maybe style s - %style ^s^ + %style ^celper.s^ $maybe jscript j - %script ^j^ + %script ^jelper.j^ ^head'^ |] return $ PageContent title head'' body diff --git a/hellowidget.hs b/hellowidget.hs index 7afe4641..7f66626c 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -2,6 +2,8 @@ import Yesod import Yesod.Widget import Yesod.Helpers.Static +import Yesod.Form.Jquery +import Yesod.Form.Nic import Control.Applicative data HW = HW { hwStatic :: Static } @@ -12,6 +14,8 @@ mkYesod "HW" [$parseRoutes| /autocomplete AutoCompleteR GET |] instance Yesod HW where approot _ = "" +instance YesodNic HW +instance YesodJquery HW wrapper h = [$hamlet| #wrapper ^h^ %footer Brought to you by Yesod Widgets™ @@ -19,7 +23,10 @@ wrapper h = [$hamlet| getRootR = applyLayoutW $ flip wrapWidget wrapper $ do i <- newIdent setTitle $ string "Hello Widgets" - addStyle [$hamlet|\#$i${color:red}|] + addStyle [$camlet| +#$i$ + color:red +|] addStylesheet $ StaticR $ StaticRoute ["style.css"] addStylesheetRemote "http://localhost:3000/static/style2.css" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" @@ -35,12 +42,13 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,,,,,) - <$> stringField (string "My Field") (string "Some tooltip info") Nothing - <*> stringField (string "Another field") (string "") (Just "some default text") - <*> intField (string "A number field") (string "some nums") (Just 5) - <*> jqueryDayField (string "A day field") (string "") Nothing - <*> timeField (string "A time field") (string "") Nothing + (res, form, enctype) <- runFormPost $ (,,,,,,,,,) + <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing + <*> stringField (labelSettings "Another field") (Just "some default text") + <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) + <*> jqueryDayField (labelSettings "A day field") Nothing + <*> timeField (labelSettings "A time field") Nothing + <*> jqueryDayTimeField (labelSettings "A day/time field") Nothing <*> boolField FormFieldSettings { ffsLabel = "A checkbox" , ffsTooltip = "" @@ -48,16 +56,24 @@ handleFormR = do , ffsName = Nothing } (Just False) <*> jqueryAutocompleteField AutoCompleteR - (string "Autocomplete") (string "Try it!") Nothing - <*> nicHtmlField (string "HTML") (string "") + (FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing + <*> nicHtmlField (labelSettings "HTML") (Just $ string "You can put rich text here") - <*> maybeEmailField (string "An e-mail addres") mempty Nothing + <*> maybeEmailField (labelSettings "An e-mail addres") Nothing let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, x, _) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, x, _) -> Just x _ -> Nothing applyLayoutW $ do - addStyle [$hamlet|\.tooltip{color:#666;font-style:italic}|] - addStyle [$hamlet|textarea.html{width:300px;height:150px};|] + addStyle [$camlet| +.tooltip + color:#666 + font-style:italic +|] + addStyle [$camlet| +textarea.html + width:300px + height:150px +|] wrapWidget (fieldsToTable form) $ \h -> [$hamlet| %form!method=post!enctype=$show.enctype$ %table diff --git a/yesod.cabal b/yesod.cabal index 0bdbfcb7..6d9678fe 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,8 @@ library template-haskell >= 2.4 && < 2.5, web-routes >= 0.22 && < 0.23, web-routes-quasi >= 0.5 && < 0.6, - hamlet >= 0.4.1 && < 0.5, + hamlet >= 0.5.0 && < 0.6, + blaze-html >= 0.1.1 && < 0.2, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, From 5190a5eabb1b4188d8c6fbc1d074d369d46d09f4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 8 Aug 2010 12:48:08 +0300 Subject: [PATCH 391/624] addStaticContent --- Yesod/Widget.hs | 37 ++++++++++++++++++++++++++++++++----- Yesod/Yesod.hs | 17 +++++++++++++++++ hellowidget.hs | 12 +++++++++++- 3 files changed, 60 insertions(+), 6 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index fc3e26c5..cc908b20 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -38,8 +38,8 @@ import Control.Monad.Trans.State import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) import Text.Camlet import Text.Jamlet -import Yesod.Handler (Route, GHandler) -import Yesod.Yesod (Yesod, defaultLayout) +import Yesod.Handler (Route, GHandler, getUrlRender) +import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) import Yesod.Content (RepHtml (..)) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) @@ -159,7 +159,7 @@ applyLayoutW :: (Eq (Route m), Yesod m) applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout -- | Convert a widget to a 'PageContent'. -widgetToPageContent :: Eq (Route master) +widgetToPageContent :: (Eq (Route master), Yesod master) => GWidget sub master () -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do @@ -186,15 +186,42 @@ widgetToPageContent (GWidget w) = do let jelper :: Jamlet url -> Hamlet url jelper j render = lbsToHtml $ renderJamlet render j + render <- getUrlRender + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right u) -> Just $ render u + cssLoc <- + case style of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "css" "text/css; charset=utf-8" + $ renderCamlet render s + return $ renderLoc x + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ renderJamlet render s + return $ renderLoc x + let head'' = [$hamlet| $forall scripts s %script!src=^s^ $forall stylesheets s %link!rel=stylesheet!href=^s^ $maybe style s - %style ^celper.s^ + $maybe cssLoc s + %link!rel=stylesheet!href=$s$ + $nothing + %style ^celper.s^ $maybe jscript j - %script ^jelper.j^ + $maybe jsLoc s + %script!src=$s$ + $nothing + %script ^jelper.j^ ^head'^ |] return $ PageContent title head'' body diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a792c321..2830d6ee 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -45,6 +45,7 @@ import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath import Web.Routes (encodePathInfo) +import qualified Data.ByteString.Lazy as L -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. @@ -163,6 +164,22 @@ class Eq (Route a) => Yesod a where | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs + -- | This function is used to store some static content to be served as an + -- external file. The most common case of this is stashing CSS and + -- JavaScript content in an external file; the "Yesod.Widget" module uses + -- this feature. + -- + -- The return value is 'Nothing' if no storing was performed; this is the + -- default implementation. A 'Just' 'Left' gives the absolute URL of the + -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is + -- necessary when you are serving the content outside the context of a + -- Yesod application, such as via memcached. + addStaticContent :: String -- ^ filename extension + -> String -- ^ mime-type + -> L.ByteString -- ^ content + -> GHandler sub a (Maybe (Either String (Route a))) + addStaticContent _ _ _ = return Nothing + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) diff --git a/hellowidget.hs b/hellowidget.hs index 7f66626c..e6a4a30c 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -5,6 +5,9 @@ import Yesod.Helpers.Static import Yesod.Form.Jquery import Yesod.Form.Nic import Control.Applicative +import qualified Data.ByteString.Lazy as L +import System.Directory +import Data.Digest.Pure.MD5 data HW = HW { hwStatic :: Static } mkYesod "HW" [$parseRoutes| @@ -13,7 +16,14 @@ mkYesod "HW" [$parseRoutes| /static StaticR Static hwStatic /autocomplete AutoCompleteR GET |] -instance Yesod HW where approot _ = "" +instance Yesod HW where + approot _ = "" + addStaticContent ext _ content = do + let fn = show (md5 content) ++ '.' : ext + liftIO $ createDirectoryIfMissing True "static/tmp" + liftIO $ L.writeFile ("static/tmp/" ++ fn) content + return $ Just $ Right $ StaticR $ StaticRoute ["tmp", fn] + instance YesodNic HW instance YesodJquery HW wrapper h = [$hamlet| From 0ce3740c649320091e2ee3c051638d8978975b41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 8 Aug 2010 15:15:37 +0300 Subject: [PATCH 392/624] query string --- Yesod/Dispatch.hs | 6 +++-- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 50 +++++++++++++---------------------------- Yesod/Helpers/Static.hs | 25 +++++++++++++++++---- Yesod/Widget.hs | 6 ++--- Yesod/Yesod.hs | 8 +++---- hellowidget.hs | 2 +- yesod.cabal | 4 ++-- 8 files changed, 51 insertions(+), 52 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5154ca70..4dc89406 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -228,8 +228,10 @@ toWaiApp' y segments env = do types = httpAccept env pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments - render u = fromMaybe - (joinPath y (approot y) $ formatPathSegments site u) + render u qs = + let (ps, qs') = formatPathSegments site u + in fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler rr <- parseWaiRequest env session' diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 18af6ba4..4757474a 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -36,7 +36,7 @@ data PageContent url = PageContent -- Yesod 'Response'. hamletToContent :: Hamlet (Route master) -> GHandler sub master Content hamletToContent h = do - render <- getUrlRender + render <- getUrlRenderParams return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 03bf02ea..2010659e 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -30,6 +30,7 @@ module Yesod.Handler , getYesod , getYesodSub , getUrlRender + , getUrlRenderParams , getCurrentRoute , getRouteToMaster -- * Special responses @@ -73,7 +74,7 @@ import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal -import Data.List (foldl', intercalate) +import Data.List (foldl') import Data.Neither import Control.Exception hiding (Handler, catch) @@ -93,8 +94,6 @@ import Data.ByteString.UTF8 (toString) import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet -import Numeric (showIntAtBase) -import Data.Char (ord, chr) -- | The type-safe URLs associated with a site argument. type family Route a @@ -104,7 +103,7 @@ data HandlerData sub master = HandlerData , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> String) + , handlerRender :: (Route master -> [(String, String)] -> String) , handlerToMaster :: Route sub -> Route master } @@ -183,7 +182,13 @@ getYesod = handlerMaster <$> GHandler ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> String) -getUrlRender = handlerRender <$> GHandler ask +getUrlRender = do + x <- handlerRender <$> GHandler ask + return $ flip x [] + +-- | The URL rendering function with query-string parameters. +getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) +getUrlRenderParams = handlerRender <$> GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. @@ -209,7 +214,7 @@ dropKeys k = filter $ \(x, _) -> x /= k -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c - -> (Route master -> String) + -> (Route master -> [(String, String)] -> String) -> Maybe (Route sub) -> (Route sub -> Route master) -> master @@ -268,33 +273,8 @@ redirect rt url = redirectParams rt url [] redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do - r <- getUrlRender - redirectString rt $ r url ++ encodeUrlPairs params - -encodeUrlPairs :: [(String, String)] -> String -encodeUrlPairs [] = "" -encodeUrlPairs pairs = - (:) '?' $ encodeUrlPairs' pairs - where - encodeUrlPairs' = intercalate "&" . map encodeUrlPair - encodeUrlPair (x, []) = escape x - encodeUrlPair (x, y) = escape x ++ '=' : escape y - escape = concatMap escape' - escape' c - | 'A' < c && c < 'Z' = [c] - | 'a' < c && c < 'a' = [c] - | '0' < c && c < '9' = [c] - | c `elem` ".-~_" = [c] - | c == ' ' = "+" - | otherwise = '%' : myShowHex (ord c) "" - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of - [] -> "00" - [c] -> ['0',c] - s -> s - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + r <- getUrlRenderParams + redirectString rt $ r url params -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a @@ -328,8 +308,8 @@ setUltDest' = do Just r -> do tm <- getRouteToMaster gets <- reqGetParams <$> getRequest - render <- getUrlRender - setUltDestString $ render (tm r) ++ encodeUrlPairs gets + render <- getUrlRenderParams + setUltDestString $ render (tm r) gets -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 734dac8b..11fff089 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -43,6 +43,10 @@ import Data.Maybe (fromMaybe) import Yesod import Data.List (intercalate) import Language.Haskell.TH.Syntax +import Web.Routes.Site + +import qualified Data.ByteString.Lazy as L +import Data.Digest.Pure.MD5 #if TEST import Test.Framework (testGroup, Test) @@ -58,9 +62,20 @@ data Static = Static , staticTypes :: [(String, ContentType)] } -mkYesodSub "Static" [] [$parseRoutes| -*Strings StaticRoute GET -|] +data StaticRoute = StaticRoute [String] [(String, String)] + deriving (Eq, Show, Read) + +type instance Route Static = StaticRoute + +instance YesodSubSite Static master where + getSubSite = Site + { handleSite = \_ (StaticRoute ps _) m -> + case m of + "GET" -> Just $ fmap chooseRep $ getStaticRoute ps + _ -> Nothing + , formatPathSegments = \(StaticRoute x y) -> (x, y) + , parsePathSegments = \x -> Right $ StaticRoute x [] + } -- | Lookup files in a specific directory. -- @@ -132,10 +147,12 @@ staticFiles fp = do let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute" + hash <- qRunIO $ fmap (show . md5) $ L.readFile $ fp ++ '/' : intercalate "/" f + let qs = ListE [TupE [LitE $ StringL "hash", LitE $ StringL hash]] return [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name - [ Clause [] (NormalB $ sr `AppE` f') [] + [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] ] ] diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index cc908b20..2c9563c1 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -38,7 +38,7 @@ import Control.Monad.Trans.State import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) import Text.Camlet import Text.Jamlet -import Yesod.Handler (Route, GHandler, getUrlRender) +import Yesod.Handler (Route, GHandler, getUrlRenderParams) import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) import Yesod.Content (RepHtml (..)) import Control.Applicative (Applicative) @@ -186,12 +186,12 @@ widgetToPageContent (GWidget w) = do let jelper :: Jamlet url -> Hamlet url jelper j render = lbsToHtml $ renderJamlet render j - render <- getUrlRender + render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s - Just (Right u) -> Just $ render u + Just (Right (u, p)) -> Just $ render u p cssLoc <- case style of Nothing -> return Nothing diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 2830d6ee..2ed95adf 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -154,9 +154,9 @@ class Eq (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> String - joinPath _ ar pieces = - ar ++ '/' : encodePathInfo (fixSegs pieces) + joinPath :: a -> String -> [String] -> [(String, String)] -> String + joinPath _ ar pieces qs = + ar ++ '/' : encodePathInfo (fixSegs pieces) qs where fixSegs [] = [] fixSegs [x] @@ -177,7 +177,7 @@ class Eq (Route a) => Yesod a where addStaticContent :: String -- ^ filename extension -> String -- ^ mime-type -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either String (Route a))) + -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) addStaticContent _ _ _ = return Nothing data AuthResult = Authorized | AuthenticationRequired | Unauthorized String diff --git a/hellowidget.hs b/hellowidget.hs index e6a4a30c..a8dfe524 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -22,7 +22,7 @@ instance Yesod HW where let fn = show (md5 content) ++ '.' : ext liftIO $ createDirectoryIfMissing True "static/tmp" liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right $ StaticR $ StaticRoute ["tmp", fn] + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn], []) instance YesodNic HW instance YesodJquery HW diff --git a/yesod.cabal b/yesod.cabal index 6d9678fe..aafc37c9 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,8 +30,8 @@ library text >= 0.5 && < 0.8, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, - web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.5 && < 0.6, + web-routes >= 0.23 && < 0.24, + web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, blaze-html >= 0.1.1 && < 0.2, transformers >= 0.2 && < 0.3, From 6b8eb05ae17808c86c4eb7c72c719dc7d75fad22 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 8 Aug 2010 23:55:34 +0300 Subject: [PATCH 393/624] Minor refactorings --- Yesod/Hamlet.hs | 19 +++++++++++++++++-- Yesod/Json.hs | 44 +++++++++++++++++++++++--------------------- yesod.cabal | 1 + 3 files changed, 41 insertions(+), 23 deletions(-) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 4757474a..e4a76394 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -5,9 +5,24 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet ( -- * Hamlet library - module Text.Hamlet + -- ** Hamlet + hamlet + , xhamlet + , Hamlet + , Html + , renderHamlet + , renderHtml + , string + , preEscapedString + , cdata + -- ** Jamlet , jamlet + , Jamlet + , renderJamlet + -- ** Camlet , camlet + , Camlet + , renderCamlet -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -16,7 +31,7 @@ module Yesod.Hamlet ) where -import Text.Hamlet hiding (hamletFile) +import Text.Hamlet import Text.Camlet import Text.Jamlet import Yesod.Content diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 2ae8ccde..20f45578 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,6 +1,7 @@ -- | Efficient generation of JSON documents, with HTML-entity encoding handled via types. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Json ( -- * Monad Json @@ -20,10 +21,11 @@ module Yesod.Json import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl) -import Yesod.Hamlet import Yesod.Handler import Numeric (showHex) import Data.Monoid (Monoid (..)) +import Text.Blaze.Builder.Core +import Text.Blaze (Html, renderHtml, string) #if TEST import Test.Framework (testGroup, Test) @@ -35,21 +37,20 @@ import Yesod.Content hiding (testSuite) import Yesod.Content #endif --- | A monad for generating Json output. In truth, it is just a newtype wrapper --- around 'Html'; we thereby get the benefits of BlazeHtml (type safety and --- speed) without accidently mixing non-JSON content. +-- | A monad for generating Json output. It wraps the Builder monoid from the +-- blaze-builder package. -- -- This is an opaque type to avoid any possible insertion of non-JSON content. -- Due to the limited nature of the JSON format, you can create any valid JSON -- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json = Json { unJson :: Html () } +newtype Json = Json { unJson :: Builder } deriving Monoid -- | Extract the final result from the given 'Json' value. -- -- See also: applyLayoutJson in "Yesod.Yesod". jsonToContent :: Json -> GHandler sub master Content -jsonToContent = return . toContent . renderHtml . unJson +jsonToContent = return . toContent . toLazyByteString . unJson -- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. jsonToRepJson :: Json -> GHandler sub master RepJson @@ -64,9 +65,10 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Wraps the resulting string in quotes. jsonScalar :: Html () -> Json jsonScalar s = Json $ mconcat - [ preEscapedString "\"" - , unsafeByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s - , preEscapedString "\"" + [ fromByteString "\"" + -- FIXME the following line can be optimized after blaze-html 0.2 + , fromByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s + , fromByteString "\"" ] where encodeJson = L.concatMap (L.pack . encodeJsonChar) @@ -88,30 +90,30 @@ jsonScalar s = Json $ mconcat -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. jsonList :: [Json] -> Json -jsonList [] = Json $ preEscapedString "[]" +jsonList [] = Json $ fromByteString "[]" jsonList (x:xs) = mconcat - [ Json $ preEscapedString "[" + [ Json $ fromByteString "[" , x , mconcat $ map go xs - , Json $ preEscapedString "]" + , Json $ fromByteString "]" ] where - go = mappend (Json $ preEscapedString ",") + go = mappend (Json $ fromByteString ",") -- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. jsonMap :: [(String, Json)] -> Json -jsonMap [] = Json $ preEscapedString "{}" +jsonMap [] = Json $ fromByteString "{}" jsonMap (x:xs) = mconcat - [ Json $ preEscapedString "{" + [ Json $ fromByteString "{" , go x , mconcat $ map go' xs - , Json $ preEscapedString "}" + , Json $ fromByteString "}" ] where - go' y = mappend (Json $ preEscapedString ",") $ go y + go' y = mappend (Json $ fromByteString ",") $ go y go (k, v) = mconcat [ jsonScalar $ string k - , Json $ preEscapedString ":" + , Json $ fromByteString ":" , v ] @@ -119,7 +121,7 @@ jsonMap (x:xs) = mconcat -- this is the only function in this module that allows you to create broken -- JSON documents. jsonRaw :: S.ByteString -> Json -jsonRaw bs = Json $ unsafeByteString bs +jsonRaw = Json . fromByteString #if TEST @@ -133,8 +135,8 @@ caseSimpleOutput = do let j = do jsonMap [ ("foo" , jsonList - [ jsonScalar $ preEscapedString "bar" - , jsonScalar $ preEscapedString "baz" + [ jsonScalar $ fromByteString "bar" + , jsonScalar $ fromByteString "baz" ]) ] "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (renderHtml $ unJson j) diff --git a/yesod.cabal b/yesod.cabal index aafc37c9..521c2c2f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -34,6 +34,7 @@ library web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, blaze-html >= 0.1.1 && < 0.2, + blaze-builder >= 0.1 && < 0.2, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, pureMD5 >= 1.1.0.0 && < 1.2, From 02fd6bfffd42cd79ff587ace458e47da468503b1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 9 Aug 2010 16:59:25 +0300 Subject: [PATCH 394/624] Removed blaze-html --- CodeGenQ.hs | 6 +++--- Yesod/Form.hs | 23 ++++++++++------------- Yesod/Form/Nic.hs | 6 +++--- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 4 ++-- Yesod/Helpers/AtomFeed.hs | 2 +- Yesod/Json.hs | 4 ++-- Yesod/Widget.hs | 6 +++--- yesod.cabal | 1 - 9 files changed, 25 insertions(+), 29 deletions(-) diff --git a/CodeGenQ.hs b/CodeGenQ.hs index b1aab436..ddd5d740 100644 --- a/CodeGenQ.hs +++ b/CodeGenQ.hs @@ -16,10 +16,10 @@ codegen' s' = do let s = killFirstBlank s' case parse (many parseToken) s s of Left e -> error $ show e - Right tokens -> do - let tokens' = map toExp tokens + Right tokens' -> do + let tokens'' = map toExp tokens' concat' <- [|concat|] - return $ concat' `AppE` ListE tokens' + return $ concat' `AppE` ListE tokens'' where killFirstBlank ('\n':x) = x killFirstBlank ('\r':'\n':x) = x diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 8f6500a8..cd05c30f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -18,7 +18,6 @@ module Yesod.Form , FormResult (..) , Enctype (..) , FieldInfo (..) - , Html' -- * Unwrapping functions , runFormGet , runFormPost @@ -157,12 +156,12 @@ mapFormXml f (GForm g) = GForm $ \e fe -> do -- write generic field functions and then different functions for producing -- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. data FieldInfo sub y = FieldInfo - { fiLabel :: Html () - , fiTooltip :: Html () + { fiLabel :: Html + , fiTooltip :: Html , fiIdent :: String , fiName :: String , fiInput :: GWidget sub y () - , fiErrors :: Maybe (Html ()) + , fiErrors :: Maybe Html } type Env = [(String, String)] @@ -211,8 +210,8 @@ class ToFormField a y where toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html () - , ffsTooltip :: Html () + { ffsLabel :: Html + , ffsTooltip :: Html , ffsId :: Maybe String , ffsName :: Maybe String } @@ -467,13 +466,13 @@ boolField ffs orig = GForm $ \env _ -> do instance ToFormField Bool y where toFormField = boolField -htmlField :: FormFieldSettings -> FormletField sub y (Html ()) +htmlField :: FormFieldSettings -> FormletField sub y Html htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) maybeHtmlField = optionalFieldHelper htmlFieldProfile -htmlFieldProfile :: FieldProfile sub y (Html ()) +htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml @@ -482,13 +481,11 @@ htmlFieldProfile = FieldProfile |] , fpWidget = const $ return () } -instance ToFormField (Html ()) y where +instance ToFormField Html y where toFormField = htmlField -instance ToFormField (Maybe (Html ())) y where +instance ToFormField (Maybe Html) y where toFormField = maybeHtmlField -type Html' = Html () - readMay :: Read a => String -> Maybe a readMay s = case reads s of (x, _):_ -> Just x diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index d40c9e56..af87e8ed 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -16,13 +16,13 @@ class YesodNic a where urlNicEdit :: a -> Either (Route a) String urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Html ()) +nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y Html nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe (Html ())) +maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe Html) maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y (Html ()) +nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index e4a76394..0a3e11da 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -42,7 +42,7 @@ import Yesod.Handler -- -- > PageContent url -> Hamlet url data PageContent url = PageContent - { pageTitle :: Html () + { pageTitle :: Html , pageHead :: Hamlet url , pageBody :: Hamlet url } diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2010659e..a4796f76 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -332,14 +332,14 @@ msgKey = "_MSG" -- instead, it will only appear in the next request. -- -- See 'getMessage'. -setMessage :: Html () -> GHandler sub master () +setMessage :: Html -> GHandler sub master () setMessage = setSession msgKey . L.toString . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe (Html ())) +getMessage :: GHandler sub master (Maybe Html) getMessage = do deleteSession msgKey fmap (fmap preEscapedString) $ lookupSession msgKey diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index bcb25937..3e44c959 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -44,7 +44,7 @@ data AtomFeedEntry url = AtomFeedEntry { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String - , atomEntryContent :: Html () + , atomEntryContent :: Html } template :: AtomFeed url -> Hamlet url diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 20f45578..82fbb280 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -25,7 +25,7 @@ import Yesod.Handler import Numeric (showHex) import Data.Monoid (Monoid (..)) import Text.Blaze.Builder.Core -import Text.Blaze (Html, renderHtml, string) +import Text.Hamlet (Html, renderHtml, string) #if TEST import Test.Framework (testGroup, Test) @@ -63,7 +63,7 @@ jsonToRepJson = fmap RepJson . jsonToContent -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: Html () -> Json +jsonScalar :: Html -> Json jsonScalar s = Json $ mconcat [ fromByteString "\"" -- FIXME the following line can be optimized after blaze-html 0.2 diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 2c9563c1..f7ebb99a 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -47,7 +47,7 @@ import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S -import Text.Blaze (unsafeByteString) +import Text.Hamlet (unsafeByteString) data Location url = Local url | Remote String deriving (Show, Eq) @@ -68,7 +68,7 @@ newtype Script url = Script { unScript :: Location url } deriving (Show, Eq) newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } deriving (Show, Eq) -newtype Title = Title { unTitle :: Html () } +newtype Title = Title { unTitle :: Html } newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) @@ -102,7 +102,7 @@ liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. -setTitle :: Html () -> GWidget sub master () +setTitle :: Html -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title -- | Add some raw HTML to the head tag. diff --git a/yesod.cabal b/yesod.cabal index 521c2c2f..de1b009b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -33,7 +33,6 @@ library web-routes >= 0.23 && < 0.24, web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, - blaze-html >= 0.1.1 && < 0.2, blaze-builder >= 0.1 && < 0.2, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, From 2f3a0effffd4ae9439195de50841ff9c12b6b82a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 9 Aug 2010 17:48:59 +0300 Subject: [PATCH 395/624] Removed inefficient builder-to-lbs calls --- Yesod/Helpers/Auth.hs | 4 ++-- Yesod/Json.hs | 43 +++++++++++++++++++------------------------ Yesod/Widget.hs | 19 ++++++++----------- 3 files changed, 29 insertions(+), 37 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d0b71450..f80a8521 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -266,8 +266,8 @@ $maybe creds c |] json creds = jsonMap - [ ("ident", jsonScalar $ maybe (string "") (string . credsIdent) creds) - , ("displayName", jsonScalar $ string $ fromMaybe "" + [ ("ident", jsonScalar $ maybe "" credsIdent creds) + , ("displayName", jsonScalar $ fromMaybe "" $ creds >>= credsDisplayName) ] diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 82fbb280..0b78fc06 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,4 +1,4 @@ --- | Efficient generation of JSON documents, with HTML-entity encoding handled via types. +-- | Efficient generation of JSON documents. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,13 +19,12 @@ module Yesod.Json where import qualified Data.ByteString.Char8 as S -import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (isControl) import Yesod.Handler import Numeric (showHex) import Data.Monoid (Monoid (..)) import Text.Blaze.Builder.Core -import Text.Hamlet (Html, renderHtml, string) +import Text.Blaze.Builder.Utf8 (writeChar) #if TEST import Test.Framework (testGroup, Test) @@ -58,35 +57,31 @@ jsonToRepJson = fmap RepJson . jsonToContent -- | Outputs a single scalar. This function essentially: -- --- * Performs HTML entity escaping as necesary. --- -- * Performs JSON encoding. -- -- * Wraps the resulting string in quotes. -jsonScalar :: Html -> Json +jsonScalar :: String -> Json jsonScalar s = Json $ mconcat [ fromByteString "\"" - -- FIXME the following line can be optimized after blaze-html 0.2 - , fromByteString $ S.concat $ L.toChunks $ encodeJson $ renderHtml s + , writeList writeJsonChar s , fromByteString "\"" ] where - encodeJson = L.concatMap (L.pack . encodeJsonChar) - - encodeJsonChar '\b' = "\\b" - encodeJsonChar '\f' = "\\f" - encodeJsonChar '\n' = "\\n" - encodeJsonChar '\r' = "\\r" - encodeJsonChar '\t' = "\\t" - encodeJsonChar '"' = "\\\"" - encodeJsonChar '\\' = "\\\\" - encodeJsonChar c - | not $ isControl c = [c] - | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs - | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs - | c < '\x1000' = '\\' : 'u' : '0' : hexxs + writeJsonChar '\b' = writeByteString "\\b" + writeJsonChar '\f' = writeByteString "\\f" + writeJsonChar '\n' = writeByteString "\\n" + writeJsonChar '\r' = writeByteString "\\r" + writeJsonChar '\t' = writeByteString "\\t" + writeJsonChar '"' = writeByteString "\\\"" + writeJsonChar '\\' = writeByteString "\\\\" + writeJsonChar c + | not $ isControl c = writeChar c + | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs + | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs + | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs where hexxs = showHex (fromEnum c) "" - encodeJsonChar c = [c] + writeJsonChar c = writeChar c + writeString = writeByteString . S.pack -- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. jsonList :: [Json] -> Json @@ -112,7 +107,7 @@ jsonMap (x:xs) = mconcat where go' y = mappend (Json $ fromByteString ",") $ go y go (k, v) = mconcat - [ jsonScalar $ string k + [ jsonScalar k , Json $ fromByteString ":" , v ] diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index f7ebb99a..6b521f10 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -35,7 +35,8 @@ import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State -import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) +import Yesod.Hamlet (PageContent (..)) +import Text.Hamlet import Text.Camlet import Text.Jamlet import Yesod.Handler (Route, GHandler, getUrlRenderParams) @@ -45,9 +46,6 @@ import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S -import Text.Hamlet (unsafeByteString) data Location url = Local url | Remote String deriving (Show, Eq) @@ -178,13 +176,12 @@ widgetToPageContent (GWidget w) = do let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' let stylesheets = map (locationToHamlet . unStylesheet) $ runUniqueList stylesheets' - -- FIXME the next functions can be optimized once blaze-html switches to - -- blaze-builder - let lbsToHtml = unsafeByteString . S.concat . L.toChunks - let celper :: Camlet url -> Hamlet url - celper c render = lbsToHtml $ renderCamlet render c - let jelper :: Jamlet url -> Hamlet url - jelper j render = lbsToHtml $ renderJamlet render j + let cssToHtml (Css b) = Html b + celper :: Camlet url -> Hamlet url + celper = fmap cssToHtml + jsToHtml (Javascript b) = Html b + jelper :: Jamlet url -> Hamlet url + jelper = fmap jsToHtml render <- getUrlRenderParams let renderLoc x = From 90a56784eb6c1d9d8ae48a96b2c8d55bfae1c7d4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 9 Aug 2010 17:53:33 +0300 Subject: [PATCH 396/624] Tests build again --- Yesod/Content.hs | 4 ++-- Yesod/Json.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index b21e0f59..48ffd145 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -245,8 +245,8 @@ propExt s = caseTypeByExt :: Assertion caseTypeByExt = do - typeJavascript @=? typeByExt (ext "foo.js") - typeHtml @=? typeByExt (ext "foo.html") + Just typeJavascript @=? lookup (ext "foo.js") typeByExt + Just typeHtml @=? lookup (ext "foo.html") typeByExt #endif -- | Format a 'UTCTime' in W3 format; useful for setting cookies. diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 0b78fc06..46b1ba00 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -130,10 +130,10 @@ caseSimpleOutput = do let j = do jsonMap [ ("foo" , jsonList - [ jsonScalar $ fromByteString "bar" - , jsonScalar $ fromByteString "baz" + [ jsonScalar "bar" + , jsonScalar "baz" ]) ] - "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (renderHtml $ unJson j) + "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j) #endif From db3b29f6b0cb31b90d0d9797e38b1d9b956b16cd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 11 Aug 2010 07:52:38 +0300 Subject: [PATCH 397/624] cassius and julius --- Yesod/Form/Jquery.hs | 6 +++--- Yesod/Form/Nic.hs | 2 +- Yesod/Hamlet.hs | 20 ++++++++++---------- Yesod/Widget.hs | 20 ++++++++++---------- 4 files changed, 24 insertions(+), 24 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 882fdcf2..305ab44c 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -55,7 +55,7 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$jamlet| + addJavaScript [$julius| $$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); |] } @@ -93,7 +93,7 @@ jqueryDayTimeFieldProfile = FieldProfile addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJavaScript [$jamlet| + addJavaScript [$julius| $$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -128,7 +128,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$jamlet| + addJavaScript [$julius| $$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index af87e8ed..402187a5 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -31,7 +31,7 @@ nicHtmlFieldProfile = FieldProfile |] , fpWidget = \name -> do addScript' urlNicEdit - addJavaScript [$jamlet|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] + addJavaScript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 0a3e11da..e472981e 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -15,14 +15,14 @@ module Yesod.Hamlet , string , preEscapedString , cdata - -- ** Jamlet - , jamlet - , Jamlet - , renderJamlet - -- ** Camlet - , camlet - , Camlet - , renderCamlet + -- ** Julius + , julius + , Julius + , renderJulius + -- ** Cassius + , cassius + , Cassius + , renderCassius -- * Convert to something displayable , hamletToContent , hamletToRepHtml @@ -32,8 +32,8 @@ module Yesod.Hamlet where import Text.Hamlet -import Text.Camlet -import Text.Jamlet +import Text.Cassius +import Text.Julius import Yesod.Content import Yesod.Handler diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 6b521f10..adf97951 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -37,8 +37,8 @@ import Control.Monad.Trans.Writer import Control.Monad.Trans.State import Yesod.Hamlet (PageContent (..)) import Text.Hamlet -import Text.Camlet -import Text.Jamlet +import Text.Cassius +import Text.Julius import Yesod.Handler (Route, GHandler, getUrlRenderParams) import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) import Yesod.Content (RepHtml (..)) @@ -80,8 +80,8 @@ newtype GWidget sub master a = GWidget ( WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) ( WriterT (UniqueList (Stylesheet (Route master))) ( - WriterT (Maybe (Camlet (Route master))) ( - WriterT (Maybe (Jamlet (Route master))) ( + WriterT (Maybe (Cassius (Route master))) ( + WriterT (Maybe (Julius (Route master))) ( WriterT (Head (Route master)) ( StateT Int ( GHandler sub master @@ -120,7 +120,7 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do return $ "w" ++ show i' -- | Add some raw CSS to the style tag. -addStyle :: Camlet (Route master) -> GWidget sub master () +addStyle :: Cassius (Route master) -> GWidget sub master () addStyle = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. @@ -148,7 +148,7 @@ addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag. -addJavaScript :: Jamlet (Route master) -> GWidget sub master () +addJavaScript :: Julius (Route master) -> GWidget sub master () addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Apply the default layout to the given widget. @@ -177,10 +177,10 @@ widgetToPageContent (GWidget w) = do let stylesheets = map (locationToHamlet . unStylesheet) $ runUniqueList stylesheets' let cssToHtml (Css b) = Html b - celper :: Camlet url -> Hamlet url + celper :: Cassius url -> Hamlet url celper = fmap cssToHtml jsToHtml (Javascript b) = Html b - jelper :: Jamlet url -> Hamlet url + jelper :: Julius url -> Hamlet url jelper = fmap jsToHtml render <- getUrlRenderParams @@ -194,14 +194,14 @@ widgetToPageContent (GWidget w) = do Nothing -> return Nothing Just s -> do x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCamlet render s + $ renderCassius render s return $ renderLoc x jsLoc <- case jscript of Nothing -> return Nothing Just s -> do x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJamlet render s + $ renderJulius render s return $ renderLoc x let head'' = [$hamlet| From 4d0be9f6725ba7b46b0da4009fb3ba8ecaaa5513 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 11 Aug 2010 14:03:53 +0300 Subject: [PATCH 398/624] base64md5 --- Yesod/Helpers/Static.hs | 15 ++++++++++++++- hellowidget.hs | 20 ++++++++++---------- yesod.cabal | 1 + 3 files changed, 25 insertions(+), 11 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 11fff089..99f85bfe 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -31,6 +31,8 @@ module Yesod.Helpers.Static -- * Lookup files in filesystem , fileLookupDir , staticFiles + -- * Hashing + , base64md5 #if TEST , testSuite #endif @@ -47,6 +49,9 @@ import Web.Routes.Site import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 +import qualified Codec.Binary.Base64Url +import qualified Data.ByteString as S +import qualified Data.Serialize #if TEST import Test.Framework (testGroup, Test) @@ -147,7 +152,7 @@ staticFiles fp = do let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap (show . md5) $ L.readFile $ fp ++ '/' : intercalate "/" f + hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f let qs = ListE [TupE [LitE $ StringL "hash", LitE $ StringL hash]] return [ SigD name $ ConT ''Route `AppT` ConT ''Static @@ -169,3 +174,11 @@ caseGetFileList = do x @?= [["foo"], ["bar", "baz"]] #endif + +-- | md5-hashes the given lazy bytestring and returns the hash as +-- base64url-encoded string. +base64md5 :: L.ByteString -> String +base64md5 = Codec.Binary.Base64Url.encode + . S.unpack + . Data.Serialize.encode + . md5 diff --git a/hellowidget.hs b/hellowidget.hs index a8dfe524..cc9ba2bc 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -19,10 +19,10 @@ mkYesod "HW" [$parseRoutes| instance Yesod HW where approot _ = "" addStaticContent ext _ content = do - let fn = show (md5 content) ++ '.' : ext + let fn = (base64md5 content) ++ '.' : ext liftIO $ createDirectoryIfMissing True "static/tmp" liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn], []) + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) instance YesodNic HW instance YesodJquery HW @@ -33,14 +33,14 @@ wrapper h = [$hamlet| getRootR = applyLayoutW $ flip wrapWidget wrapper $ do i <- newIdent setTitle $ string "Hello Widgets" - addStyle [$camlet| + addStyle [$cassius| #$i$ color:red |] - addStylesheet $ StaticR $ StaticRoute ["style.css"] + addStylesheet $ StaticR $ StaticRoute ["style.css"] [] addStylesheetRemote "http://localhost:3000/static/style2.css" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScript $ StaticR $ StaticRoute ["script.js"] + addScript $ StaticR $ StaticRoute ["script.js"] [] addBody [$hamlet| %h1#$i$ Welcome to my first widget!!! %p @@ -74,12 +74,12 @@ handleFormR = do FormSuccess (_, _, _, _, _, _, _, _, x, _) -> Just x _ -> Nothing applyLayoutW $ do - addStyle [$camlet| + addStyle [$cassius| .tooltip color:#666 font-style:italic |] - addStyle [$camlet| + addStyle [$cassius| textarea.html width:300px height:150px @@ -102,7 +102,7 @@ getAutoCompleteR :: Handler HW RepJson getAutoCompleteR = do term <- runFormGet' $ stringInput "term" jsonToRepJson $ jsonList - [ jsonScalar $ string $ term ++ "foo" - , jsonScalar $ string $ term ++ "bar" - , jsonScalar $ string $ term ++ "baz" + [ jsonScalar $ term ++ "foo" + , jsonScalar $ term ++ "bar" + , jsonScalar $ term ++ "baz" ] diff --git a/yesod.cabal b/yesod.cabal index de1b009b..37b80b44 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -40,6 +40,7 @@ library random >= 1.0.0.2 && < 1.1, control-monad-attempt >= 0.3 && < 0.4, cereal >= 0.2 && < 0.3, + dataenc >= 0.13.0.2 && < 0.14, old-locale >= 1.0.0.2 && < 1.1, persistent >= 0.2.0 && < 0.3, neither >= 0.0.0 && < 0.1, From b11a05d9eb41c33df6fc6fdad73f53be5a447d34 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 11 Aug 2010 15:03:08 +0300 Subject: [PATCH 399/624] ToHtml for setMessage --- Yesod/Handler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a4796f76..f77e97e5 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -332,8 +332,8 @@ msgKey = "_MSG" -- instead, it will only appear in the next request. -- -- See 'getMessage'. -setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . L.toString . renderHtml +setMessage :: ToHtml h => h -> GHandler sub master () +setMessage = setSession msgKey . L.toString . renderHtml . toHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. From 13d3d020a730c0dfa189ba8cbf331df9e2e2e351 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 11 Aug 2010 15:03:25 +0300 Subject: [PATCH 400/624] Shorter URLs for static hashes --- Yesod/Helpers/Static.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 99f85bfe..fcab7875 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -153,7 +153,7 @@ staticFiles fp = do f' <- lift f let sr = ConE $ mkName "StaticRoute" hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL "hash", LitE $ StringL hash]] + let qs = ListE [TupE [LitE $ StringL hash, ListE []]] return [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name @@ -177,8 +177,11 @@ caseGetFileList = do -- | md5-hashes the given lazy bytestring and returns the hash as -- base64url-encoded string. +-- +-- This function returns the first 8 characters of the hash. base64md5 :: L.ByteString -> String -base64md5 = Codec.Binary.Base64Url.encode +base64md5 = take 8 + . Codec.Binary.Base64Url.encode . S.unpack . Data.Serialize.encode . md5 From 1a273387d694b97c90984c2e064b087914ed9756 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 12 Aug 2010 11:41:18 +0300 Subject: [PATCH 401/624] Added urlField --- Yesod/Form.hs | 28 ++++++++++++++++++++++++++++ yesod.cabal | 1 + 2 files changed, 29 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index cd05c30f..8fde8226 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -44,6 +44,7 @@ module Yesod.Form , timeFieldProfile , htmlFieldProfile , emailFieldProfile + , urlFieldProfile , FormFieldSettings (..) , labelSettings -- * Pre-built fields @@ -68,6 +69,8 @@ module Yesod.Form , boolField , emailField , maybeEmailField + , urlField + , maybeUrlField -- * Pre-built inputs , stringInput , maybeStringInput @@ -76,6 +79,7 @@ module Yesod.Form , dayInput , maybeDayInput , emailInput + , urlInput -- * Template Haskell , mkToForm -- * Utilities @@ -102,6 +106,7 @@ import Yesod.Widget import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email import Data.List (group, sort) +import Network.URI (parseURI) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -739,6 +744,29 @@ toLabel (x:rest) = toUpper x : go rest | isUpper c = ' ' : c : go cs | otherwise = c : go cs +urlFieldProfile :: FieldProfile s y String +urlFieldProfile = FieldProfile + { fpParse = \s -> case parseURI s of + Nothing -> Left "Invalid URL" + Just _ -> Right s + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +urlField :: FormFieldSettings -> FormletField sub y String +urlField = requiredFieldHelper urlFieldProfile + +maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeUrlField = optionalFieldHelper urlFieldProfile + +urlInput :: String -> FormInput sub master String +urlInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper urlFieldProfile (nameSettings n) Nothing + emailFieldProfile :: FieldProfile s y String emailFieldProfile = FieldProfile { fpParse = \s -> if Email.isValid s diff --git a/yesod.cabal b/yesod.cabal index 37b80b44..8152a9dc 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -46,6 +46,7 @@ library neither >= 0.0.0 && < 0.1, MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, data-object >= 0.3.1 && < 0.4, + network >= 2.2.1.5 && < 2.3, email-validate >= 0.2.5 && < 0.3 exposed-modules: Yesod Yesod.Content From cc102b67d965e9b598813f3da69e0f177bd01a2b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 15:31:42 +0300 Subject: [PATCH 402/624] IsString instance for FormFieldSettings --- Yesod/Form.hs | 7 +++---- hellowidget.hs | 12 ++++++------ 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 8fde8226..0e83f9ef 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -46,7 +46,6 @@ module Yesod.Form , emailFieldProfile , urlFieldProfile , FormFieldSettings (..) - , labelSettings -- * Pre-built fields , stringField , maybeStringField @@ -107,6 +106,7 @@ import Control.Arrow ((&&&)) import qualified Text.Email.Validate as Email import Data.List (group, sort) import Network.URI (parseURI) +import Data.String (IsString (..)) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -220,6 +220,8 @@ data FormFieldSettings = FormFieldSettings , ffsId :: Maybe String , ffsName :: Maybe String } +instance IsString FormFieldSettings where + fromString s = FormFieldSettings (string s) mempty Nothing Nothing -- | Create a required field (ie, one that cannot be blank) from a -- 'FieldProfile'.ngs @@ -793,9 +795,6 @@ emailInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -labelSettings :: String -> FormFieldSettings -labelSettings l = FormFieldSettings (string l) mempty Nothing Nothing - textareaFieldProfile :: FieldProfile sub y String textareaFieldProfile = FieldProfile { fpParse = Right diff --git a/hellowidget.hs b/hellowidget.hs index cc9ba2bc..b3564e74 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -54,11 +54,11 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do handleFormR = do (res, form, enctype) <- runFormPost $ (,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing - <*> stringField (labelSettings "Another field") (Just "some default text") + <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) - <*> jqueryDayField (labelSettings "A day field") Nothing - <*> timeField (labelSettings "A time field") Nothing - <*> jqueryDayTimeField (labelSettings "A day/time field") Nothing + <*> jqueryDayField ("A day field") Nothing + <*> timeField ("A time field") Nothing + <*> jqueryDayTimeField ("A day/time field") Nothing <*> boolField FormFieldSettings { ffsLabel = "A checkbox" , ffsTooltip = "" @@ -67,9 +67,9 @@ handleFormR = do } (Just False) <*> jqueryAutocompleteField AutoCompleteR (FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing - <*> nicHtmlField (labelSettings "HTML") + <*> nicHtmlField ("HTML") (Just $ string "You can put rich text here") - <*> maybeEmailField (labelSettings "An e-mail addres") Nothing + <*> maybeEmailField ("An e-mail addres") Nothing let mhtml = case res of FormSuccess (_, _, _, _, _, _, _, _, x, _) -> Just x _ -> Nothing From 95392aba0ad539129f8ceb73ccc7a6e9c44958aa Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 15:38:24 +0300 Subject: [PATCH 403/624] Minor code cleanup --- Yesod/Form.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 0e83f9ef..6a7895ed 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -225,11 +225,11 @@ instance IsString FormFieldSettings where -- | Create a required field (ie, one that cannot be blank) from a -- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a -requiredFieldHelper - (FieldProfile parse render mkXml w) - (FormFieldSettings label tooltip theId' name') orig = +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' theId <- maybe newFormIdent return theId' let (res, val) = @@ -256,11 +256,11 @@ requiredFieldHelper -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) -optionalFieldHelper - (FieldProfile parse render mkXml w) - (FormFieldSettings label tooltip theId' name') orig' = +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> FormletField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' name <- maybe newFormIdent return name' theId <- maybe newFormIdent return theId' From 280aa5d543f6839a4edc896109b15968a236a5f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 15:39:15 +0300 Subject: [PATCH 404/624] Foundations for multiForm. Instead of a single integer, we store a list of integers in a form. This allows nesting. Now there are some auxilary functions for nesting level manipulation, as well as a Monoid instance for FormResult. --- Yesod/Form.hs | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 6a7895ed..7ec3afa1 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -31,6 +31,8 @@ module Yesod.Form , optionalFieldHelper , mapFormXml , newFormIdent + , deeperFormIdent + , shallowerFormIdent , fieldsToTable , fieldsToPlain , fieldsToInput @@ -128,6 +130,9 @@ instance Applicative FormResult where (FormFailure x) <*> _ = FormFailure x _ <*> (FormFailure y) = FormFailure y _ <*> _ = FormMissing +instance Monoid m => Monoid (FormResult m) where + mempty = pure mempty + mappend x y = mappend <$> x <*> y -- | The encoding type required by a form. The 'Show' instance produces values -- that can be inserted directly into HTML. @@ -140,10 +145,19 @@ instance Monoid Enctype where mappend UrlEncoded UrlEncoded = UrlEncoded mappend _ _ = Multipart +data Ints = IntCons Int Ints | IntSingle Int +instance Show Ints where + show (IntSingle i) = show i + show (IntCons i is) = show i ++ '-' : show is + +incrInts :: Ints -> Ints +incrInts (IntSingle i) = IntSingle $ i + 1 +incrInts (IntCons i is) = (i + 1) `IntCons` is + -- | A generic form, allowing you to specifying the subsite datatype, master -- site datatype, a datatype for the form XML and the return type. newtype GForm sub y xml a = GForm - { deform :: Env -> FileEnv -> StateT Int (GHandler sub y) (FormResult a, xml, Enctype) + { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) } type Form sub y = GForm sub y (GWidget sub y ()) type Formlet sub y a = Maybe a -> Form sub y a @@ -614,18 +628,29 @@ maybeDayInput n = --------------------- End prebuilt inputs -- | Get a unique identifier. -newFormIdent :: Monad m => StateT Int m String +newFormIdent :: Monad m => StateT Ints m String newFormIdent = do i <- get - let i' = i + 1 + let i' = incrInts i put i' - return $ "f" ++ show i' + return $ 'f' : show i' + +deeperFormIdent :: Monad m => StateT Ints m () +deeperFormIdent = do + i <- get + let i' = 1 `IntCons` incrInts i + put i' + +shallowerFormIdent :: Monad m => StateT Ints m () +shallowerFormIdent = do + IntCons _ i <- get + put i runFormGeneric :: Env -> FileEnv -> GForm sub y xml a -> GHandler sub y (FormResult a, xml, Enctype) -runFormGeneric env fe f = evalStateT (deform f env fe) 1 +runFormGeneric env fe f = evalStateT (deform f env fe) $ IntSingle 1 -- | Run a form against POST parameters. runFormPost :: GForm sub y xml a From 2a19d1a4e82a11a3dd6c3bf89ba72fcfaf4568ec Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 16:09:52 +0300 Subject: [PATCH 405/624] Split Yesod.Form into subfiles --- Yesod/Form.hs | 679 +---------------------------------------- Yesod/Form/Class.hs | 54 ++++ Yesod/Form/Core.hs | 103 +++++++ Yesod/Form/Fields.hs | 376 +++++++++++++++++++++++ Yesod/Form/Jquery.hs | 1 + Yesod/Form/Nic.hs | 1 + Yesod/Form/Profiles.hs | 181 +++++++++++ Yesod/Helpers/Crud.hs | 1 + yesod.cabal | 4 + 9 files changed, 728 insertions(+), 672 deletions(-) create mode 100644 Yesod/Form/Class.hs create mode 100644 Yesod/Form/Core.hs create mode 100644 Yesod/Form/Fields.hs create mode 100644 Yesod/Form/Profiles.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 7ec3afa1..8cff7183 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -1,211 +1,50 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types - GForm (..) - , Form - , Formlet - , FormField - , FormletField - , FormInput + GForm , FormResult (..) , Enctype (..) - , FieldInfo (..) -- * Unwrapping functions , runFormGet , runFormPost , runFormGet' , runFormPost' - -- * Type classes - , ToForm (..) - , ToFormField (..) -- * Field/form helpers - , requiredFieldHelper - , optionalFieldHelper - , mapFormXml - , newFormIdent - , deeperFormIdent - , shallowerFormIdent , fieldsToTable , fieldsToPlain - , fieldsToInput - -- * Field profiles - , FieldProfile (..) - , stringFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , urlFieldProfile - , FormFieldSettings (..) - -- * Pre-built fields - , stringField - , maybeStringField - , textareaField - , maybeTextareaField - , hiddenField - , maybeHiddenField - , intField - , maybeIntField - , doubleField - , maybeDoubleField - , dayField - , maybeDayField - , timeField - , maybeTimeField - , htmlField - , maybeHtmlField - , selectField - , maybeSelectField - , boolField - , emailField - , maybeEmailField - , urlField - , maybeUrlField - -- * Pre-built inputs - , stringInput - , maybeStringInput - , intInput - , boolInput - , dayInput - , maybeDayInput - , emailInput - , urlInput + , module Yesod.Form.Fields -- * Template Haskell , mkToForm - -- * Utilities - , parseDate - , parseTime ) where +import Yesod.Form.Core +import Yesod.Form.Fields +import Yesod.Form.Class + import Text.Hamlet import Yesod.Request import Yesod.Handler import Control.Applicative hiding (optional) -import Data.Time (Day, TimeOfDay(..)) import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class -import Control.Monad ((<=<), liftM, join) -import Data.Monoid (Monoid (..)) +import Control.Monad ((<=<)) import Control.Monad.Trans.State import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..)) import Data.Char (toUpper, isUpper) -import Data.Int (Int64) -import qualified Data.ByteString.Lazy.UTF8 as U import Yesod.Widget import Control.Arrow ((&&&)) -import qualified Text.Email.Validate as Email import Data.List (group, sort) -import Network.URI (parseURI) -import Data.String (IsString (..)) - --- | A form can produce three different results: there was no data available, --- the data was invalid, or there was a successful parse. --- --- The 'Applicative' instance will concatenate the failure messages in two --- 'FormResult's. -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart -instance Show Enctype where - show UrlEncoded = "application/x-www-form-urlencoded" - show Multipart = "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ '-' : show is - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm sub y xml a = GForm - { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) - } -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ \e fe -> do - (res, xml, enc) <- g e fe - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiName :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - } - -type Env = [(String, String)] -type FileEnv = [(String, FileInfo)] - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ const $ const $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ \env fe -> do - (f1, f2, f3) <- f env fe - (g1, g2, g3) <- g env fe - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -- | Display only the actual input widget code, without any decoration. fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y () fieldsToPlain = mapM_ fiInput -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - -- | Display the label, tooltip, input code and errors in a single row of a -- table. fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () @@ -223,429 +62,6 @@ fieldsToTable = mapM_ go %td.errors $err$ |] -class ToForm a y where - toForm :: Maybe a -> Form sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val True) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val False) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) - , fpWidget :: String -> GWidget sub y () - } - ---------------------- Begin prebuilt forms - -stringField :: FormFieldSettings -> FormletField sub y String -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeStringField = optionalFieldHelper stringFieldProfile - -stringFieldProfile :: FieldProfile sub y String -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: Integral i => FormFieldSettings -> FormletField sub y i -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) -maybeIntField = optionalFieldHelper intFieldProfile - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI - , fpRender = showI - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -doubleField :: FormFieldSettings -> FormletField sub y Double -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - , fpWidget = \_name -> return () - } -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -dayField :: FormFieldSettings -> FormletField sub y Day -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) -maybeDayField = optionalFieldHelper dayFieldProfile - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either String TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = - parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = - let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 - in parseTimeHelper (h1', h2', m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper (h1, h2, m1, m2, s1, s2) -parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -timeField :: FormFieldSettings -> FormletField sub y TimeOfDay -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) -maybeTimeField = optionalFieldHelper timeFieldProfile - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime - , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool -boolField ffs orig = GForm $ \env _ -> do - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody [$hamlet| -%input#$theId$!type=checkbox!name=$name$!:val:checked -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) -instance ToFormField Bool y where - toFormField = boolField - -htmlField :: FormFieldSettings -> FormletField sub y Html -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString - , fpRender = U.toString . renderHtml - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea.html#$theId$!name=$name$ $val$ -|] - , fpWidget = const $ return () - } -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -selectField :: Eq x => [(x, String)] - -> FormFieldSettings - -> Maybe x -> FormField sub master x -selectField pairs ffs initial = GForm $ \env _ -> do - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = [$hamlet| -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - -maybeSelectField :: Eq x => [(x, String)] - -> FormFieldSettings - -> FormletField sub master (Maybe x) -maybeSelectField pairs ffs initial' = GForm $ \env _ -> do - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = [$hamlet| -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = addBody input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - ---------------------- End prebuilt forms - ---------------------- Begin prebuilt inputs - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ \env _ -> return - (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| -%input#$n$!type=checkbox!name=$n$ -|], UrlEncoded) - -dayInput :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - ---------------------- End prebuilt inputs - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - runFormGeneric :: Env -> FileEnv -> GForm sub y xml a @@ -770,84 +186,3 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs - -urlFieldProfile :: FieldProfile s y String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } - -urlField :: FormFieldSettings -> FormletField sub y String -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailFieldProfile :: FieldProfile s y String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid s - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| -%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ -|] - , fpWidget = const $ return () - } - -emailField :: FormFieldSettings -> FormletField sub y String -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -textareaFieldProfile :: FieldProfile sub y String -textareaFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea#$theId$!name=$name$ $val$ -|] - , fpWidget = const $ return () - } - -textareaField :: FormFieldSettings -> FormletField sub y String -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenFieldProfile :: FieldProfile sub y String -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| -%input!type=hidden#$theId$!name=$name$!value=$val$ -|] - , fpWidget = const $ return () - } - -hiddenField :: FormFieldSettings -> FormletField sub y String -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) -maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs new file mode 100644 index 00000000..78af7e9c --- /dev/null +++ b/Yesod/Form/Class.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Yesod.Form.Class + ( ToForm (..) + , ToFormField (..) + ) where + +import Text.Hamlet +import Yesod.Form.Fields +import Data.Int (Int64) +import Data.Time (Day, TimeOfDay) + +class ToForm a y where + toForm :: Maybe a -> Form sub y a +class ToFormField a y where + toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a + +instance ToFormField String y where + toFormField = stringField +instance ToFormField (Maybe String) y where + toFormField = maybeStringField + +instance ToFormField Int y where + toFormField = intField +instance ToFormField (Maybe Int) y where + toFormField = maybeIntField +instance ToFormField Int64 y where + toFormField = intField +instance ToFormField (Maybe Int64) y where + toFormField = maybeIntField + +instance ToFormField Double y where + toFormField = doubleField +instance ToFormField (Maybe Double) y where + toFormField = maybeDoubleField + +instance ToFormField Day y where + toFormField = dayField +instance ToFormField (Maybe Day) y where + toFormField = maybeDayField + +instance ToFormField TimeOfDay y where + toFormField = timeField +instance ToFormField (Maybe TimeOfDay) y where + toFormField = maybeTimeField + +instance ToFormField Bool y where + toFormField = boolField + +instance ToFormField Html y where + toFormField = htmlField +instance ToFormField (Maybe Html) y where + toFormField = maybeHtmlField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs new file mode 100644 index 00000000..f05437ec --- /dev/null +++ b/Yesod/Form/Core.hs @@ -0,0 +1,103 @@ +module Yesod.Form.Core + ( FormResult (..) + , GForm (..) + , newFormIdent + , deeperFormIdent + , shallowerFormIdent + , Env + , FileEnv + , Enctype (..) + , Ints (..) + ) where + +import Control.Monad.Trans.State +import Yesod.Handler +import Data.Monoid (Monoid (..)) +import Control.Applicative +import Yesod.Request +import Control.Monad (liftM) + +-- | A form can produce three different results: there was no data available, +-- the data was invalid, or there was a successful parse. +-- +-- The 'Applicative' instance will concatenate the failure messages in two +-- 'FormResult's. +data FormResult a = FormMissing + | FormFailure [String] + | FormSuccess a + deriving Show +instance Functor FormResult where + fmap _ FormMissing = FormMissing + fmap _ (FormFailure errs) = FormFailure errs + fmap f (FormSuccess a) = FormSuccess $ f a +instance Applicative FormResult where + pure = FormSuccess + (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g + (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y + (FormFailure x) <*> _ = FormFailure x + _ <*> (FormFailure y) = FormFailure y + _ <*> _ = FormMissing +instance Monoid m => Monoid (FormResult m) where + mempty = pure mempty + mappend x y = mappend <$> x <*> y + +-- | The encoding type required by a form. The 'Show' instance produces values +-- that can be inserted directly into HTML. +data Enctype = UrlEncoded | Multipart +instance Show Enctype where + show UrlEncoded = "application/x-www-form-urlencoded" + show Multipart = "multipart/form-data" +instance Monoid Enctype where + mempty = UrlEncoded + mappend UrlEncoded UrlEncoded = UrlEncoded + mappend _ _ = Multipart + +data Ints = IntCons Int Ints | IntSingle Int +instance Show Ints where + show (IntSingle i) = show i + show (IntCons i is) = show i ++ '-' : show is + +incrInts :: Ints -> Ints +incrInts (IntSingle i) = IntSingle $ i + 1 +incrInts (IntCons i is) = (i + 1) `IntCons` is + +-- | A generic form, allowing you to specifying the subsite datatype, master +-- site datatype, a datatype for the form XML and the return type. +newtype GForm sub y xml a = GForm + { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) + } + +type Env = [(String, String)] +type FileEnv = [(String, FileInfo)] + +-- | Get a unique identifier. +newFormIdent :: Monad m => StateT Ints m String +newFormIdent = do + i <- get + let i' = incrInts i + put i' + return $ 'f' : show i' + +deeperFormIdent :: Monad m => StateT Ints m () +deeperFormIdent = do + i <- get + let i' = 1 `IntCons` incrInts i + put i' + +shallowerFormIdent :: Monad m => StateT Ints m () +shallowerFormIdent = do + IntCons _ i <- get + put i + +instance Monoid xml => Functor (GForm sub url xml) where + fmap f (GForm g) = + GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) + where + first3 f' (x, y, z) = (f' x, y, z) + +instance Monoid xml => Applicative (GForm sub url xml) where + pure a = GForm $ const $ const $ return (pure a, mempty, mempty) + (GForm f) <*> (GForm g) = GForm $ \env fe -> do + (f1, f2, f3) <- f env fe + (g1, g2, g3) <- g env fe + return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs new file mode 100644 index 00000000..09204f76 --- /dev/null +++ b/Yesod/Form/Fields.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Fields + ( -- * Type synonyms + Form + , Formlet + , FormField + , FormletField + , FormInput + -- * Data types + , FieldInfo (..) + , FormFieldSettings (..) + -- * Fields + -- ** Required + , stringField + , textareaField + , hiddenField + , intField + , doubleField + , dayField + , timeField + , htmlField + , selectField + , boolField + , emailField + , urlField + -- ** Optional + , maybeStringField + , maybeTextareaField + , maybeHiddenField + , maybeIntField + , maybeDoubleField + , maybeDayField + , maybeTimeField + , maybeHtmlField + , maybeSelectField + , maybeEmailField + , maybeUrlField + -- * Inputs + -- ** Required + , stringInput + , intInput + , boolInput + , dayInput + , emailInput + , urlInput + -- ** Optional + , maybeStringInput + , maybeDayInput + -- * Utils + , requiredFieldHelper + , optionalFieldHelper + , fieldsToInput + , mapFormXml + ) where + +import Yesod.Form.Core +import Yesod.Form.Profiles +import Yesod.Widget +import Data.Time (Day, TimeOfDay) +import Text.Hamlet +import Data.Monoid +import Control.Monad (join) +import Data.Maybe (fromMaybe) +import Data.String + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html + , ffsTooltip :: Html + , ffsId :: Maybe String + , ffsName :: Maybe String + } +instance IsString FormFieldSettings where + fromString s = FormFieldSettings (string s) mempty Nothing Nothing + +-- | Using this as the intermediate XML representation for fields allows us to +-- write generic field functions and then different functions for producing +-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. +data FieldInfo sub y = FieldInfo + { fiLabel :: Html + , fiTooltip :: Html + , fiIdent :: String + , fiName :: String + , fiInput :: GWidget sub y () + , fiErrors :: Maybe Html + } + +type Form sub y = GForm sub y (GWidget sub y ()) +type Formlet sub y a = Maybe a -> Form sub y a +type FormField sub y = GForm sub y [FieldInfo sub y] +type FormletField sub y a = Maybe a -> FormField sub y a +type FormInput sub y = GForm sub y [GWidget sub y ()] + +stringField :: FormFieldSettings -> FormletField sub y String +stringField = requiredFieldHelper stringFieldProfile + +maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField = optionalFieldHelper stringFieldProfile + +intInput :: Integral i => String -> FormInput sub master i +intInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper intFieldProfile (nameSettings n) Nothing + +intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField = requiredFieldHelper intFieldProfile + +maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField = optionalFieldHelper intFieldProfile + +doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField = requiredFieldHelper doubleFieldProfile + +maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField = optionalFieldHelper doubleFieldProfile + +dayField :: FormFieldSettings -> FormletField sub y Day +dayField = requiredFieldHelper dayFieldProfile + +maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField = optionalFieldHelper dayFieldProfile + +timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField = requiredFieldHelper timeFieldProfile + +maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField = optionalFieldHelper timeFieldProfile + +boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool +boolField ffs orig = GForm $ \env _ -> do + let label = ffsLabel ffs + tooltip = ffsTooltip ffs + name <- maybe newFormIdent return $ ffsName ffs + theId <- maybe newFormIdent return $ ffsId ffs + let (res, val) = + if null env + then (FormMissing, fromMaybe False orig) + else case lookup name env of + Nothing -> (FormSuccess False, False) + Just _ -> (FormSuccess True, True) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody [$hamlet| +%input#$theId$!type=checkbox!name=$name$!:val:checked +|] + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +htmlField :: FormFieldSettings -> FormletField sub y Html +htmlField = requiredFieldHelper htmlFieldProfile + +maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) +maybeHtmlField = optionalFieldHelper htmlFieldProfile + +selectField :: Eq x => [(x, String)] + -> FormFieldSettings + -> Maybe x -> FormField sub master x +selectField pairs ffs initial = GForm $ \env _ -> do + let label = ffsLabel ffs + tooltip = ffsTooltip ffs + theId <- maybe newFormIdent return $ ffsId ffs + name <- maybe newFormIdent return $ ffsName ffs + let pairs' = zip [1 :: Int ..] pairs + let res = case lookup name env of + Nothing -> FormMissing + Just "none" -> FormFailure ["Field is required"] + Just x -> + case reads x of + (x', _):_ -> + case lookup x' pairs' of + Nothing -> FormFailure ["Invalid entry"] + Just (y, _) -> FormSuccess y + [] -> FormFailure ["Invalid entry"] + let isSelected x = + case res of + FormSuccess y -> x == y + _ -> Just x == initial + let input = [$hamlet| +%select#$theId$!name=$name$ + %option!value=none + $forall pairs' pair + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +maybeSelectField :: Eq x => [(x, String)] + -> FormFieldSettings + -> FormletField sub master (Maybe x) +maybeSelectField pairs ffs initial' = GForm $ \env _ -> do + let initial = join initial' + label = ffsLabel ffs + tooltip = ffsTooltip ffs + theId <- maybe newFormIdent return $ ffsId ffs + name <- maybe newFormIdent return $ ffsName ffs + let pairs' = zip [1 :: Int ..] pairs + let res = case lookup name env of + Nothing -> FormMissing + Just "none" -> FormSuccess Nothing + Just x -> + case reads x of + (x', _):_ -> + case lookup x' pairs' of + Nothing -> FormFailure ["Invalid entry"] + Just (y, _) -> FormSuccess $ Just y + [] -> FormFailure ["Invalid entry"] + let isSelected x = + case res of + FormSuccess y -> Just x == y + _ -> Just x == initial + let input = [$hamlet| +%select#$theId$!name=$name$ + %option!value=none + $forall pairs' pair + %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ +|] + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = addBody input + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +stringInput :: String -> FormInput sub master String +stringInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper stringFieldProfile (nameSettings n) Nothing + +maybeStringInput :: String -> FormInput sub master (Maybe String) +maybeStringInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper stringFieldProfile (nameSettings n) Nothing + +boolInput :: String -> FormInput sub master Bool +boolInput n = GForm $ \env _ -> return + (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| +%input#$n$!type=checkbox!name=$n$ +|], UrlEncoded) + +dayInput :: String -> FormInput sub master Day +dayInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper dayFieldProfile (nameSettings n) Nothing + +maybeDayInput :: String -> FormInput sub master (Maybe Day) +maybeDayInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper dayFieldProfile (nameSettings n) Nothing + +nameSettings :: String -> FormFieldSettings +nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) + +-- | Create a required field (ie, one that cannot be blank) from a +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormMissing, "") + Just "" -> (FormFailure ["Value is required"], "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +-- | Create an optional field (ie, one that can be blank) from a +-- 'FieldProfile'. +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> FormletField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + let orig = join orig' + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormSuccess Nothing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormSuccess Nothing, "") + Just "" -> (FormSuccess Nothing, "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess $ Just y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] +fieldsToInput = map fiInput + +-- | Convert the XML in a 'GForm'. +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + +urlField :: FormFieldSettings -> FormletField sub y String +urlField = requiredFieldHelper urlFieldProfile + +maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeUrlField = optionalFieldHelper urlFieldProfile + +urlInput :: String -> FormInput sub master String +urlInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper urlFieldProfile (nameSettings n) Nothing + +emailField :: FormFieldSettings -> FormletField sub y String +emailField = requiredFieldHelper emailFieldProfile + +maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField = optionalFieldHelper emailFieldProfile + +emailInput :: String -> FormInput sub master String +emailInput n = + mapFormXml fieldsToInput $ + requiredFieldHelper emailFieldProfile (nameSettings n) Nothing + +textareaField :: FormFieldSettings -> FormletField sub y String +textareaField = requiredFieldHelper textareaFieldProfile + +maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeTextareaField = optionalFieldHelper textareaFieldProfile + +hiddenField :: FormFieldSettings -> FormletField sub y String +hiddenField = requiredFieldHelper hiddenFieldProfile + +maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 305ab44c..915a017d 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -12,6 +12,7 @@ module Yesod.Form.Jquery import Yesod.Handler import Yesod.Form +import Yesod.Form.Profiles import Yesod.Widget import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, timeToTimeOfDay) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 402187a5..b0c02192 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -7,6 +7,7 @@ module Yesod.Form.Nic import Yesod.Handler import Yesod.Form +import Yesod.Form.Profiles import Yesod.Hamlet import Yesod.Widget import qualified Data.ByteString.Lazy.UTF8 as U diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs new file mode 100644 index 00000000..b86f8149 --- /dev/null +++ b/Yesod/Form/Profiles.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE QuasiQuotes #-} +module Yesod.Form.Profiles + ( FieldProfile (..) + , stringFieldProfile + , textareaFieldProfile + , hiddenFieldProfile + , intFieldProfile + , dayFieldProfile + , timeFieldProfile + , htmlFieldProfile + , emailFieldProfile + , urlFieldProfile + , doubleFieldProfile + , parseDate + , parseTime + ) where + +import Yesod.Widget +import Yesod.Handler +import Text.Hamlet +import Data.Time (Day, TimeOfDay(..)) +import qualified Data.ByteString.Lazy.UTF8 as U +import qualified Text.Email.Validate as Email +import Network.URI (parseURI) + +-- | A generic definition of a form field that can be used for generating both +-- required and optional fields. See 'requiredFieldHelper and +-- 'optionalFieldHelper'. +data FieldProfile sub y a = FieldProfile + { fpParse :: String -> Either String a + , fpRender :: a -> String + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) + , fpWidget :: String -> GWidget sub y () + } + +intFieldProfile :: Integral i => FieldProfile sub y i +intFieldProfile = FieldProfile + { fpParse = maybe (Left "Invalid integer") Right . readMayI + , fpRender = showI + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + where + showI x = show (fromIntegral x :: Integer) + readMayI s = case reads s of + (x, _):_ -> Just $ fromInteger x + [] -> Nothing + +doubleFieldProfile :: FieldProfile sub y Double +doubleFieldProfile = FieldProfile + { fpParse = maybe (Left "Invalid number") Right . readMay + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +dayFieldProfile :: FieldProfile sub y Day +dayFieldProfile = FieldProfile + { fpParse = parseDate + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +timeFieldProfile :: FieldProfile sub y TimeOfDay +timeFieldProfile = FieldProfile + { fpParse = parseTime + , fpRender = show + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +htmlFieldProfile :: FieldProfile sub y Html +htmlFieldProfile = FieldProfile + { fpParse = Right . preEscapedString + , fpRender = U.toString . renderHtml + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea.html#$theId$!name=$name$ $val$ +|] + , fpWidget = const $ return () + } + +textareaFieldProfile :: FieldProfile sub y String +textareaFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%textarea#$theId$!name=$name$ $val$ +|] + , fpWidget = const $ return () + } + +hiddenFieldProfile :: FieldProfile sub y String +hiddenFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val _isReq -> [$hamlet| +%input!type=hidden#$theId$!name=$name$!value=$val$ +|] + , fpWidget = const $ return () + } + +stringFieldProfile :: FieldProfile sub y String +stringFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ +|] + , fpWidget = \_name -> return () + } + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + (x, _):_ -> Just x + [] -> Nothing + +parseDate :: String -> Either String Day +parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right + . readMay . replace '/' '-' + +-- | Replaces all instances of a value in a list by another value. +-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\z -> if z == x then y else z) + +parseTime :: String -> Either String TimeOfDay +parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = + parseTimeHelper (h1, h2, m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = + let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 + in parseTimeHelper (h1', h2', m1, m2, '0', '0') +parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = + parseTimeHelper (h1, h2, m1, m2, s1, s2) +parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" + +parseTimeHelper :: (Char, Char, Char, Char, Char, Char) + -> Either [Char] TimeOfDay +parseTimeHelper (h1, h2, m1, m2, s1, s2) + | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h + | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m + | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s + | otherwise = Right $ TimeOfDay h m s + where + h = read [h1, h2] + m = read [m1, m2] + s = fromInteger $ read [s1, s2] + +emailFieldProfile :: FieldProfile s y String +emailFieldProfile = FieldProfile + { fpParse = \s -> if Email.isValid s + then Right s + else Left "Invalid e-mail address" + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } + +urlFieldProfile :: FieldProfile s y String +urlFieldProfile = FieldProfile + { fpParse = \s -> case parseURI s of + Nothing -> Left "Invalid URL" + Just _ -> Right s + , fpRender = id + , fpHamlet = \theId name val isReq -> [$hamlet| +%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ +|] + , fpWidget = const $ return () + } diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 446526c1..06c031e6 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -17,6 +17,7 @@ import Yesod.Content import Yesod.Handler import Text.Hamlet import Yesod.Form +import Yesod.Form.Class import Data.Monoid (mempty) import Language.Haskell.TH.Syntax diff --git a/yesod.cabal b/yesod.cabal index 8152a9dc..51bc22bd 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -52,6 +52,10 @@ library Yesod.Content Yesod.Dispatch Yesod.Form + Yesod.Form.Class + Yesod.Form.Core + Yesod.Form.Fields + Yesod.Form.Profiles Yesod.Form.Jquery Yesod.Form.Nic Yesod.Hamlet From c7ac7f191c9cc16984c73a549237e46ae2f22483 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 16:24:51 +0300 Subject: [PATCH 406/624] Minor rearranging and renaming --- Yesod/Form.hs | 8 ++- Yesod/Form/Class.hs | 1 + Yesod/Form/Core.hs | 135 ++++++++++++++++++++++++++++++++++++++++- Yesod/Form/Fields.hs | 118 +---------------------------------- Yesod/Form/Jquery.hs | 2 +- Yesod/Form/Nic.hs | 2 +- Yesod/Form/Profiles.hs | 13 +--- Yesod/Helpers/Crud.hs | 2 +- 8 files changed, 146 insertions(+), 135 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 8cff7183..70eb0882 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -8,7 +8,13 @@ module Yesod.Form ( -- * Data types GForm , FormResult (..) - , Enctype (..) + , Enctype + -- * Type synonyms + , Form + , Formlet + , FormField + , FormletField + , FormInput -- * Unwrapping functions , runFormGet , runFormPost diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 78af7e9c..58c4df15 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -8,6 +8,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields +import Yesod.Form.Core import Data.Int (Int64) import Data.Time (Day, TimeOfDay) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index f05437ec..81aab78d 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Yesod.Form.Core ( FormResult (..) , GForm (..) @@ -8,14 +9,32 @@ module Yesod.Form.Core , FileEnv , Enctype (..) , Ints (..) + , requiredFieldHelper + , optionalFieldHelper + , fieldsToInput + , mapFormXml + -- * Data types + , FieldInfo (..) + , FormFieldSettings (..) + , FieldProfile (..) + -- * Type synonyms + , Form + , Formlet + , FormField + , FormletField + , FormInput ) where import Control.Monad.Trans.State import Yesod.Handler +import Yesod.Widget import Data.Monoid (Monoid (..)) import Control.Applicative import Yesod.Request import Control.Monad (liftM) +import Text.Hamlet +import Data.String +import Control.Monad (join) -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. @@ -44,9 +63,10 @@ instance Monoid m => Monoid (FormResult m) where -- | The encoding type required by a form. The 'Show' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart -instance Show Enctype where - show UrlEncoded = "application/x-www-form-urlencoded" - show Multipart = "multipart/form-data" + deriving (Eq, Enum, Bounded) +instance ToHtml Enctype where + toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" + toHtml Multipart = unsafeByteString "multipart/form-data" instance Monoid Enctype where mempty = UrlEncoded mappend UrlEncoded UrlEncoded = UrlEncoded @@ -101,3 +121,112 @@ instance Monoid xml => Applicative (GForm sub url xml) where (f1, f2, f3) <- f env fe (g1, g2, g3) <- g env fe return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) + +-- | Create a required field (ie, one that cannot be blank) from a +-- 'FieldProfile'.ngs +requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> Maybe a -> FormField sub y a +requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormMissing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormMissing, "") + Just "" -> (FormFailure ["Value is required"], "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val True) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +-- | Create an optional field (ie, one that can be blank) from a +-- 'FieldProfile'. +optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings + -> FormletField sub y (Maybe a) +optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = + GForm $ \env _ -> do + let (FormFieldSettings label tooltip theId' name') = ffs + let orig = join orig' + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let (res, val) = + if null env + then (FormSuccess Nothing, maybe "" render orig) + else case lookup name env of + Nothing -> (FormSuccess Nothing, "") + Just "" -> (FormSuccess Nothing, "") + Just x -> + case parse x of + Left e -> (FormFailure [e], x) + Right y -> (FormSuccess $ Just y, x) + let fi = FieldInfo + { fiLabel = label + , fiTooltip = tooltip + , fiIdent = theId + , fiName = name + , fiInput = w theId >> addBody (mkXml theId name val False) + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + } + return (res, [fi], UrlEncoded) + +fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] +fieldsToInput = map fiInput + +-- | Convert the XML in a 'GForm'. +mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a +mapFormXml f (GForm g) = GForm $ \e fe -> do + (res, xml, enc) <- g e fe + return (res, f xml, enc) + +-- | Using this as the intermediate XML representation for fields allows us to +-- write generic field functions and then different functions for producing +-- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. +data FieldInfo sub y = FieldInfo + { fiLabel :: Html + , fiTooltip :: Html + , fiIdent :: String + , fiName :: String + , fiInput :: GWidget sub y () + , fiErrors :: Maybe Html + } + +data FormFieldSettings = FormFieldSettings + { ffsLabel :: Html + , ffsTooltip :: Html + , ffsId :: Maybe String + , ffsName :: Maybe String + } +instance IsString FormFieldSettings where + fromString s = FormFieldSettings (string s) mempty Nothing Nothing + +-- | A generic definition of a form field that can be used for generating both +-- required and optional fields. See 'requiredFieldHelper and +-- 'optionalFieldHelper'. +data FieldProfile sub y a = FieldProfile + { fpParse :: String -> Either String a + , fpRender :: a -> String + , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) + , fpWidget :: String -> GWidget sub y () + } + +type Form sub y = GForm sub y (GWidget sub y ()) +type Formlet sub y a = Maybe a -> Form sub y a +type FormField sub y = GForm sub y [FieldInfo sub y] +type FormletField sub y a = Maybe a -> FormField sub y a +type FormInput sub y = GForm sub y [GWidget sub y ()] diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 09204f76..846e6b2e 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,17 +1,8 @@ {-# LANGUAGE QuasiQuotes #-} module Yesod.Form.Fields - ( -- * Type synonyms - Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - -- * Fields + ( -- * Fields -- ** Required - , stringField + stringField , textareaField , hiddenField , intField @@ -46,11 +37,6 @@ module Yesod.Form.Fields -- ** Optional , maybeStringInput , maybeDayInput - -- * Utils - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml ) where import Yesod.Form.Core @@ -61,34 +47,6 @@ import Text.Hamlet import Data.Monoid import Control.Monad (join) import Data.Maybe (fromMaybe) -import Data.String - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiName :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] stringField :: FormFieldSettings -> FormletField sub y String stringField = requiredFieldHelper stringFieldProfile @@ -269,78 +227,6 @@ maybeDayInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val True) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = - GForm $ \env _ -> do - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = label - , fiTooltip = tooltip - , fiIdent = theId - , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val False) - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - } - return (res, [fi], UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ \e fe -> do - (res, xml, enc) <- g e fe - return (res, f xml, enc) - urlField :: FormFieldSettings -> FormletField sub y String urlField = requiredFieldHelper urlFieldProfile diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 915a017d..a4c39349 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -11,7 +11,7 @@ module Yesod.Form.Jquery ) where import Yesod.Handler -import Yesod.Form +import Yesod.Form.Core import Yesod.Form.Profiles import Yesod.Widget import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index b0c02192..a52be361 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -6,7 +6,7 @@ module Yesod.Form.Nic ) where import Yesod.Handler -import Yesod.Form +import Yesod.Form.Core import Yesod.Form.Profiles import Yesod.Hamlet import Yesod.Widget diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index b86f8149..557cf2fc 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -15,24 +15,13 @@ module Yesod.Form.Profiles , parseTime ) where -import Yesod.Widget -import Yesod.Handler +import Yesod.Form.Core import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) - , fpWidget :: String -> GWidget sub y () - } - intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 06c031e6..ba22569e 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -160,7 +160,7 @@ crudHelper title me isPost = do %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$ -%form!method=post!enctype=$show.enctype$ +%form!method=post!enctype=$enctype$ %table ^form^ %tr From a609f2d046920743fddf1d2b6f61f583bed542bb Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 16:28:17 +0300 Subject: [PATCH 407/624] Remove need to mapFormXml externally --- Yesod/Form.hs | 9 +++++---- hellowidget.hs | 6 +++--- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 70eb0882..e7c411c6 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -9,6 +9,7 @@ module Yesod.Form GForm , FormResult (..) , Enctype + , FormFieldSettings (..) -- * Type synonyms , Form , Formlet @@ -48,13 +49,13 @@ import Control.Arrow ((&&&)) import Data.List (group, sort) -- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: [FieldInfo sub y] -> GWidget sub y () -fieldsToPlain = mapM_ fiInput +fieldsToPlain :: FormField sub y a -> Form sub y a +fieldsToPlain = mapFormXml $ mapM_ fiInput -- | Display the label, tooltip, input code and errors in a single row of a -- table. -fieldsToTable :: [FieldInfo sub y] -> GWidget sub y () -fieldsToTable = mapM_ go +fieldsToTable :: FormField sub y a -> Form sub y a +fieldsToTable = mapFormXml $ mapM_ go where go fi = do wrapWidget (fiInput fi) $ \w -> [$hamlet| diff --git a/hellowidget.hs b/hellowidget.hs index b3564e74..b4e3fe73 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -52,7 +52,7 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ (,,,,,,,,,) + (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -84,8 +84,8 @@ textarea.html width:300px height:150px |] - wrapWidget (fieldsToTable form) $ \h -> [$hamlet| -%form!method=post!enctype=$show.enctype$ + wrapWidget form $ \h -> [$hamlet| +%form!method=post!enctype=$enctype$ %table ^h^ %tr From b5fa539f1bc4a369b3e7ab639b25d5774e8c908a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 17:16:50 +0300 Subject: [PATCH 408/624] Remove fpHamlet --- Yesod/Form/Class.hs | 4 ++-- Yesod/Form/Core.hs | 12 ++++++------ Yesod/Form/Jquery.hs | 12 ++++++------ Yesod/Form/Nic.hs | 7 ++----- Yesod/Form/Profiles.hs | 34 ++++++++++++---------------------- 5 files changed, 28 insertions(+), 41 deletions(-) diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 58c4df15..83f699c8 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -13,9 +13,9 @@ import Data.Int (Int64) import Data.Time (Day, TimeOfDay) class ToForm a y where - toForm :: Maybe a -> Form sub y a + toForm :: Formlet sub y a class ToFormField a y where - toFormField :: FormFieldSettings -> Maybe a -> FormField sub y a + toFormField :: FormFieldSettings -> FormletField sub y a instance ToFormField String y where toFormField = stringField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 81aab78d..75f4c9e2 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -126,7 +126,7 @@ instance Monoid xml => Applicative (GForm sub url xml) where -- 'FieldProfile'.ngs requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = +requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ \env _ -> do let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' @@ -146,7 +146,7 @@ requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = , fiTooltip = tooltip , fiIdent = theId , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val True) + , fiInput = mkWidget theId name val True , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -157,7 +157,7 @@ requiredFieldHelper (FieldProfile parse render mkXml w) ffs orig = -- 'FieldProfile'. optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = +optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ \env _ -> do let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' @@ -178,7 +178,7 @@ optionalFieldHelper (FieldProfile parse render mkXml w) ffs orig' = , fiTooltip = tooltip , fiIdent = theId , fiName = name - , fiInput = w theId >> addBody (mkXml theId name val False) + , fiInput = mkWidget theId name val False , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -221,8 +221,8 @@ instance IsString FormFieldSettings where data FieldProfile sub y a = FieldProfile { fpParse :: String -> Either String a , fpRender :: a -> String - , fpHamlet :: String -> String -> String -> Bool -> Hamlet (Route y) - , fpWidget :: String -> GWidget sub y () + -- | ID, name, value, required + , fpWidget :: String -> String -> String -> Bool -> GWidget sub y () } type Form sub y = GForm sub y (GWidget sub y ()) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index a4c39349..8f466ebc 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -49,10 +49,10 @@ jqueryDayFieldProfile = FieldProfile Right . readMay , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> do + addBody [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] - , fpWidget = \name -> do addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss @@ -86,10 +86,10 @@ jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> do + addBody [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] - , fpWidget = \name -> do addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker @@ -122,10 +122,10 @@ jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> do + addBody [$hamlet| %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] - , fpWidget = \name -> do addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index a52be361..d6d7c5b1 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -7,7 +7,6 @@ module Yesod.Form.Nic import Yesod.Handler import Yesod.Form.Core -import Yesod.Form.Profiles import Yesod.Hamlet import Yesod.Widget import qualified Data.ByteString.Lazy.UTF8 as U @@ -27,10 +26,8 @@ nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \theId name val _isReq -> [$hamlet| -%textarea.html#$theId$!name=$name$ $val$ -|] - , fpWidget = \name -> do + , fpWidget = \theId name val _isReq -> do + addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit addJavaScript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] } diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 557cf2fc..4ee1bac9 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -1,7 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} module Yesod.Form.Profiles - ( FieldProfile (..) - , stringFieldProfile + ( stringFieldProfile , textareaFieldProfile , hiddenFieldProfile , intFieldProfile @@ -16,6 +15,7 @@ module Yesod.Form.Profiles ) where import Yesod.Form.Core +import Yesod.Widget import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U @@ -26,10 +26,9 @@ intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] - , fpWidget = \_name -> return () } where showI x = show (fromIntegral x :: Integer) @@ -41,70 +40,63 @@ doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] - , fpWidget = \_name -> return () } dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] - , fpWidget = const $ return () } timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] - , fpWidget = const $ return () } htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString , fpRender = U.toString . renderHtml - , fpHamlet = \theId name val _isReq -> [$hamlet| + , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea.html#$theId$!name=$name$ $val$ |] - , fpWidget = const $ return () } textareaFieldProfile :: FieldProfile sub y String textareaFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| + , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea#$theId$!name=$name$ $val$ |] - , fpWidget = const $ return () } hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \theId name val _isReq -> [$hamlet| + , fpWidget = \theId name val _isReq -> addBody [$hamlet| %input!type=hidden#$theId$!name=$name$!value=$val$ |] - , fpWidget = const $ return () } stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] - , fpWidget = \_name -> return () } readMay :: Read a => String -> Maybe a @@ -151,10 +143,9 @@ emailFieldProfile = FieldProfile then Right s else Left "Invalid e-mail address" , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] - , fpWidget = const $ return () } urlFieldProfile :: FieldProfile s y String @@ -163,8 +154,7 @@ urlFieldProfile = FieldProfile Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id - , fpHamlet = \theId name val isReq -> [$hamlet| + , fpWidget = \theId name val isReq -> addBody [$hamlet| %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] - , fpWidget = const $ return () } From 2e4adb55512484eb880f908fca088786031bdf0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 17:29:13 +0300 Subject: [PATCH 409/624] jQuery and Nic fixes --- Yesod/Form/Jquery.hs | 10 +++++----- Yesod/Form/Nic.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 8f466ebc..85d26636 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -34,7 +34,7 @@ class YesodJquery a where -- | jQuery UI time picker add-on. urlJqueryUiDateTimePicker :: a -> Either (Route a) String - urlJqueryUiDateTimePicker _ = Right "http://www.projectcodegen.com/jquery.ui.datetimepicker.js.txt" + urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" jqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y Day jqueryDayField = requiredFieldHelper jqueryDayFieldProfile @@ -57,7 +57,7 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJavaScript [$julius| -$$(function(){$$("#$name$").datepicker({dateFormat:'yy-mm-dd'})}); +$$(function(){$$("#$theId$").datepicker({dateFormat:'yy-mm-dd'})}); |] } @@ -88,14 +88,14 @@ jqueryDayTimeFieldProfile = FieldProfile , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do addBody [$hamlet| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ +%input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss addJavaScript [$julius| -$$(function(){$$("#$name$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); +$$(function(){$$("#$theId$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -130,7 +130,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJavaScript [$julius| -$$(function(){$$("#$name$").autocomplete({source:"@src@",minLength:2})}); +$$(function(){$$("#$theId$").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index d6d7c5b1..e3361548 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -29,7 +29,7 @@ nicHtmlFieldProfile = FieldProfile , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit - addJavaScript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$name$")});|] + addJavaScript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$theId$")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () From 29b38af610371158aea95d8e57a405f45e097e72 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 17:29:43 +0300 Subject: [PATCH 410/624] Added ignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index ed9fa968..08e46243 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ client_session_key.aes *.hi *.o blog.db3 +static/tmp/ From 81cbd67475c56c95f54af649a611e3859c49565f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 13 Aug 2010 17:41:46 +0300 Subject: [PATCH 411/624] Custom form layout example --- hellowidget.hs | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/hellowidget.hs b/hellowidget.hs index b4e3fe73..382420b2 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -3,11 +3,13 @@ import Yesod import Yesod.Widget import Yesod.Helpers.Static import Yesod.Form.Jquery +import Yesod.Form.Core +import Data.Monoid import Yesod.Form.Nic import Control.Applicative import qualified Data.ByteString.Lazy as L import System.Directory -import Data.Digest.Pure.MD5 +import Control.Monad.Trans.Class data HW = HW { hwStatic :: Static } mkYesod "HW" [$parseRoutes| @@ -15,6 +17,7 @@ mkYesod "HW" [$parseRoutes| /form FormR /static StaticR Static hwStatic /autocomplete AutoCompleteR GET +/customform CustomFormR GET |] instance Yesod HW where approot _ = "" @@ -47,6 +50,8 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do %a!href=@RootR@ Recursive link. %p %a!href=@FormR@ Check out the form. +%p + %a!href=@CustomFormR@ Custom form arrangement. %p.noscript Your script did not load. :( |] addHead [$hamlet|%meta!keywords=haskell|] @@ -106,3 +111,28 @@ getAutoCompleteR = do , jsonScalar $ term ++ "bar" , jsonScalar $ term ++ "baz" ] + +data Person = Person String Int +getCustomFormR = do + let customForm = GForm $ \e f -> do + (a1, [b1], c1) <- deform (stringInput "name") e f + (a2, [b2], c2) <- deform (intInput "age") e f + let b = do + b1' <- extractBody b1 + b2' <- extractBody b2 + addBody [$hamlet| +%p This is a custom layout. +%h1 Name Follows! +%p ^b1'^ +%p Age: ^b2'^ +|] + return (Person <$> a1 <*> a2, b , c1 `mappend` c2) + (_, wform, enctype) <- runFormGet customForm + applyLayoutW $ do + form <- extractBody wform + addBody [$hamlet| +%form + ^form^ + %div + %input!type=submit +|] From d0f1c60b634644b9cb1d844a123aa067f61b9c4b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 14 Aug 2010 21:50:56 +0300 Subject: [PATCH 412/624] Added UTF8 path tests --- Yesod.hs | 3 ++- Yesod/Dispatch.hs | 7 +++++- Yesod/Yesod.hs | 60 ++++++++++++++++++++++++++++++++++++++++++++--- runtests.hs | 2 ++ 4 files changed, 67 insertions(+), 5 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 73c3f733..3edf55e7 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,15 +19,16 @@ module Yesod import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) import Yesod.Dispatch hiding (testSuite) +import Yesod.Yesod hiding (testSuite) #else import Yesod.Content import Yesod.Json import Yesod.Dispatch +import Yesod.Yesod #endif import Yesod.Request import Yesod.Form -import Yesod.Yesod import Yesod.Widget import Yesod.Handler hiding (runHandler) import Network.Wai (Application) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 4dc89406..c6bd9e1a 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -23,8 +23,13 @@ module Yesod.Dispatch #endif ) where -import Yesod.Handler +#if TEST +import Yesod.Yesod hiding (testSuite) +#else import Yesod.Yesod +#endif + +import Yesod.Handler import Yesod.Request import Yesod.Internal diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 2ed95adf..06475539 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod ( -- * Type classes @@ -25,28 +26,45 @@ module Yesod.Yesod , defaultErrorHandler -- * Data types , AuthResult (..) +#if TEST + , testSuite +#endif ) where +#if TEST +import Yesod.Content hiding (testSuite) +import Yesod.Json hiding (testSuite) +#else import Yesod.Content +import Yesod.Json +#endif + import Yesod.Request import Yesod.Hamlet import Yesod.Handler import qualified Network.Wai as W -import Yesod.Json import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS import Data.Monoid (mempty) -import Data.ByteString.UTF8 (toString) +import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Network.Wai.Middleware.CleanPath import Web.Routes (encodePathInfo) import qualified Data.ByteString.Lazy as L +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit hiding (Test) +#endif + -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where @@ -250,9 +268,10 @@ applyLayout' s = fmap chooseRep . applyLayout s mempty defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest + let pi = BSU.toString $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $toString.pathInfo.r$ +%p $pi$ |] where pathInfo = W.pathInfo @@ -305,3 +324,38 @@ maybeAuthorized :: Yesod a maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing + +#if TEST +testSuite :: Test +testSuite = testGroup "Yesod.Yesod" + [ testProperty "join/split path" propJoinSplitPath + , testCase "utf8 split path" caseUtf8SplitPath + , testCase "utf8 join path" caseUtf8JoinPath + ] + +data TmpYesod = TmpYesod +data TmpRoute = TmpRoute deriving Eq +type instance Route TmpYesod = TmpRoute +instance Yesod TmpYesod where approot _ = "" + +propJoinSplitPath ss = + splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) + == Right ss' + where + ss' = filter (not . null) ss + +caseUtf8SplitPath :: Assertion +caseUtf8SplitPath = do + Right ["שלום"] @=? + splitPath TmpYesod (BSU.fromString "/שלום/") + Right ["page", "Fooé"] @=? + splitPath TmpYesod (BSU.fromString "/page/Fooé/") + Right ["\156"] @=? + splitPath TmpYesod (BSU.fromString "/\156/") + Right ["ð"] @=? + splitPath TmpYesod (BSU.fromString "/%C3%B0/") + +caseUtf8JoinPath :: Assertion +caseUtf8JoinPath = do + "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] +#endif diff --git a/runtests.hs b/runtests.hs index 208e38fe..7e06ab98 100644 --- a/runtests.hs +++ b/runtests.hs @@ -4,6 +4,7 @@ import qualified Yesod.Content import qualified Yesod.Json import qualified Yesod.Dispatch import qualified Yesod.Helpers.Static +import qualified Yesod.Yesod main :: IO () main = defaultMain @@ -11,4 +12,5 @@ main = defaultMain , Yesod.Json.testSuite , Yesod.Dispatch.testSuite , Yesod.Helpers.Static.testSuite + , Yesod.Yesod.testSuite ] From 476926cb683b5a584d80ecb883d7997edcc9147b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 15 Aug 2010 01:02:15 +0300 Subject: [PATCH 413/624] Added checkForm --- Yesod/Form.hs | 2 ++ Yesod/Form/Core.hs | 10 ++++++++++ Yesod/Yesod.hs | 5 ++--- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index e7c411c6..f2462148 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -24,6 +24,8 @@ module Yesod.Form -- * Field/form helpers , fieldsToTable , fieldsToPlain + , checkForm + -- * Fields , module Yesod.Form.Fields -- * Template Haskell , mkToForm diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 75f4c9e2..e5ddea00 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -13,6 +13,7 @@ module Yesod.Form.Core , optionalFieldHelper , fieldsToInput , mapFormXml + , checkForm -- * Data types , FieldInfo (..) , FormFieldSettings (..) @@ -230,3 +231,12 @@ type Formlet sub y a = Maybe a -> Form sub y a type FormField sub y = GForm sub y [FieldInfo sub y] type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] + +checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b +checkForm f (GForm form) = GForm $ \env fenv -> do + (res, xml, enc) <- form env fenv + let res' = case res of + FormSuccess a -> f a + FormFailure e -> FormFailure e + FormMissing -> FormMissing + return (res', xml, enc) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 06475539..b4c9fb1a 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -53,7 +53,6 @@ import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 import qualified Network.Wai.Middleware.CleanPath import Web.Routes (encodePathInfo) import qualified Data.ByteString.Lazy as L @@ -268,10 +267,10 @@ applyLayout' s = fmap chooseRep . applyLayout s mempty defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let pi = BSU.toString $ pathInfo r + let path = BSU.toString $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $pi$ +%p $path$ |] where pathInfo = W.pathInfo From 2cefc3c2a7eead6e1774d17314a5fd1f92f3e55d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 15 Aug 2010 11:23:46 +0300 Subject: [PATCH 414/624] Form minor changes, setMessage not polymorphic --- Yesod/Form.hs | 7 ++++--- Yesod/Handler.hs | 4 ++-- Yesod/Helpers/Crud.hs | 1 - 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index f2462148..5618e85f 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -8,7 +8,7 @@ module Yesod.Form ( -- * Data types GForm , FormResult (..) - , Enctype + , Enctype (..) , FormFieldSettings (..) -- * Type synonyms , Form @@ -25,10 +25,11 @@ module Yesod.Form , fieldsToTable , fieldsToPlain , checkForm - -- * Fields - , module Yesod.Form.Fields -- * Template Haskell , mkToForm + -- * Re-exports + , module Yesod.Form.Fields + , module Yesod.Form.Class ) where import Yesod.Form.Core diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f77e97e5..a4796f76 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -332,8 +332,8 @@ msgKey = "_MSG" -- instead, it will only appear in the next request. -- -- See 'getMessage'. -setMessage :: ToHtml h => h -> GHandler sub master () -setMessage = setSession msgKey . L.toString . renderHtml . toHtml +setMessage :: Html -> GHandler sub master () +setMessage = setSession msgKey . L.toString . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index ba22569e..88431266 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -17,7 +17,6 @@ import Yesod.Content import Yesod.Handler import Text.Hamlet import Yesod.Form -import Yesod.Form.Class import Data.Monoid (mempty) import Language.Haskell.TH.Syntax From bca631749066f8f50975d12b3225460059e37686 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 16 Aug 2010 14:48:38 +0300 Subject: [PATCH 415/624] GForm uses ReaderT --- Yesod/Form.hs | 4 +++- Yesod/Form/Core.hs | 46 +++++++++++++++++++++++++++++------------- Yesod/Form/Fields.hs | 18 +++++++++++------ Yesod/Form/Profiles.hs | 5 +++++ 4 files changed, 52 insertions(+), 21 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 5618e85f..39ffcb85 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -44,6 +44,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<)) import Control.Monad.Trans.State +import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..)) import Data.Char (toUpper, isUpper) @@ -76,7 +77,8 @@ runFormGeneric :: Env -> FileEnv -> GForm sub y xml a -> GHandler sub y (FormResult a, xml, Enctype) -runFormGeneric env fe f = evalStateT (deform f env fe) $ IntSingle 1 +runFormGeneric env fe (GForm f) = + runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe -- | Run a form against POST parameters. runFormPost :: GForm sub y xml a diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index e5ddea00..46c81f0d 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -14,6 +14,9 @@ module Yesod.Form.Core , fieldsToInput , mapFormXml , checkForm + , askParams + , askFiles + , liftForm -- * Data types , FieldInfo (..) , FormFieldSettings (..) @@ -27,6 +30,8 @@ module Yesod.Form.Core ) where import Control.Monad.Trans.State +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class (lift) import Yesod.Handler import Yesod.Widget import Data.Monoid (Monoid (..)) @@ -85,7 +90,11 @@ incrInts (IntCons i is) = (i + 1) `IntCons` is -- | A generic form, allowing you to specifying the subsite datatype, master -- site datatype, a datatype for the form XML and the return type. newtype GForm sub y xml a = GForm - { deform :: Env -> FileEnv -> StateT Ints (GHandler sub y) (FormResult a, xml, Enctype) + { deform :: StateT Ints ( + ReaderT Env ( + ReaderT FileEnv ( + (GHandler sub y) + ))) (FormResult a, xml, Enctype) } type Env = [(String, String)] @@ -112,23 +121,23 @@ shallowerFormIdent = do instance Monoid xml => Functor (GForm sub url xml) where fmap f (GForm g) = - GForm $ \env fe -> liftM (first3 $ fmap f) (g env fe) + GForm $ liftM (first3 $ fmap f) g where first3 f' (x, y, z) = (f' x, y, z) instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ const $ const $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ \env fe -> do - (f1, f2, f3) <- f env fe - (g1, g2, g3) <- g env fe + pure a = GForm $ return (pure a, mempty, mempty) + (GForm f) <*> (GForm g) = GForm $ do + (f1, f2, f3) <- f + (g1, g2, g3) <- g return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -- | Create a required field (ie, one that cannot be blank) from a -- 'FieldProfile'.ngs requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = - GForm $ \env _ -> do +requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do + env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' theId <- maybe newFormIdent return theId' @@ -158,8 +167,8 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = -- 'FieldProfile'. optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = - GForm $ \env _ -> do +optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do + env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' name <- maybe newFormIdent return name' @@ -191,8 +200,8 @@ fieldsToInput = map fiInput -- | Convert the XML in a 'GForm'. mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ \e fe -> do - (res, xml, enc) <- g e fe +mapFormXml f (GForm g) = GForm $ do + (res, xml, enc) <- g return (res, f xml, enc) -- | Using this as the intermediate XML representation for fields allows us to @@ -233,10 +242,19 @@ type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b -checkForm f (GForm form) = GForm $ \env fenv -> do - (res, xml, enc) <- form env fenv +checkForm f (GForm form) = GForm $ do + (res, xml, enc) <- form let res' = case res of FormSuccess a -> f a FormFailure e -> FormFailure e FormMissing -> FormMissing return (res', xml, enc) + +askParams :: Monad m => StateT Ints (ReaderT Env m) Env +askParams = lift ask + +askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv +askFiles = lift $ lift ask + +liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a +liftForm = lift . lift . lift diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 846e6b2e..bae68238 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -84,7 +84,8 @@ maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) maybeTimeField = optionalFieldHelper timeFieldProfile boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool -boolField ffs orig = GForm $ \env _ -> do +boolField ffs orig = GForm $ do + env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs name <- maybe newFormIdent return $ ffsName ffs @@ -118,7 +119,8 @@ maybeHtmlField = optionalFieldHelper htmlFieldProfile selectField :: Eq x => [(x, String)] -> FormFieldSettings -> Maybe x -> FormField sub master x -selectField pairs ffs initial = GForm $ \env _ -> do +selectField pairs ffs initial = GForm $ do + env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs theId <- maybe newFormIdent return $ ffsId ffs @@ -159,7 +161,8 @@ selectField pairs ffs initial = GForm $ \env _ -> do maybeSelectField :: Eq x => [(x, String)] -> FormFieldSettings -> FormletField sub master (Maybe x) -maybeSelectField pairs ffs initial' = GForm $ \env _ -> do +maybeSelectField pairs ffs initial' = GForm $ do + env <- askParams let initial = join initial' label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -209,10 +212,13 @@ maybeStringInput n = optionalFieldHelper stringFieldProfile (nameSettings n) Nothing boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ \env _ -> return - (FormSuccess $ fromMaybe "" (lookup n env) /= "", return $ addBody [$hamlet| +boolInput n = GForm $ do + env <- askParams + let res = FormSuccess $ fromMaybe "" (lookup n env) /= "" + let xml = addBody [$hamlet| %input#$n$!type=checkbox!name=$n$ -|], UrlEncoded) +|] + return (res, [xml], UrlEncoded) dayInput :: String -> FormInput sub master Day dayInput n = diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 4ee1bac9..ca0e873b 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -10,12 +10,14 @@ module Yesod.Form.Profiles , emailFieldProfile , urlFieldProfile , doubleFieldProfile + , fileFieldProfile , parseDate , parseTime ) where import Yesod.Form.Core import Yesod.Widget +import Yesod.Request import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U @@ -45,6 +47,9 @@ doubleFieldProfile = FieldProfile |] } +fileFieldProfile :: FieldProfile s m FileInfo +fileFieldProfile = undefined -- FIXME + dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate From 6ecf2c4c89602740d6158ac1fd745e794da90bf9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 17 Aug 2010 17:32:19 +0300 Subject: [PATCH 416/624] Some convenience exports --- Yesod.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Yesod.hs b/Yesod.hs index 3edf55e7..eabc19ab 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -11,7 +11,9 @@ module Yesod , module Yesod.Json , module Yesod.Widget , Application + , lift , liftIO + , MonadCatchIO , mempty ) where @@ -33,5 +35,7 @@ import Yesod.Widget import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet +import "transformers" Control.Monad.Trans.Class (lift) import "transformers" Control.Monad.IO.Class (liftIO) +import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import Data.Monoid (mempty) From cfffdd9cb3d05cb85fb0dd0591c5a2c28d0bbe0c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 17 Aug 2010 17:33:51 +0300 Subject: [PATCH 417/624] Hiding lift in Static --- Yesod/Helpers/Static.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index fcab7875..4ed310a9 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -42,7 +42,7 @@ import System.Directory import Control.Monad import Data.Maybe (fromMaybe) -import Yesod +import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax import Web.Routes.Site From 799ee875f612c7bee02877239980c307e25e3112 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 17 Aug 2010 23:58:29 +0300 Subject: [PATCH 418/624] Minor fixes for the auth module --- Yesod/Helpers/Auth.hs | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index f80a8521..4d78071c 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -100,7 +100,12 @@ type SaltedPass = String type VerStatus = Bool -- | Data stored in a database for each e-mail address. -data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey +data EmailCreds = EmailCreds + { emailCredsId :: EmailId + , emailCredsPass :: Maybe SaltedPass + , emailCredsStatus :: VerStatus + , emailCredsVerkey :: Maybe VerKey + } -- | For a sample set of settings for a trivial in-memory database, see -- 'inMemoryEmailSettings'. @@ -108,6 +113,7 @@ data AuthEmailSettings = AuthEmailSettings { addUnverified :: Email -> VerKey -> IO EmailId , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () , getVerifyKey :: EmailId -> IO (Maybe VerKey) + , setVerifyKey :: EmailId -> VerKey -> IO () , verifyAccount :: EmailId -> IO () , setPassword :: EmailId -> String -> IO () , getEmailCreds :: Email -> IO (Maybe EmailCreds) @@ -148,11 +154,11 @@ mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] [$parseRoutes| -/check Check GET -/logout Logout GET +/check CheckR GET +/logout LogoutR GET /openid OpenIdR GET -/openid/forward OpenIdForward GET -/openid/complete OpenIdComplete GET +/openid/forward OpenIdForwardR GET +/openid/complete OpenIdCompleteR GET /login/rpxnow RpxnowR /facebook FacebookR GET @@ -312,11 +318,15 @@ postEmailRegisterR = do mecreds <- liftIO $ getEmailCreds ae email (lid, verKey) <- case mecreds of + Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) + Just (EmailCreds lid _ _ Nothing) -> liftIO $ do + key <- randomKey y + setVerifyKey ae lid key + return (lid, key) Nothing -> liftIO $ do key <- randomKey y lid <- addUnverified ae email key return (lid, key) - Just (EmailCreds lid _ _ key) -> return (lid, key) render <- getUrlRender tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey @@ -471,12 +481,14 @@ inMemoryEmailSettings = do { addUnverified = \email verkey -> modifyMVar mm $ \m -> do let helper (_, EmailCreds x _ _ _) = x let newId = 1 + maximum (0 : map helper m) - let ec = EmailCreds newId Nothing False verkey + let ec = EmailCreds newId Nothing False $ Just verkey return ((email, ec) : m, newId) , sendVerifyEmail = \_email _verkey verurl -> hPutStrLn stderr $ "Please go to: " ++ verurl , getVerifyKey = \eid -> withMVar mm $ \m -> return $ - lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m + join $ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m + , setVerifyKey = \eid key -> modifyMVar_ mm $ \m -> return $ + map (setHelper eid key) m , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid) , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass) , getEmailCreds = \email -> withMVar mm $ return . lookup email @@ -486,6 +498,9 @@ inMemoryEmailSettings = do _ -> Nothing } where + setHelper eid key pair@(k, EmailCreds eid' b c _) + | eid == eid' = (k, EmailCreds eid b c $ Just key) + | otherwise = pair vago eid (email, EmailCreds eid' pass status key) | eid == eid' = (email, EmailCreds eid pass True key) | otherwise = (email, EmailCreds eid' pass status key) From 24e6806cde59facdb431a96204a3148ca5935253 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 18 Aug 2010 00:01:03 +0300 Subject: [PATCH 419/624] Bug fixes for last change --- Yesod/Helpers/Auth.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 4d78071c..d33b3618 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -184,19 +184,19 @@ getOpenIdR = do applyLayout "Log in via OpenID" mempty [$hamlet| $maybe message msg %p.message $msg$ -%form!method=get!action=@rtom.OpenIdForward@ +%form!method=get!action=@rtom.OpenIdForwardR@ %label!for=openid OpenID: $ %input#openid!type=text!name=openid %input!type=submit!value=Login |] -getOpenIdForward :: GHandler Auth master () -getOpenIdForward = do +getOpenIdForwardR :: GHandler Auth master () +getOpenIdForwardR = do testOpenId oid <- runFormGet' $ stringInput "openid" render <- getUrlRender toMaster <- getRouteToMaster - let complete = render $ toMaster OpenIdComplete + let complete = render $ toMaster OpenIdCompleteR res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt (\err -> do @@ -205,8 +205,8 @@ getOpenIdForward = do (redirectString RedirectTemporary) res -getOpenIdComplete :: YesodAuth master => GHandler Auth master () -getOpenIdComplete = do +getOpenIdCompleteR :: YesodAuth master => GHandler Auth master () +getOpenIdCompleteR = do testOpenId rr <- getRequest let gets' = reqGetParams rr @@ -258,8 +258,8 @@ getDisplayName extra = where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] -getCheck :: Yesod master => GHandler Auth master RepHtmlJson -getCheck = do +getCheckR :: Yesod master => GHandler Auth master RepHtmlJson +getCheckR = do creds <- maybeCreds applyLayoutJson "Authentication Status" mempty (html creds) (json creds) where @@ -277,8 +277,8 @@ $maybe creds c $ creds >>= credsDisplayName) ] -getLogout :: YesodAuth master => GHandler Auth master () -getLogout = do +getLogoutR :: YesodAuth master => GHandler Auth master () +getLogoutR = do y <- getYesod deleteSession credsKey redirectUltDest RedirectTemporary $ defaultDest y From adc8a8cf6325baa6d4d793e8e4100ae07323e656 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 18 Aug 2010 06:59:26 +0300 Subject: [PATCH 420/624] Textarea --- Yesod/Form.hs | 2 ++ Yesod/Form/Class.hs | 6 ++++++ Yesod/Form/Fields.hs | 4 ++-- Yesod/Form/Profiles.hs | 30 +++++++++++++++++++++++++++--- hellowidget.hs | 16 +++++++++++----- 5 files changed, 48 insertions(+), 10 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 39ffcb85..e65c898a 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -10,6 +10,7 @@ module Yesod.Form , FormResult (..) , Enctype (..) , FormFieldSettings (..) + , Textarea (..) -- * Type synonyms , Form , Formlet @@ -35,6 +36,7 @@ module Yesod.Form import Yesod.Form.Core import Yesod.Form.Fields import Yesod.Form.Class +import Yesod.Form.Profiles (Textarea (..)) import Text.Hamlet import Yesod.Request diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 83f699c8..290b15d7 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -9,6 +9,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields import Yesod.Form.Core +import Yesod.Form.Profiles (Textarea) import Data.Int (Int64) import Data.Time (Day, TimeOfDay) @@ -53,3 +54,8 @@ instance ToFormField Html y where toFormField = htmlField instance ToFormField (Maybe Html) y where toFormField = maybeHtmlField + +instance ToFormField Textarea y where + toFormField = textareaField +instance ToFormField (Maybe Textarea) y where + toFormField = maybeTextareaField diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index bae68238..b1c3f229 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -255,10 +255,10 @@ emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing -textareaField :: FormFieldSettings -> FormletField sub y String +textareaField :: FormFieldSettings -> FormletField sub y Textarea textareaField = requiredFieldHelper textareaFieldProfile -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile hiddenField :: FormFieldSettings -> FormletField sub y String diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index ca0e873b..521a7cd1 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -1,4 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile @@ -13,6 +15,7 @@ module Yesod.Form.Profiles , fileFieldProfile , parseDate , parseTime + , Textarea (..) ) where import Yesod.Form.Core @@ -23,6 +26,10 @@ import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) +import Database.Persist (PersistField) + +import Text.Blaze.Builder.Utf8 (writeChar) +import Text.Blaze.Builder.Core (writeList, writeByteString) intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile @@ -77,10 +84,27 @@ htmlFieldProfile = FieldProfile |] } -textareaFieldProfile :: FieldProfile sub y String +-- | A newtype wrapper around a 'String' that converts newlines to HTML +-- br-tags. +newtype Textarea = Textarea { unTextarea :: String } + deriving (Show, Read, Eq, PersistField) +instance ToHtml Textarea where + toHtml = + Html . writeList writeHtmlEscapedChar . unTextarea + where + -- Taken from blaze-builder and modified with newline handling. + writeHtmlEscapedChar '<' = writeByteString "<" + writeHtmlEscapedChar '>' = writeByteString ">" + writeHtmlEscapedChar '&' = writeByteString "&" + writeHtmlEscapedChar '"' = writeByteString """ + writeHtmlEscapedChar '\'' = writeByteString "'" + writeHtmlEscapedChar '\n' = writeByteString "<br>" + writeHtmlEscapedChar c = writeChar c + +textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id + { fpParse = Right . Textarea + , fpRender = unTextarea , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea#$theId$!name=$name$ $val$ |] diff --git a/hellowidget.hs b/hellowidget.hs index 382420b2..8c346952 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -57,7 +57,7 @@ getRootR = applyLayoutW $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,) + (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -75,8 +75,12 @@ handleFormR = do <*> nicHtmlField ("HTML") (Just $ string "You can put rich text here") <*> maybeEmailField ("An e-mail addres") Nothing + <*> maybeTextareaField "A text area" Nothing let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, _, x, _) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, x, _, _) -> Just x + _ -> Nothing + let txt = case res of + FormSuccess (_, _, _, _, _, _, _, _, _, _, Just x) -> Just x _ -> Nothing applyLayoutW $ do addStyle [$cassius| @@ -98,6 +102,8 @@ textarea.html %input!type=submit $maybe mhtml html $html$ + $maybe txt t + $t$ |] setTitle $ string "Form" @@ -114,9 +120,9 @@ getAutoCompleteR = do data Person = Person String Int getCustomFormR = do - let customForm = GForm $ \e f -> do - (a1, [b1], c1) <- deform (stringInput "name") e f - (a2, [b2], c2) <- deform (intInput "age") e f + let customForm = GForm $ do + (a1, [b1], c1) <- deform $ stringInput "name" + (a2, [b2], c2) <- deform $ intInput "age" let b = do b1' <- extractBody b1 b2' <- extractBody b2 From f7dc45eb9e878b06b06a2cd8720b0e74f248a409 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 18 Aug 2010 07:15:12 +0300 Subject: [PATCH 421/624] addJavaScript -> addJavascript --- Yesod/Form/Jquery.hs | 6 +++--- Yesod/Form/Nic.hs | 2 +- Yesod/Widget.hs | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 85d26636..deef1118 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -56,7 +56,7 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$julius| + addJavascript [$julius| $$(function(){$$("#$theId$").datepicker({dateFormat:'yy-mm-dd'})}); |] } @@ -94,7 +94,7 @@ jqueryDayTimeFieldProfile = FieldProfile addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJavaScript [$julius| + addJavascript [$julius| $$(function(){$$("#$theId$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -129,7 +129,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavaScript [$julius| + addJavascript [$julius| $$(function(){$$("#$theId$").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index e3361548..c1f6111f 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -29,7 +29,7 @@ nicHtmlFieldProfile = FieldProfile , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit - addJavaScript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$theId$")});|] + addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$theId$")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index adf97951..263fd8a2 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -25,7 +25,7 @@ module Yesod.Widget , addScriptEither , addHead , addBody - , addJavaScript + , addJavascript -- * Manipulating , wrapWidget , extractBody @@ -148,8 +148,8 @@ addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag. -addJavaScript :: Julius (Route master) -> GWidget sub master () -addJavaScript = GWidget . lift . lift . lift . lift . lift. tell . Just +addJavascript :: Julius (Route master) -> GWidget sub master () +addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Apply the default layout to the given widget. applyLayoutW :: (Eq (Route m), Yesod m) From 6bef4e5018218b0af53a3e4f895a61737de0e558 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 19 Aug 2010 09:45:07 +0300 Subject: [PATCH 422/624] Auth -> Auth master --- Yesod/Helpers/Auth.hs | 102 +++++++++++++++++++++--------------------- 1 file changed, 51 insertions(+), 51 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d33b3618..d4f58290 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -66,24 +66,24 @@ class Yesod master => YesodAuth master where -- -- The second parameter can contain various information, depending on login -- mechanism. - onLogin :: Creds -> [(String, String)] -> GHandler Auth master () + onLogin :: Creds -> [(String, String)] -> GHandler (Auth master) master () onLogin _ _ = return () -- | Generate a random alphanumeric string. -- -- This is used for verify string in email authentication. - randomKey :: master -> IO String - randomKey _ = do + randomKey :: master -> GHandler (Auth master) master String + randomKey _ = liftIO $ do stdgen <- newStdGen return $ take 10 $ randomRs ('A', 'Z') stdgen -- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its -- own settings. If those settings are not present, then relevant handlers will -- simply return a 404. -data Auth = Auth +data Auth m = Auth { authIsOpenIdEnabled :: Bool , authRpxnowApiKey :: Maybe String - , authEmailSettings :: Maybe AuthEmailSettings + , authEmailSettings :: Maybe (AuthEmailSettings m) -- | client id, secret and requested permissions , authFacebook :: Maybe (String, String, [String]) } @@ -109,15 +109,15 @@ data EmailCreds = EmailCreds -- | For a sample set of settings for a trivial in-memory database, see -- 'inMemoryEmailSettings'. -data AuthEmailSettings = AuthEmailSettings - { addUnverified :: Email -> VerKey -> IO EmailId - , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO () - , getVerifyKey :: EmailId -> IO (Maybe VerKey) - , setVerifyKey :: EmailId -> VerKey -> IO () - , verifyAccount :: EmailId -> IO () - , setPassword :: EmailId -> String -> IO () - , getEmailCreds :: Email -> IO (Maybe EmailCreds) - , getEmail :: EmailId -> IO (Maybe Email) +data AuthEmailSettings m = AuthEmailSettings + { addUnverified :: Email -> VerKey -> GHandler (Auth m) m EmailId + , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler (Auth m) m () + , getVerifyKey :: EmailId -> GHandler (Auth m) m (Maybe VerKey) + , setVerifyKey :: EmailId -> VerKey -> GHandler (Auth m) m () + , verifyAccount :: EmailId -> GHandler (Auth m) m () + , setPassword :: EmailId -> String -> GHandler (Auth m) m () + , getEmailCreds :: Email -> GHandler (Auth m) m (Maybe EmailCreds) + , getEmail :: EmailId -> GHandler (Auth m) m (Maybe Email) } -- | User credentials @@ -135,7 +135,7 @@ credsKey :: String credsKey = "_CREDS" setCreds :: YesodAuth master - => Creds -> [(String, String)] -> GHandler Auth master () + => Creds -> [(String, String)] -> GHandler (Auth master) master () setCreds creds extra = do setSession credsKey $ show creds onLogin creds extra @@ -150,7 +150,7 @@ maybeCreds = do (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth" +mkYesodSub "Auth master" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] [$parseRoutes| @@ -170,12 +170,12 @@ mkYesodSub "Auth" /set-password EmailPasswordR GET POST |] -testOpenId :: GHandler Auth master () +testOpenId :: GHandler (Auth master) master () testOpenId = do a <- getYesodSub unless (authIsOpenIdEnabled a) notFound -getOpenIdR :: Yesod master => GHandler Auth master RepHtml +getOpenIdR :: Yesod master => GHandler (Auth master) master RepHtml getOpenIdR = do testOpenId lookupGetParam "dest" >>= maybe (return ()) setUltDestString @@ -190,7 +190,7 @@ $maybe message msg %input!type=submit!value=Login |] -getOpenIdForwardR :: GHandler Auth master () +getOpenIdForwardR :: GHandler (Auth master) master () getOpenIdForwardR = do testOpenId oid <- runFormGet' $ stringInput "openid" @@ -205,7 +205,7 @@ getOpenIdForwardR = do (redirectString RedirectTemporary) res -getOpenIdCompleteR :: YesodAuth master => GHandler Auth master () +getOpenIdCompleteR :: YesodAuth master => GHandler (Auth master) master () getOpenIdCompleteR = do testOpenId rr <- getRequest @@ -221,7 +221,7 @@ getOpenIdCompleteR = do redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: YesodAuth master => GHandler Auth master () +handleRpxnowR :: YesodAuth master => GHandler (Auth master) master () handleRpxnowR = do ay <- getYesod auth <- getYesodSub @@ -258,7 +258,7 @@ getDisplayName extra = where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] -getCheckR :: Yesod master => GHandler Auth master RepHtmlJson +getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson getCheckR = do creds <- maybeCreds applyLayoutJson "Authentication Status" mempty (html creds) (json creds) @@ -277,7 +277,7 @@ $maybe creds c $ creds >>= credsDisplayName) ] -getLogoutR :: YesodAuth master => GHandler Auth master () +getLogoutR :: YesodAuth master => GHandler (Auth master) master () getLogoutR = do y <- getYesod deleteSession credsKey @@ -295,10 +295,10 @@ requireCreds = setUltDest' redirect RedirectTemporary $ defaultLoginRoute y -getAuthEmailSettings :: GHandler Auth master AuthEmailSettings +getAuthEmailSettings :: GHandler (Auth master) master (AuthEmailSettings master) getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings -getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml +getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -310,40 +310,40 @@ getEmailRegisterR = do %input!type=submit!value=Register |] -postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml +postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings email <- runFormPost' $ emailInput "email" y <- getYesod - mecreds <- liftIO $ getEmailCreds ae email + mecreds <- getEmailCreds ae email (lid, verKey) <- case mecreds of Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) - Just (EmailCreds lid _ _ Nothing) -> liftIO $ do + Just (EmailCreds lid _ _ Nothing) -> do key <- randomKey y setVerifyKey ae lid key return (lid, key) - Nothing -> liftIO $ do + Nothing -> do key <- randomKey y lid <- addUnverified ae email key return (lid, key) render <- getUrlRender tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey - liftIO $ sendVerifyEmail ae email verKey verUrl + sendVerifyEmail ae email verKey verUrl applyLayout "Confirmation e-mail sent" mempty [$hamlet| %p A confirmation e-mail has been sent to $email$. |] getEmailVerifyR :: YesodAuth master - => Integer -> String -> GHandler Auth master RepHtml + => Integer -> String -> GHandler (Auth master) master RepHtml getEmailVerifyR lid key = do ae <- getAuthEmailSettings - realKey <- liftIO $ getVerifyKey ae lid - memail <- liftIO $ getEmail ae lid + realKey <- getVerifyKey ae lid + memail <- getEmail ae lid case (realKey == Just key, memail) of (True, Just email) -> do - liftIO $ verifyAccount ae lid + verifyAccount ae lid setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) Nothing) [] toMaster <- getRouteToMaster @@ -352,7 +352,7 @@ getEmailVerifyR lid key = do %p I'm sorry, but that was an invalid verification key. |] -getEmailLoginR :: Yesod master => GHandler Auth master RepHtml +getEmailLoginR :: Yesod master => GHandler (Auth master) master RepHtml getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -378,14 +378,14 @@ $maybe msg ms %input!type=submit!value=Login |] -postEmailLoginR :: YesodAuth master => GHandler Auth master () +postEmailLoginR :: YesodAuth master => GHandler (Auth master) master () postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost' $ (,) <$> emailInput "email" <*> stringInput "password" y <- getYesod - mecreds <- liftIO $ getEmailCreds ae email + mecreds <- getEmailCreds ae email let mlid = case mecreds of Just (EmailCreds lid (Just realpass) True _) -> @@ -401,7 +401,7 @@ postEmailLoginR = do toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailLoginR -getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml +getEmailPasswordR :: Yesod master => GHandler (Auth master) master RepHtml getEmailPasswordR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -431,7 +431,7 @@ $maybe msg ms %input!type=submit!value=Submit |] -postEmailPasswordR :: YesodAuth master => GHandler Auth master () +postEmailPasswordR :: YesodAuth master => GHandler (Auth master) master () postEmailPasswordR = do ae <- getAuthEmailSettings (new, confirm) <- runFormPost' $ (,) @@ -448,7 +448,7 @@ postEmailPasswordR = do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR salted <- liftIO $ saltPass new - liftIO $ setPassword ae lid salted + setPassword ae lid salted setMessage $ string "Password updated" redirect RedirectTemporary $ toMaster EmailLoginR @@ -474,25 +474,25 @@ saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) -- | A simplistic set of email settings, useful only for testing purposes. In -- particular, it doesn't actually send emails, but instead prints verification -- URLs to stderr. -inMemoryEmailSettings :: IO AuthEmailSettings +inMemoryEmailSettings :: IO (AuthEmailSettings a) inMemoryEmailSettings = do mm <- newMVar [] return AuthEmailSettings - { addUnverified = \email verkey -> modifyMVar mm $ \m -> do + { addUnverified = \email verkey -> liftIO $ modifyMVar mm $ \m -> do let helper (_, EmailCreds x _ _ _) = x let newId = 1 + maximum (0 : map helper m) let ec = EmailCreds newId Nothing False $ Just verkey return ((email, ec) : m, newId) - , sendVerifyEmail = \_email _verkey verurl -> + , sendVerifyEmail = \_email _verkey verurl -> liftIO $ hPutStrLn stderr $ "Please go to: " ++ verurl - , getVerifyKey = \eid -> withMVar mm $ \m -> return $ + , getVerifyKey = \eid -> liftIO $ withMVar mm $ \m -> return $ join $ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m - , setVerifyKey = \eid key -> modifyMVar_ mm $ \m -> return $ + , setVerifyKey = \eid key -> liftIO $ modifyMVar_ mm $ \m -> return $ map (setHelper eid key) m - , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid) - , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass) - , getEmailCreds = \email -> withMVar mm $ return . lookup email - , getEmail = \eid -> withMVar mm $ \m -> return $ + , verifyAccount = \eid -> liftIO $ modifyMVar_ mm $ return . map (vago eid) + , setPassword = \eid pass -> liftIO $ modifyMVar_ mm $ return . map (spgo eid pass) + , getEmailCreds = \email -> liftIO $ withMVar mm $ return . lookup email + , getEmail = \eid -> liftIO $ withMVar mm $ \m -> return $ case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of ((email, _):_) -> Just email _ -> Nothing @@ -508,7 +508,7 @@ inMemoryEmailSettings = do | eid == eid' = (email, EmailCreds eid (Just pass) status key) | otherwise = (email, EmailCreds eid' pass' status key) -getFacebookR :: YesodAuth master => GHandler Auth master () +getFacebookR :: YesodAuth master => GHandler (Auth master) master () getFacebookR = do y <- getYesod a <- authFacebook <$> getYesodSub @@ -531,7 +531,7 @@ getFacebookR = do setCreds c [] redirectUltDest RedirectTemporary $ defaultDest y -getStartFacebookR :: GHandler Auth master () +getStartFacebookR :: GHandler (Auth master) master () getStartFacebookR = do y <- getYesodSub case authFacebook y of From c7ddc8415db5e16879b0dddacd7685b13e04ad16 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 19 Aug 2010 21:04:35 +0300 Subject: [PATCH 423/624] Imported all web-routes dependencies --- Yesod/Dispatch.hs | 2 +- Yesod/Helpers/Static.hs | 2 +- Yesod/WebRoutes.hs | 88 +++++++++++++++++++++++++++++++++++++++++ Yesod/Yesod.hs | 3 +- yesod.cabal | 2 +- 5 files changed, 92 insertions(+), 5 deletions(-) create mode 100644 Yesod/WebRoutes.hs diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index c6bd9e1a..2ca147b5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -36,8 +36,8 @@ import Yesod.Internal import Web.Routes.Quasi import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH -import Web.Routes.Site import Language.Haskell.TH.Syntax +import Yesod.WebRoutes import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath (cleanPathFunc) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 4ed310a9..593dd5d7 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -45,13 +45,13 @@ import Data.Maybe (fromMaybe) import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax -import Web.Routes.Site import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 import qualified Codec.Binary.Base64Url import qualified Data.ByteString as S import qualified Data.Serialize +import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/WebRoutes.hs b/Yesod/WebRoutes.hs new file mode 100644 index 00000000..07d08288 --- /dev/null +++ b/Yesod/WebRoutes.hs @@ -0,0 +1,88 @@ +-- | This module should be removed when web-routes incorporates necessary support. +module Yesod.WebRoutes + ( encodePathInfo + , Site (..) + ) where + +import Codec.Binary.UTF8.String (encodeString) +import Data.List (intercalate) +import Network.URI + +encodePathInfo :: [String] -> [(String, String)] -> String +encodePathInfo pieces qs = + let x = map encodeString `o` -- utf-8 encode the data characters in path components (we have not added any delimiters yet) + map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o` -- percent encode the characters + map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o` -- encode . and .. + intercalate "/" -- add in the delimiters + y = showParams qs + in x pieces ++ y + where + -- reverse composition + o :: (a -> b) -> (b -> c) -> a -> c + o = flip (.) + +{-| + +A site groups together the three functions necesary to make an application: + +* A function to convert from the URL type to path segments. + +* A function to convert from path segments to the URL, if possible. + +* A function to return the application for a given URL. + +There are two type parameters for Site: the first is the URL datatype, the +second is the application datatype. The application datatype will depend upon +your server backend. +-} +data Site url a + = Site { + {-| + Return the appropriate application for a given URL. + + The first argument is a function which will give an appropriate + URL (as a String) for a URL datatype. This is usually + constructed by a combination of 'formatPathSegments' and the + prepending of an absolute application root. + + Well behaving applications should use this function to + generating all internal URLs. + -} + handleSite :: (url -> [(String, String)] -> String) -> url -> a + -- | This function must be the inverse of 'parsePathSegments'. + , formatPathSegments :: url -> ([String], [(String, String)]) + -- | This function must be the inverse of 'formatPathSegments'. + , parsePathSegments :: [String] -> Either String url + } + +showParams :: [(String, String)] -> String +showParams [] = "" +showParams z = + '?' : intercalate "&" (map go z) + where + go (x, "") = go' x + go (x, y) = go' x ++ '=' : go' y + go' = concatMap encodeUrlChar + +-- | Taken straight from web-encodings; reimplemented here to avoid extra +-- dependencies. +encodeUrlChar :: Char -> String +encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] +encodeUrlChar c@'-' = [c] +encodeUrlChar c@'_' = [c] +encodeUrlChar c@'.' = [c] +encodeUrlChar c@'~' = [c] +encodeUrlChar ' ' = "+" +encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b4c9fb1a..5f50b5dc 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -49,13 +49,12 @@ import qualified Web.ClientSession as CS import Data.Monoid (mempty) import qualified Data.ByteString.UTF8 as BSU import Database.Persist -import Web.Routes.Site (Site) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Attempt (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath -import Web.Routes (encodePathInfo) import qualified Data.ByteString.Lazy as L +import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test) diff --git a/yesod.cabal b/yesod.cabal index 51bc22bd..424d8a8b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,7 +30,6 @@ library text >= 0.5 && < 0.8, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, - web-routes >= 0.23 && < 0.24, web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, blaze-builder >= 0.1 && < 0.2, @@ -70,6 +69,7 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static + Yesod.WebRoutes ghc-options: -Wall -Werror executable yesod From 53c2a2f49a3677f3b3ac7ee17bf514f24f1c5893 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 20 Aug 2010 09:01:58 +0300 Subject: [PATCH 424/624] Included experimental Yesod.Mail --- Yesod/Mail.hs | 116 ++++++++++++++++++++++++++++++++++++++++++++++++++ mail.hs | 14 ++++++ yesod.cabal | 4 +- 3 files changed, 133 insertions(+), 1 deletion(-) create mode 100644 Yesod/Mail.hs create mode 100644 mail.hs diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs new file mode 100644 index 00000000..7411110c --- /dev/null +++ b/Yesod/Mail.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Mail + ( Boundary (..) + , Mail (..) + , Part (..) + , Encoding (..) + , renderMail + , renderMail' + , sendmail + , Disposition (..) + , renderSendMail + ) where + +import qualified Data.ByteString.Lazy as L +import Text.Blaze.Builder.Utf8 +import Text.Blaze.Builder.Core +import Data.Monoid +import System.Random +import Control.Arrow +import System.Process +import System.IO +import System.Exit +import Codec.Binary.Base64 (encode) +import Control.Monad ((<=<)) + +newtype Boundary = Boundary { unBoundary :: String } +instance Random Boundary where + randomR = const random + random = + first (Boundary . map toChar) . sequence' (replicate 10 (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +data Mail = Mail + { mailHeaders :: [(String, String)] + , mailPlain :: String + , mailParts :: [Part] + } + +data Encoding = None | Base64 + +data Part = Part + { partType :: String -- ^ content type + , partEncoding :: Encoding + , partDisposition :: Disposition + , partContent :: L.ByteString + } + +data Disposition = Inline | Attachment String + +renderMail :: Boundary -> Mail -> L.ByteString +renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat + [ mconcat $ map showHeader headers + , mconcat $ map showHeader + [ ("MIME-Version", "1.0") + , ("Content-Type", "multipart/mixed; boundary=\"" + ++ b ++ "\"") + ] + , fromByteString "\n" + , fromString plain + , mconcat $ map showPart parts + , fromByteString "\n--" + , fromString b + , fromByteString "--" + ] + where + showHeader (k, v) = mconcat + [ fromString k + , fromByteString ": " + , fromString v + , fromByteString "\n" + ] + showPart (Part contentType encoding disposition content) = mconcat + [ fromByteString "\n--" + , fromString b + , fromByteString "\n" + , showHeader ("Content-Type", contentType) + , case encoding of + None -> mempty + Base64 -> showHeader ("Content-Transfer-Encoding", "base64") + , case disposition of + Inline -> mempty + Attachment filename -> + showHeader ("Content-Disposition", "attachment; filename=" ++ filename) + , fromByteString "\n" + , case encoding of + None -> writeList writeByteString $ L.toChunks content + Base64 -> fromString $ encode $ L.unpack content + ] + +renderMail' :: Mail -> IO L.ByteString +renderMail' m = do + b <- randomIO + return $ renderMail b m + +sendmail :: L.ByteString -> IO () +sendmail lbs = do + (Just hin, _, _, phandle) <- createProcess $ (proc + "/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe } + L.hPut hin lbs + hClose hin + exitCode <- waitForProcess phandle + case exitCode of + ExitSuccess -> return () + _ -> error $ "sendmail exited with error code " ++ show exitCode + +renderSendMail :: Mail -> IO () +renderSendMail = sendmail <=< renderMail' diff --git a/mail.hs b/mail.hs new file mode 100644 index 00000000..8e39e0e2 --- /dev/null +++ b/mail.hs @@ -0,0 +1,14 @@ +import Yesod.Mail +import qualified Data.ByteString.Lazy.Char8 as L +import System.Environment + +main = do + [dest] <- getArgs + let p1 = Part "text/html" None Inline $ L.pack "<h1>Hello World!!!</h1>" + lbs <- L.readFile "mail.hs" + let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs + let mail = Mail + [("To", dest), ("Subject", "mail quine")] + "Plain stuff. Mime-clients should not show it." + [p1, p2] + renderSendMail mail diff --git a/yesod.cabal b/yesod.cabal index 424d8a8b..6153ea9c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -46,7 +46,8 @@ library MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, data-object >= 0.3.1 && < 0.4, network >= 2.2.1.5 && < 2.3, - email-validate >= 0.2.5 && < 0.3 + email-validate >= 0.2.5 && < 0.3, + process >= 1.0.1 && < 1.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch @@ -61,6 +62,7 @@ library Yesod.Handler Yesod.Internal Yesod.Json + Yesod.Mail Yesod.Request Yesod.Widget Yesod.Yesod From 21becc6bda3e704945b92ecad03e26fe30c00ed0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 20 Aug 2010 10:37:27 +0300 Subject: [PATCH 425/624] randomKey in Auth uses randomString from Mail --- Yesod/Helpers/Auth.hs | 14 ++++++++------ Yesod/Mail.hs | 30 +++++++++++++++++------------- 2 files changed, 25 insertions(+), 19 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d4f58290..6dff278e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -40,6 +40,7 @@ import qualified Web.Authenticate.OpenId as OpenId import qualified Web.Authenticate.Facebook as Facebook import Yesod +import Yesod.Mail (randomString) import Data.Maybe import Control.Monad @@ -72,10 +73,10 @@ class Yesod master => YesodAuth master where -- | Generate a random alphanumeric string. -- -- This is used for verify string in email authentication. - randomKey :: master -> GHandler (Auth master) master String - randomKey _ = liftIO $ do + randomKey :: master -> IO String + randomKey _ = do stdgen <- newStdGen - return $ take 10 $ randomRs ('A', 'Z') stdgen + return $ fst $ randomString 10 stdgen -- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its -- own settings. If those settings are not present, then relevant handlers will @@ -314,17 +315,18 @@ postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings email <- runFormPost' $ emailInput "email" - y <- getYesod mecreds <- getEmailCreds ae email (lid, verKey) <- case mecreds of Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) Just (EmailCreds lid _ _ Nothing) -> do - key <- randomKey y + y <- getYesod + key <- liftIO $ randomKey y setVerifyKey ae lid key return (lid, key) Nothing -> do - key <- randomKey y + y <- getYesod + key <- liftIO $ randomKey y lid <- addUnverified ae email key return (lid, key) render <- getUrlRender diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs index 7411110c..256b43b5 100644 --- a/Yesod/Mail.hs +++ b/Yesod/Mail.hs @@ -9,6 +9,7 @@ module Yesod.Mail , sendmail , Disposition (..) , renderSendMail + , randomString ) where import qualified Data.ByteString.Lazy as L @@ -23,21 +24,24 @@ import System.Exit import Codec.Binary.Base64 (encode) import Control.Monad ((<=<)) +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + newtype Boundary = Boundary { unBoundary :: String } instance Random Boundary where randomR = const random - random = - first (Boundary . map toChar) . sequence' (replicate 10 (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 + random = first Boundary . randomString 10 data Mail = Mail { mailHeaders :: [(String, String)] @@ -93,7 +97,7 @@ renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat , fromByteString "\n" , case encoding of None -> writeList writeByteString $ L.toChunks content - Base64 -> fromString $ encode $ L.unpack content + Base64 -> writeList writeByte $ map (toEnum . fromEnum) $ encode $ L.unpack content ] renderMail' :: Mail -> IO L.ByteString From f102b9882be20b5f8c78e2751d1d0c926db54a07 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 22 Aug 2010 16:08:58 +0300 Subject: [PATCH 426/624] defaultLayout now works directly on widgets --- Yesod/Helpers/Auth.hs | 25 ++++++--- Yesod/Helpers/Crud.hs | 12 ++-- Yesod/Internal.hs | 43 +++++++++++++++ Yesod/Widget.hs | 110 +------------------------------------ Yesod/Yesod.hs | 124 +++++++++++++++++++++++++++++++----------- 5 files changed, 163 insertions(+), 151 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 6dff278e..fe581f87 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -182,7 +183,9 @@ getOpenIdR = do lookupGetParam "dest" >>= maybe (return ()) setUltDestString rtom <- getRouteToMaster message <- getMessage - applyLayout "Log in via OpenID" mempty [$hamlet| + defaultLayout $ do + setTitle "Log in via OpenID" + addBody [$hamlet| $maybe message msg %p.message $msg$ %form!method=get!action=@rtom.OpenIdForwardR@ @@ -262,7 +265,9 @@ getDisplayName extra = getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson getCheckR = do creds <- maybeCreds - applyLayoutJson "Authentication Status" mempty (html creds) (json creds) + defaultLayoutJson (do + setTitle "Authentication Status" + addBody $ html creds) (json creds) where html creds = [$hamlet| %h1 Authentication Status @@ -303,7 +308,7 @@ getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster - applyLayout "Register a new account" mempty [$hamlet| + defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. %form!method=post!action=@toMaster.EmailRegisterR@ %label!for=email E-mail @@ -333,7 +338,7 @@ postEmailRegisterR = do tm <- getRouteToMaster let verUrl = render $ tm $ EmailVerifyR lid verKey sendVerifyEmail ae email verKey verUrl - applyLayout "Confirmation e-mail sent" mempty [$hamlet| + defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| %p A confirmation e-mail has been sent to $email$. |] @@ -350,7 +355,9 @@ getEmailVerifyR lid key = do Nothing) [] toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> applyLayout "Invalid verification key" mempty [$hamlet| + _ -> defaultLayout $ do + setTitle "Invalid verification key" + addBody [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -359,7 +366,9 @@ getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster msg <- getMessage - applyLayout "Login" mempty [$hamlet| + defaultLayout $ do + setTitle "Login" + addBody [$hamlet| $maybe msg ms %p.message $ms$ %p Please log in to your account. @@ -414,7 +423,9 @@ getEmailPasswordR = do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR msg <- getMessage - applyLayout "Set password" mempty [$hamlet| + defaultLayout $ do + setTitle "Set password" + addBody [$hamlet| $maybe msg ms %p.message $ms$ %h3 Set a new password diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 88431266..d08d1231 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..) @@ -17,7 +18,6 @@ import Yesod.Content import Yesod.Handler import Text.Hamlet import Yesod.Form -import Data.Monoid (mempty) import Language.Haskell.TH.Syntax -- | An entity which can be displayed by the Crud subsite. @@ -53,7 +53,9 @@ getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) getCrudListR = do items <- getYesodSub >>= crudSelect toMaster <- getRouteToMaster - applyLayout "Items" mempty [$hamlet| + defaultLayout $ do + setTitle "Items" + addBody [$hamlet| %h1 Items %ul $forall items item @@ -111,7 +113,9 @@ getCrudDeleteR s = do crud <- getYesodSub item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists toMaster <- getRouteToMaster - applyLayout "Confirm delete" mempty [$hamlet| + defaultLayout $ do + setTitle "Confirm delete" + addBody [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$? @@ -151,7 +155,7 @@ crudHelper title me isPost = do redirect RedirectTemporary $ toMaster $ CrudEditR $ toSinglePiece eid _ -> return () - applyLayoutW $ do + defaultLayout $ do wrapWidget form (wrapForm toMaster enctype) setTitle $ string title where diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 2309904e..ef66e3f5 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses @@ -6,8 +8,23 @@ module Yesod.Internal , Header (..) -- * Cookie names , langKey + -- * Widgets + , Location (..) + , UniqueList (..) + , Script (..) + , Stylesheet (..) + , Title (..) + , Head (..) + , Body (..) + , locationToHamlet + , runUniqueList + , toUnique ) where +import Text.Hamlet (Hamlet, hamlet, Html) +import Data.Monoid (Monoid (..)) +import Data.List (nub) + -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = @@ -28,3 +45,29 @@ data Header = langKey :: String langKey = "_LANG" + +data Location url = Local url | Remote String + deriving (Show, Eq) +locationToHamlet :: Location url -> Hamlet url +locationToHamlet (Local url) = [$hamlet|@url@|] +locationToHamlet (Remote s) = [$hamlet|$s$|] + +newtype UniqueList x = UniqueList ([x] -> [x]) +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y +runUniqueList :: Eq x => UniqueList x -> [x] +runUniqueList (UniqueList x) = nub $ x [] +toUnique :: x -> UniqueList x +toUnique = UniqueList . (:) + +newtype Script url = Script { unScript :: Location url } + deriving (Show, Eq) +newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html } + +newtype Head url = Head (Hamlet url) + deriving Monoid +newtype Body url = Body (Hamlet url) + deriving Monoid diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 263fd8a2..13101494 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,12 +6,9 @@ -- generator, allowing you to create truly modular HTML components. module Yesod.Widget ( -- * Datatype - GWidget + GWidget (..) , Widget , liftHandler - -- * Unwrapping - , widgetToPageContent - , applyLayoutW -- * Creating , newIdent , setTitle @@ -31,46 +27,18 @@ module Yesod.Widget , extractBody ) where -import Data.List (nub) import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State -import Yesod.Hamlet (PageContent (..)) import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, getUrlRenderParams) -import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) -import Yesod.Content (RepHtml (..)) +import Yesod.Handler (Route, GHandler) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) - -data Location url = Local url | Remote String - deriving (Show, Eq) -locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [$hamlet|@url@|] -locationToHamlet (Remote s) = [$hamlet|$s$|] - -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -newtype Script url = Script { unScript :: Location url } - deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } -newtype Head url = Head (Hamlet url) - deriving Monoid -newtype Body url = Body (Hamlet url) - deriving Monoid +import Yesod.Internal -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of @@ -151,78 +119,6 @@ addScriptRemote = addJavascript :: Julius (Route master) -> GWidget sub master () addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just --- | Apply the default layout to the given widget. -applyLayoutW :: (Eq (Route m), Yesod m) - => GWidget sub m () -> GHandler sub m RepHtml -applyLayoutW w = widgetToPageContent w >>= fmap RepHtml . defaultLayout - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent (GWidget w) = do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - Last mTitle), - scripts'), - stylesheets'), - style), - jscript), - Head head') = w' - let title = maybe mempty unTitle mTitle - let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' - let stylesheets = map (locationToHamlet . unStylesheet) - $ runUniqueList stylesheets' - let cssToHtml (Css b) = Html b - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = Html b - jelper :: Julius url -> Hamlet url - jelper = fmap jsToHtml - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s - return $ renderLoc x - - let head'' = [$hamlet| -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ - $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ - $nothing - %script ^jelper.j^ -^head'^ -|] - return $ PageContent title head'' body - -- | Modify the given 'GWidget' by wrapping the body tag HTML code with the -- given function. You might also consider using 'extractBody'. wrapWidget :: GWidget s m a diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5f50b5dc..70172f8c 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -18,10 +18,10 @@ module Yesod.Yesod -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs - -- * Convenience functions - , applyLayout - , applyLayoutJson + -- * Utitlities , maybeAuthorized + , widgetToPageContent + , defaultLayoutJson -- * Defaults , defaultErrorHandler -- * Data types @@ -39,6 +39,7 @@ import Yesod.Content import Yesod.Json #endif +import Yesod.Widget import Yesod.Request import Yesod.Hamlet import Yesod.Handler @@ -46,7 +47,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import Data.Monoid (mempty) import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) @@ -55,6 +55,12 @@ import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L import Yesod.WebRoutes +import Data.Monoid +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State hiding (get) +import Text.Hamlet +import Text.Cassius +import Text.Julius #if TEST import Test.Framework (testGroup, Test) @@ -103,8 +109,10 @@ class Eq (Route a) => Yesod a where errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. - defaultLayout :: PageContent (Route a) -> GHandler sub a Content - defaultLayout p = hamletToContent [$hamlet| + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + hamletToRepHtml [$hamlet| !!! %html %head @@ -226,41 +234,24 @@ breadcrumbs = do (title, next) <- breadcrumb this go ((this, title) : back) next --- | Apply the default layout ('defaultLayout') to the given title and body. -applyLayout :: Yesod master - => String -- ^ title - -> Hamlet (Route master) -- ^ head - -> Hamlet (Route master) -- ^ body - -> GHandler sub master RepHtml -applyLayout t h b = - RepHtml `fmap` defaultLayout PageContent - { pageTitle = string t - , pageHead = h - , pageBody = b - } - -- | Provide both an HTML and JSON representation for a piece of data, using -- the default layout for the HTML output ('defaultLayout'). -applyLayoutJson :: Yesod master - => String -- ^ title - -> Hamlet (Route master) -- ^ head - -> Hamlet (Route master) -- ^ body - -> Json - -> GHandler sub master RepHtmlJson -applyLayoutJson t h html json = do - html' <- defaultLayout PageContent - { pageTitle = string t - , pageHead = h - , pageBody = html - } +defaultLayoutJson :: Yesod master + => GWidget sub master () + -> Json + -> GHandler sub master RepHtmlJson +defaultLayoutJson w json = do + RepHtml html' <- defaultLayout w json' <- jsonToContent json return $ RepHtmlJson html' json' applyLayout' :: Yesod master - => String -- ^ title + => Html -- ^ title -> Hamlet (Route master) -- ^ body -> GHandler sub master ChooseRep -applyLayout' s = fmap chooseRep . applyLayout s mempty +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + addBody body -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep @@ -323,6 +314,73 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent (GWidget w) = do + w' <- flip evalStateT 0 + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT w + let ((((((((), + Body body), + Last mTitle), + scripts'), + stylesheets'), + style), + jscript), + Head head') = w' + let title = maybe mempty unTitle mTitle + let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' + let stylesheets = map (locationToHamlet . unStylesheet) + $ runUniqueList stylesheets' + let cssToHtml (Css b) = Html b + celper :: Cassius url -> Hamlet url + celper = fmap cssToHtml + jsToHtml (Javascript b) = Html b + jelper :: Julius url -> Hamlet url + jelper = fmap jsToHtml + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + cssLoc <- + case style of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "css" "text/css; charset=utf-8" + $ renderCassius render s + return $ renderLoc x + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ renderJulius render s + return $ renderLoc x + + let head'' = [$hamlet| +$forall scripts s + %script!src=^s^ +$forall stylesheets s + %link!rel=stylesheet!href=^s^ +$maybe style s + $maybe cssLoc s + %link!rel=stylesheet!href=$s$ + $nothing + %style ^celper.s^ +$maybe jscript j + $maybe jsLoc s + %script!src=$s$ + $nothing + %script ^jelper.j^ +^head'^ +|] + return $ PageContent title head'' body + #if TEST testSuite :: Test testSuite = testGroup "Yesod.Yesod" From b0c2bf0a3ba05270cf98a9254d32dcb2d9e202b9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 25 Aug 2010 09:13:57 +0300 Subject: [PATCH 427/624] julius $ -> % --- Yesod/Form/Jquery.hs | 6 +++--- Yesod/Form/Nic.hs | 2 +- hellowidget.hs | 16 ++++++++-------- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index deef1118..1d190f0c 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -57,7 +57,7 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJavascript [$julius| -$$(function(){$$("#$theId$").datepicker({dateFormat:'yy-mm-dd'})}); +$(function(){$("#%theId%").datepicker({dateFormat:'yy-mm-dd'})}); |] } @@ -95,7 +95,7 @@ jqueryDayTimeFieldProfile = FieldProfile addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss addJavascript [$julius| -$$(function(){$$("#$theId$").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); +$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -130,7 +130,7 @@ jqueryAutocompleteFieldProfile src = FieldProfile addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJavascript [$julius| -$$(function(){$$("#$theId$").autocomplete({source:"@src@",minLength:2})}); +$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index c1f6111f..0e450046 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -29,7 +29,7 @@ nicHtmlFieldProfile = FieldProfile , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit - addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("$theId$")});|] + addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/hellowidget.hs b/hellowidget.hs index 8c346952..6177d172 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -33,12 +33,12 @@ wrapper h = [$hamlet| #wrapper ^h^ %footer Brought to you by Yesod Widgets™ |] -getRootR = applyLayoutW $ flip wrapWidget wrapper $ do +getRootR = defaultLayout $ flip wrapWidget wrapper $ do i <- newIdent setTitle $ string "Hello Widgets" addStyle [$cassius| #$i$ - color:red + color: red |] addStylesheet $ StaticR $ StaticRoute ["style.css"] [] addStylesheetRemote "http://localhost:3000/static/style2.css" @@ -82,16 +82,16 @@ handleFormR = do let txt = case res of FormSuccess (_, _, _, _, _, _, _, _, _, _, Just x) -> Just x _ -> Nothing - applyLayoutW $ do + defaultLayout $ do addStyle [$cassius| .tooltip - color:#666 - font-style:italic + color: #666 + font-style: italic |] addStyle [$cassius| textarea.html - width:300px - height:150px + width: 300px + height: 150px |] wrapWidget form $ \h -> [$hamlet| %form!method=post!enctype=$enctype$ @@ -134,7 +134,7 @@ getCustomFormR = do |] return (Person <$> a1 <*> a2, b , c1 `mappend` c2) (_, wform, enctype) <- runFormGet customForm - applyLayoutW $ do + defaultLayout $ do form <- extractBody wform addBody [$hamlet| %form From fc0fed4c145407fc26e8ef8c0a0ee8bbc118bd2b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 25 Aug 2010 15:34:33 +0300 Subject: [PATCH 428/624] Removed Handler type synonym --- Yesod/Handler.hs | 8 +------- Yesod/Yesod.hs | 2 +- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a4796f76..5dcbace9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -24,7 +24,6 @@ module Yesod.Handler ( -- * Type families Route -- * Handler monad - , Handler , GHandler -- ** Read information from handler , getYesod @@ -124,7 +123,7 @@ toMasterHandler :: (Route sub -> Route master) -> (master -> sub) -> Route sub -> GHandler sub master a - -> Handler master a + -> GHandler master master a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h @@ -145,11 +144,6 @@ newtype GHandler sub master a = GHandler { unGHandler :: type Endo a = a -> a --- | A 'GHandler' limited to the case where the master and sub sites are the --- same. This is the usual case for application writing; only code written --- specifically as a subsite need been concerned with the more general variety. -type Handler yesod = GHandler yesod yesod - -- | An extension of the basic WAI 'W.Application' datatype to provide extra -- features needed by Yesod. Users should never need to use this directly, as -- the 'GHandler' monad and template haskell code should hide it away. diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 70172f8c..f87ab328 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -72,7 +72,7 @@ import Test.HUnit hiding (Test) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where - getSite :: Site (Route y) (Method -> Maybe (Handler y ChooseRep)) + getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) type Method = String -- | Same as 'YesodSite', but for subsites. Once again, users should not need From 93dddc7b0fc720564dd1862be4416bcc80a3ad72 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 25 Aug 2010 15:35:01 +0300 Subject: [PATCH 429/624] Scaffold tool works again, brand new site template --- favicon.ico | Bin 0 -> 1150 bytes scaffold.hs | 384 ++++++++++++++++++++++++++++++++++++++++------------ 2 files changed, 294 insertions(+), 90 deletions(-) create mode 100644 favicon.ico diff --git a/favicon.ico b/favicon.ico new file mode 100644 index 0000000000000000000000000000000000000000..4613ed03a65f518e28cd421beb06f346bedf0e1e GIT binary patch literal 1150 zcmai!--{Aa6vuBE1--NoL@%*DMlV4SK@YvvbI>1A&%MMFkx;b$VAM=knRM14tGhdn zKgLy=5mzPMY}H+Vu&V{pO1TjD=7Wf6r+Z!QAk#oIeCOPI=6udMocV#!IeacHA$+}o zo}EYNDnjTc7ItCJnI9X3@ICbb07$KV|JU`z1{-_7V*QpAa;xoT`|fl){U=V%jmKkM zUP?ZfL-t`y4ghcTK{L>TeNS~3Wum?8R@Qb<J$NvgOmu4YsNJ}q@Yx$p$q$5`^A^{f zCpoBUTpf5*<o9X+^cu-A7!0nYBLTJ~xMq~2mbWtsM|o=Nd-cbJ4>{lUXuR5r9uw(Z zGsh>fWFUNI)74OObbpxffv_6U<R!0MApEWv4%2uo%bU(-Nc*NX$?Octyvw`kS6UqP z@s>5s`ecrsqt5O6m+})Dt7SRk8z{T?G;>sPm8acq=T<GnDbI}NsHMEHW;1~;m<E$q z1dBNY+}kjGW-Cgr{C1ujjYbzzK4wfgVtLjK2FE)1<t7BOEk$H+WaD7PxqLWR#3CG% z8KyRz9l{lOCs?dDaK}mtv&b*5-Ldk_z~Ca7m!p2+qumG$7ymCudawtR->db;L;6h= z3dKjxV7&NYJ3n2lp<X*8#mQDeG7pEtOQfz^KTb}TMXB)8wjS$xcJ^nKpVtf|4v#xu z@2DBAJ?X2_YTw%wvktRI_?gJ$UXXW1Gxjw?<I4#3bO`CO@J~dM9<S%ZE<F{FDPF|P JGD3ea`xmCx5C#AM literal 0 HcmV?d00001 diff --git a/scaffold.hs b/scaffold.hs index 8fc2f0e7..68951bb2 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -1,7 +1,14 @@ -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} import CodeGenQ import System.IO import System.Directory +import qualified Data.ByteString.Char8 as S +import Language.Haskell.TH.Syntax + +writeFile' :: FilePath -> String -> IO () +writeFile' fp s = do + putStrLn $ "Generating " ++ fp + writeFile fp s main :: IO () main = do @@ -35,8 +42,28 @@ Site argument: |] That's it! I'm creating your files now... |] - putStrLn $ "Generating " ++ project ++ ".cabal" - writeFile (project ++ ".cabal") [$codegen| + createDirectoryIfMissing False "Handler" + createDirectoryIfMissing False "hamlet" + createDirectoryIfMissing False "cassius" + createDirectoryIfMissing False "julius" + + writeFile' "simple-server.hs" [$codegen| +import Controller +import Network.Wai.Handler.SimpleServer (run) + +main :: IO () +main = with~sitearg~ $ run 3000 +|] + + writeFile' "fastcgi.hs" [$codegen| +import Controller +import Network.Wai.Handler.FastCGI (run) + +main :: IO () +main = with~sitearg~ run +|] + + writeFile' (project ++ ".cabal") [$codegen| name: ~project~ version: 0.0.0 license: BSD3 @@ -51,16 +78,39 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/~project~ -executable ~project~ +Flag production + Description: Build the production executable. + Default: False + +executable simple-server + if flag(production) + Buildable: False + cpp-options: -DDEBUG + main-is: simple-server.hs build-depends: base >= 4 && < 5, - yesod >= 0.4.0 && < 0.5.0, - persistent-sqlite >= 0.1.0 && < 0.2 + yesod >= 0.5 && < 0.6, + wai-extra, + directory, + bytestring, + persistent, + persistent-sqlite, + template-haskell, + hamlet ghc-options: -Wall - main-is: ~project~.hs + extensions: TemplateHaskell, QuasiQuotes, TypeFamilies + +executable fastcgi + if flag(production) + Buildable: True + else + Buildable: False + main-is: fastcgi.hs + build-depends: wai-handler-fastcgi + ghc-options: -Wall + extensions: TemplateHaskell, QuasiQuotes, TypeFamilies |] - putStrLn "Generating LICENSE" - writeFile "LICENSE" [$codegen| + writeFile' "LICENSE" [$codegen| The following license covers this documentation, and the source code, except where otherwise indicated. @@ -88,113 +138,267 @@ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |] - putStrLn ("Generating " ++ project ++ ".hs") - writeFile (project ++ ".hs") [$codegen| -import Yesod -import App - -main :: IO () -main = with~sitearg~ $ basicHandler 3000 -|] - - putStrLn "Generating App.hs" - writeFile "App.hs" [$codegen| -{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} -module App + writeFile' (sitearg ++ ".hs") [$codegen| +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module ~sitearg~ ( ~sitearg~ (..) - , with~sitearg~ + , ~sitearg~Route (..) + , resources~sitearg~ + , Handler + , module Yesod + , module Settings + , module Model ) where + import Yesod -import Yesod.Helpers.Crud import Yesod.Helpers.Static -import Database.Persist.Sqlite +import qualified Settings +import System.Directory +import qualified Data.ByteString.Lazy as L +import Yesod.WebRoutes +import Database.Persist.GenericSql +import Settings (hamletFile, cassiusFile, juliusFile) import Model data ~sitearg~ = ~sitearg~ - { connPool :: Pool Connection - , static :: Static + { getStatic :: Static + , connPool :: Settings.ConnectionPool } -with~sitearg~ :: (~sitearg~ -> IO a) -> IO a -with~sitearg~ f = withSqlite "~project~.db3" 8 $ \pool -> do - flip runSqlite pool $ do - -- This is where you can initialize your database. - initialize (undefined :: Person) - f $ ~sitearg~ pool $ fileLookupDir "static" typeByExt +type Handler = GHandler ~sitearg~ ~sitearg~ -type PersonCrud = Crud ~sitearg~ Person - -mkYesod "~sitearg~" [$parseRoutes| -/ RootR GET -/people PeopleR PersonCrud defaultCrud -/static StaticR Static static +mkYesodData "~sitearg~" [$parseRoutes| +/ RootR GET POST +/static StaticR Static getStatic +/favicon.ico FaviconR GET +/robots.txt RobotsR GET |~~] instance Yesod ~sitearg~ where - approot _ = "http://localhost:3000" - defaultLayout (PageContent title head' body) = hamletToContent [$hamlet| -!!! -%html - %head - %title $title$ - %link!rel=stylesheet!href=@stylesheet@ - ^head'^ - %body - #wrapper - ^body^ -|~~] + approot _ = Settings.approot + defaultLayout widget = do + pc <- widgetToPageContent $ do + widget + addStyle $(Settings.cassiusFile "default-layout") + hamletToRepHtml $(Settings.hamletFile "default-layout") + urlRenderOverride a (StaticR s) = + Just $ uncurry (joinPath a Settings.staticroot) $ format s where - stylesheet = StaticR $ StaticRoute ["style.css"] + format = formatPathSegments ss + ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) + ss = getSubSite + urlRenderOverride _ _ = Nothing + addStaticContent ext' _ content = do + let fn = base64md5 content ++ '.' : ext' + let statictmp = Settings.staticdir ++ "/tmp/" + liftIO $ createDirectoryIfMissing True statictmp + liftIO $ L.writeFile (statictmp ++ fn) content + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) instance YesodPersist ~sitearg~ where - type YesodDB ~sitearg~ = SqliteReader - runDB db = fmap connPool getYesod >>= runSqlite db - -getRootR :: Handler ~sitearg~ RepHtml -getRootR = applyLayoutW $ do - setTitle "Welcome to the ~project~ project" - addBody [$hamlet| -%h1 Welcome to ~project~ -%h2 The greatest Yesod web application ever! -%p - %a!href=@PeopleR.CrudListR@ Manage people -|~~] + type YesodDB ~sitearg~ = SqlPersist + runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db |] - putStrLn "Generating Model.hs" - writeFile "Model.hs" [$codegen| -{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TypeFamilies #-} + writeFile' "Controller.hs" [$codegen| +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( with~sitearg~ + ) where --- We don't explicitly state our export list, since there are funny things --- that happen with type family constructors. +import ~sitearg~ +import Settings +import Yesod.Helpers.Static +import Database.Persist.GenericSql + +import Handler.Root + +mkYesodDispatch "~sitearg~" resources~sitearg~ + +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" "favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent "User-agent: *" + +with~sitearg~ :: (Application -> IO a) -> IO a +with~sitearg~ f = Settings.withConnectionPool $ \p -> do + flip runConnectionPool p $ runMigration $ do + migrate (undefined :: Message) + let h = ~sitearg~ s p + toWaiApp h >>= f + where + s = fileLookupDir Settings.staticdir typeByExt +|] + + writeFile' "Handler/Root.hs" [$codegen| +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +module Handler.Root where + +import ~sitearg~ +import Control.Applicative + +messageFormlet :: Formlet sub master Message +messageFormlet x = fieldsToTable + $ Message <$> textareaField "Message" + (fmap messageContent x) + +getRootR :: Handler RepHtml +getRootR = do + messages <- runDB $ selectList [] [] 10 0 + (_, wform, _) <- runFormGet $ messageFormlet Nothing + defaultLayout $ do + setTitle "~project~ homepage" + ident <- newIdent + form <- extractBody wform + addBody $(hamletFile "homepage") + addStyle $(cassiusFile "homepage") + addJavascript $(juliusFile "homepage") + +postRootR :: Handler () +postRootR = do + (res, _, _) <- runFormPost $ messageFormlet Nothing + case res of + FormSuccess message -> runDB (insert message) >> return () + _ -> return () + redirect RedirectTemporary RootR +|] + + writeFile' "Model.hs" [$codegen| +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} module Model where import Yesod -import Yesod.Helpers.Crud -share2 mkPersist mkToForm [$persist| -Person - name String - age Int +mkPersist [$persist| +Message + content Textarea |~~] - -instance Item Person where - itemTitle = personName |] - putStrLn "Generating static/style.css" - createDirectoryIfMissing True "static" - writeFile "static/style.css" [$codegen| -body { - font-family: sans-serif; - background: #eee; -} + writeFile' "Settings.hs" [$codegen| +{-# LANGUAGE CPP #-} +module Settings + ( hamletFile + , cassiusFile + , juliusFile + , connStr + , ConnectionPool + , withConnectionPool + , runConnectionPool + , approot + , staticroot + , staticdir + ) where -#wrapper { - width: 760px; - margin: 1em auto; - border: 2px solid #000; - padding: 0.5em; - background: #fff; +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import Language.Haskell.TH.Syntax +import Database.Persist.Sqlite +import Yesod (MonadCatchIO) + +hamletFile :: FilePath -> Q Exp +#ifdef DEBUG +hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" +#else +hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" +#endif + +cassiusFile :: FilePath -> Q Exp +#ifdef DEBUG +cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" +#else +cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius" +#endif + +juliusFile :: FilePath -> Q Exp +#ifdef DEBUG +juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" +#else +juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" +#endif + +connStr :: String +#ifdef DEBUG +connStr = "debug.db3" +#else +connStr = "production.db3" +#endif + +connectionCount :: Int +connectionCount = 10 + +withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a +withConnectionPool = withSqlitePool connStr connectionCount + +runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +approot :: String +#ifdef DEBUG +approot = "http://localhost:3000" +#else +approot = "http://localhost:3000" +#endif + +staticroot :: String +staticroot = approot ++ "/static" + +staticdir :: FilePath +staticdir = "static" +|] + + writeFile' "cassius/default-layout.cassius" [$codegen| +body + font-family: sans-serif +|] + + writeFile' "hamlet/default-layout.hamlet" [$codegen| +!!! +%html + %head + %title $pageTitle.pc$ + ^pageHead.pc^ + %body + ^pageBody.pc^ +|] + + writeFile' "hamlet/homepage.hamlet" [$codegen| +%h1 Hello +%p#$ident$ Welcome. +%h3 Messages +$if null.messages + %p No messages. +$else + %ul + $forall messages m + %li $messageContent.snd.m$ +%h3 Add Message +%form!method=post!action=@RootR@ + %table + ^form^ + %tr + %td!colspan=2 + %input!type=submit!value="Add Message" +|] + + writeFile' "cassius/homepage.cassius" [$codegen| +body + font-family: sans-serif +h1 + text-align: center +|] + + writeFile' "julius/homepage.julius" [$codegen| +window.onload = function(){ + document.getElementById("%ident%").innerHTML = "<i>Added from JavaScript.</i>"; } |] + + S.writeFile "favicon.ico" + $(runIO (S.readFile "favicon.ico") >>= \bs -> do + pack <- [|S.pack|] + return $ pack `AppE` LitE (StringL $ S.unpack bs)) From 1c28d0f9d015f38f130afce45b74ffb7ae220b12 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 25 Aug 2010 15:54:59 +0300 Subject: [PATCH 430/624] Scaffolding offers directory name and switching backends --- scaffold.hs | 60 +++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 16 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index 68951bb2..577fb44e 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -5,16 +5,10 @@ import System.Directory import qualified Data.ByteString.Char8 as S import Language.Haskell.TH.Syntax -writeFile' :: FilePath -> String -> IO () -writeFile' fp s = do - putStrLn $ "Generating " ++ fp - writeFile fp s - main :: IO () main = do putStr [$codegen|Welcome to the Yesod scaffolder. I'm going to be creating a skeleton Yesod project for you. -Please make sure you are in the directory where you'd like the files created. What is your name? We're going to put this in the cabal and LICENSE files. @@ -24,28 +18,62 @@ Your name: |] putStr [$codegen| Welcome ~name~. -What do you want to call your project? We'll use this for the cabal name and -executable filenames. +What do you want to call your project? We'll use this for the cabal name. Project name: |] hFlush stdout project <- getLine + putStr [$codegen| -Great, we'll be creating ~project~ today. What's going to be the name of -your site argument datatype? This name must start with a capital letter; -I recommend picking something short, as this name gets typed a lot. +Now where would you like me to place your generated files? I'm smart enough +to create the directories, don't worry about that. If you leave this answer +blank, we'll place the files in ~project~. + +Directory name: |] + hFlush stdout + dirRaw <- getLine + let dir = if null dirRaw then project else dirRaw + + putStr [$codegen| +Great, we'll be creating ~project~ today, and placing it in ~dir~. +What's going to be the name of your site argument datatype? This name must +start with a capital letter. Site argument: |] hFlush stdout sitearg <- getLine + putStr [$codegen| That's it! I'm creating your files now... |] - createDirectoryIfMissing False "Handler" - createDirectoryIfMissing False "hamlet" - createDirectoryIfMissing False "cassius" - createDirectoryIfMissing False "julius" + putStr [$codegen| +Yesod uses Persistent for its (you guessed it) persistence layer. +This tool will build in either SQLite or PostgreSQL support for you. If you +want to use a different backend, you'll have to make changes manually. +If you're not sure, stick with SQLite: it has no dependencies. + +So, what'll it be? s for sqlite, p for postgresql: |] + hFlush stdout + backendS <- getLine + let pconn1 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug|] + let pconn2 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production|] + let (lower, upper, connstr1, connstr2) = + case backendS of + "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3") + "p" -> ("postgresql", "Postgresql", pconn1, pconn2) + _ -> error $ "Invalid backend: " ++ backendS + + + let writeFile' fp s = do + putStrLn $ "Generating " ++ fp + writeFile (dir ++ '/' : fp) s + mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp + + mkDir "Handler" + mkDir "hamlet" + mkDir "cassius" + mkDir "julius" writeFile' "simple-server.hs" [$codegen| import Controller @@ -398,7 +426,7 @@ window.onload = function(){ } |] - S.writeFile "favicon.ico" + S.writeFile (dir ++ "/favicon.ico") $(runIO (S.readFile "favicon.ico") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) From 86653cd8f545555383e0d5f5798b245392b12bd5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 26 Aug 2010 00:14:42 +0300 Subject: [PATCH 431/624] Beginning of major refactoring of Auth helper --- Yesod/Helpers/Auth.hs | 128 ++++++++++++++++++++++++++++-------------- scaffold.hs | 5 +- 2 files changed, 90 insertions(+), 43 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index fe581f87..dda02c6e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE QuasiQuotes #-} @@ -23,6 +24,7 @@ module Yesod.Helpers.Auth ( -- * Subsite Auth (..) + , getAuth , AuthRoute (..) -- * Settings , YesodAuth (..) @@ -34,6 +36,10 @@ module Yesod.Helpers.Auth -- * Functions , maybeCreds , requireCreds + -- * AuthId + , YesodAuthId (..) + , maybeAuthId + , requireAuthId ) where import qualified Web.Authenticate.Rpxnow as Rpxnow @@ -68,7 +74,7 @@ class Yesod master => YesodAuth master where -- -- The second parameter can contain various information, depending on login -- mechanism. - onLogin :: Creds -> [(String, String)] -> GHandler (Auth master) master () + onLogin :: Creds -> [(String, String)] -> GHandler Auth master () onLogin _ _ = return () -- | Generate a random alphanumeric string. @@ -79,16 +85,23 @@ class Yesod master => YesodAuth master where stdgen <- newStdGen return $ fst $ randomString 10 stdgen --- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its --- own settings. If those settings are not present, then relevant handlers will --- simply return a 404. -data Auth m = Auth - { authIsOpenIdEnabled :: Bool - , authRpxnowApiKey :: Maybe String - , authEmailSettings :: Maybe (AuthEmailSettings m) + authIsOpenIdEnabled :: master -> Bool + authIsOpenIdEnabled _ = False + + authRpxnowApiKey :: master -> Maybe String + authRpxnowApiKey _ = Nothing + + authEmailSettings :: master -> Maybe (AuthEmailSettings master) + authEmailSettings _ = Nothing + -- | client id, secret and requested permissions - , authFacebook :: Maybe (String, String, [String]) - } + authFacebook :: master -> Maybe (String, String, [String]) + authFacebook _ = Nothing + +data Auth = Auth + +getAuth :: a -> Auth +getAuth = const Auth -- | Which subsystem authenticated the user. data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook @@ -112,14 +125,14 @@ data EmailCreds = EmailCreds -- | For a sample set of settings for a trivial in-memory database, see -- 'inMemoryEmailSettings'. data AuthEmailSettings m = AuthEmailSettings - { addUnverified :: Email -> VerKey -> GHandler (Auth m) m EmailId - , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler (Auth m) m () - , getVerifyKey :: EmailId -> GHandler (Auth m) m (Maybe VerKey) - , setVerifyKey :: EmailId -> VerKey -> GHandler (Auth m) m () - , verifyAccount :: EmailId -> GHandler (Auth m) m () - , setPassword :: EmailId -> String -> GHandler (Auth m) m () - , getEmailCreds :: Email -> GHandler (Auth m) m (Maybe EmailCreds) - , getEmail :: EmailId -> GHandler (Auth m) m (Maybe Email) + { addUnverified :: Email -> VerKey -> GHandler Auth m EmailId + , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () + , getVerifyKey :: EmailId -> GHandler Auth m (Maybe VerKey) + , setVerifyKey :: EmailId -> VerKey -> GHandler Auth m () + , verifyAccount :: EmailId -> GHandler Auth m () + , setPassword :: EmailId -> String -> GHandler Auth m () + , getEmailCreds :: Email -> GHandler Auth m (Maybe EmailCreds) + , getEmail :: EmailId -> GHandler Auth m (Maybe Email) } -- | User credentials @@ -137,7 +150,7 @@ credsKey :: String credsKey = "_CREDS" setCreds :: YesodAuth master - => Creds -> [(String, String)] -> GHandler (Auth master) master () + => Creds -> [(String, String)] -> GHandler Auth master () setCreds creds extra = do setSession credsKey $ show creds onLogin creds extra @@ -152,7 +165,7 @@ maybeCreds = do (y, _):_ -> Just y _ -> Nothing -mkYesodSub "Auth master" +mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] ] [$parseRoutes| @@ -172,12 +185,12 @@ mkYesodSub "Auth master" /set-password EmailPasswordR GET POST |] -testOpenId :: GHandler (Auth master) master () +testOpenId :: YesodAuth master => GHandler Auth master () testOpenId = do - a <- getYesodSub + a <- getYesod unless (authIsOpenIdEnabled a) notFound -getOpenIdR :: Yesod master => GHandler (Auth master) master RepHtml +getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml getOpenIdR = do testOpenId lookupGetParam "dest" >>= maybe (return ()) setUltDestString @@ -194,7 +207,7 @@ $maybe message msg %input!type=submit!value=Login |] -getOpenIdForwardR :: GHandler (Auth master) master () +getOpenIdForwardR :: YesodAuth master => GHandler Auth master () getOpenIdForwardR = do testOpenId oid <- runFormGet' $ stringInput "openid" @@ -209,7 +222,7 @@ getOpenIdForwardR = do (redirectString RedirectTemporary) res -getOpenIdCompleteR :: YesodAuth master => GHandler (Auth master) master () +getOpenIdCompleteR :: YesodAuth master => GHandler Auth master () getOpenIdCompleteR = do testOpenId rr <- getRequest @@ -225,10 +238,10 @@ getOpenIdCompleteR = do redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: YesodAuth master => GHandler (Auth master) master () +handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod - auth <- getYesodSub + auth <- getYesod apiKey <- case authRpxnowApiKey auth of Just x -> return x Nothing -> notFound @@ -262,7 +275,7 @@ getDisplayName extra = where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] -getCheckR :: Yesod master => GHandler (Auth master) master RepHtmlJson +getCheckR :: Yesod master => GHandler Auth master RepHtmlJson getCheckR = do creds <- maybeCreds defaultLayoutJson (do @@ -283,7 +296,7 @@ $maybe creds c $ creds >>= credsDisplayName) ] -getLogoutR :: YesodAuth master => GHandler (Auth master) master () +getLogoutR :: YesodAuth master => GHandler Auth master () getLogoutR = do y <- getYesod deleteSession credsKey @@ -301,10 +314,11 @@ requireCreds = setUltDest' redirect RedirectTemporary $ defaultLoginRoute y -getAuthEmailSettings :: GHandler (Auth master) master (AuthEmailSettings master) -getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings +getAuthEmailSettings :: YesodAuth master + => GHandler Auth master (AuthEmailSettings master) +getAuthEmailSettings = getYesod >>= maybe notFound return . authEmailSettings -getEmailRegisterR :: Yesod master => GHandler (Auth master) master RepHtml +getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -316,7 +330,7 @@ getEmailRegisterR = do %input!type=submit!value=Register |] -postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml +postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings email <- runFormPost' $ emailInput "email" @@ -343,7 +357,7 @@ postEmailRegisterR = do |] getEmailVerifyR :: YesodAuth master - => Integer -> String -> GHandler (Auth master) master RepHtml + => Integer -> String -> GHandler Auth master RepHtml getEmailVerifyR lid key = do ae <- getAuthEmailSettings realKey <- getVerifyKey ae lid @@ -361,7 +375,7 @@ getEmailVerifyR lid key = do %p I'm sorry, but that was an invalid verification key. |] -getEmailLoginR :: Yesod master => GHandler (Auth master) master RepHtml +getEmailLoginR :: YesodAuth master => GHandler Auth master RepHtml getEmailLoginR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -389,7 +403,7 @@ $maybe msg ms %input!type=submit!value=Login |] -postEmailLoginR :: YesodAuth master => GHandler (Auth master) master () +postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do ae <- getAuthEmailSettings (email, pass) <- runFormPost' $ (,) @@ -412,7 +426,7 @@ postEmailLoginR = do toMaster <- getRouteToMaster redirect RedirectTemporary $ toMaster EmailLoginR -getEmailPasswordR :: Yesod master => GHandler (Auth master) master RepHtml +getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml getEmailPasswordR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster @@ -444,7 +458,7 @@ $maybe msg ms %input!type=submit!value=Submit |] -postEmailPasswordR :: YesodAuth master => GHandler (Auth master) master () +postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do ae <- getAuthEmailSettings (new, confirm) <- runFormPost' $ (,) @@ -521,10 +535,10 @@ inMemoryEmailSettings = do | eid == eid' = (email, EmailCreds eid (Just pass) status key) | otherwise = (email, EmailCreds eid' pass' status key) -getFacebookR :: YesodAuth master => GHandler (Auth master) master () +getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR = do y <- getYesod - a <- authFacebook <$> getYesodSub + a <- authFacebook <$> getYesod case a of Nothing -> notFound Just (cid, secret, _) -> do @@ -544,9 +558,9 @@ getFacebookR = do setCreds c [] redirectUltDest RedirectTemporary $ defaultDest y -getStartFacebookR :: GHandler (Auth master) master () +getStartFacebookR :: YesodAuth master => GHandler Auth master () getStartFacebookR = do - y <- getYesodSub + y <- getYesod case authFacebook y of Nothing -> notFound Just (cid, secret, perms) -> do @@ -555,3 +569,33 @@ getStartFacebookR = do let fb = Facebook.Facebook cid secret $ render $ tm FacebookR let fburl = Facebook.getForwardUrl fb perms redirectString RedirectTemporary fburl + +class ( YesodAuth m + , YesodPersist m + , PersistEntity (AuthEntity m) + ) => YesodAuthId m where + type AuthEntity m + newAuthEntity :: Creds -> (YesodDB m) (GHandler s m) (AuthEntity m) + getAuthEntity :: Creds + -> (YesodDB m) (GHandler s m) + (Maybe (Key (AuthEntity m), AuthEntity m)) + +maybeAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) + => GHandler s m (Maybe (Key (AuthEntity m), AuthEntity m)) +maybeAuthId = maybeCreds >>= maybe (return Nothing) (fmap Just . authIdHelper) + +requireAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) + => GHandler s m (Key (AuthEntity m), AuthEntity m) +requireAuthId = requireCreds >>= authIdHelper + +authIdHelper :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) + => Creds + -> GHandler s m (Key (AuthEntity m), AuthEntity m) +authIdHelper creds = runDB $ do + x <- getAuthEntity creds + case x of + Just y -> return y + Nothing -> do + user <- newAuthEntity creds + uid <- insert user + return (uid, user) diff --git a/scaffold.hs b/scaffold.hs index 577fb44e..2a09b8d5 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -80,7 +80,7 @@ import Controller import Network.Wai.Handler.SimpleServer (run) main :: IO () -main = with~sitearg~ $ run 3000 +main = putStrLn "Loaded" >> with~sitearg~ (run 3000) |] writeFile' "fastcgi.hs" [$codegen| @@ -205,6 +205,7 @@ mkYesodData "~sitearg~" [$parseRoutes| instance Yesod ~sitearg~ where approot _ = Settings.approot defaultLayout widget = do + mmsg <- getMessage pc <- widgetToPageContent $ do widget addStyle $(Settings.cassiusFile "default-layout") @@ -391,6 +392,8 @@ body %title $pageTitle.pc$ ^pageHead.pc^ %body + $maybe mmsg msg + #message $msg$ ^pageBody.pc^ |] From a03cc7cff8c3b5046299951cfaea5ac455d1913a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 26 Aug 2010 14:03:46 +0300 Subject: [PATCH 432/624] Cleaned up auth module --- Yesod/Helpers/Auth.hs | 269 ++++++++++++++++-------------------------- 1 file changed, 103 insertions(+), 166 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index dda02c6e..51407c94 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -32,14 +32,9 @@ module Yesod.Helpers.Auth , EmailCreds (..) , AuthType (..) , AuthEmailSettings (..) - , inMemoryEmailSettings -- * Functions , maybeCreds , requireCreds - -- * AuthId - , YesodAuthId (..) - , maybeAuthId - , requireAuthId ) where import qualified Web.Authenticate.Rpxnow as Rpxnow @@ -54,28 +49,31 @@ import Control.Monad import System.Random import Data.Digest.Pure.MD5 import Control.Applicative -import Control.Concurrent.MVar -import System.IO import Control.Monad.Attempt import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object import Language.Haskell.TH.Syntax --- | Minimal complete definition: 'defaultDest' and 'defaultLoginRoute'. -class Yesod master => YesodAuth master where +class (Integral (AuthEmailId master), Yesod master, + Show (AuthId master), Read (AuthId master), Eq (AuthId master) + ) => YesodAuth master where + type AuthId master + type AuthEmailId master + + showAuthId :: AuthId master -> GHandler s master String + showAuthId = return . show + + readAuthId :: String -> GHandler s master (Maybe (AuthId master)) + readAuthId s = return $ case reads s of + [] -> Nothing + ((x, _):_) -> Just x + -- | Default destination on successful login or logout, if no other -- destination exists. defaultDest :: master -> Route master - -- | Default page to redirect user to for logging in. - defaultLoginRoute :: master -> Route master - - -- | Callback for a successful login. - -- - -- The second parameter can contain various information, depending on login - -- mechanism. - onLogin :: Creds -> [(String, String)] -> GHandler Auth master () - onLogin _ _ = return () + getAuthId :: Creds master -> [(String, String)] + -> GHandler s master (Maybe (AuthId master)) -- | Generate a random alphanumeric string. -- @@ -85,18 +83,18 @@ class Yesod master => YesodAuth master where stdgen <- newStdGen return $ fst $ randomString 10 stdgen - authIsOpenIdEnabled :: master -> Bool - authIsOpenIdEnabled _ = False + openIdEnabled :: master -> Bool + openIdEnabled _ = False - authRpxnowApiKey :: master -> Maybe String - authRpxnowApiKey _ = Nothing + rpxnowApiKey :: master -> Maybe String + rpxnowApiKey _ = Nothing - authEmailSettings :: master -> Maybe (AuthEmailSettings master) - authEmailSettings _ = Nothing + emailSettings :: master -> Maybe (AuthEmailSettings master) + emailSettings _ = Nothing -- | client id, secret and requested permissions - authFacebook :: master -> Maybe (String, String, [String]) - authFacebook _ = Nothing + facebookKeys :: master -> Maybe (String, String, [String]) + facebookKeys _ = Nothing data Auth = Auth @@ -110,60 +108,57 @@ data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook type Email = String type VerKey = String type VerUrl = String -type EmailId = Integer type SaltedPass = String type VerStatus = Bool -- | Data stored in a database for each e-mail address. -data EmailCreds = EmailCreds - { emailCredsId :: EmailId - , emailCredsPass :: Maybe SaltedPass +data EmailCreds m = EmailCreds + { emailCredsId :: AuthEmailId m + , emailCredsAuthId :: Maybe (AuthId m) , emailCredsStatus :: VerStatus , emailCredsVerkey :: Maybe VerKey } --- | For a sample set of settings for a trivial in-memory database, see --- 'inMemoryEmailSettings'. data AuthEmailSettings m = AuthEmailSettings - { addUnverified :: Email -> VerKey -> GHandler Auth m EmailId + { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () - , getVerifyKey :: EmailId -> GHandler Auth m (Maybe VerKey) - , setVerifyKey :: EmailId -> VerKey -> GHandler Auth m () - , verifyAccount :: EmailId -> GHandler Auth m () - , setPassword :: EmailId -> String -> GHandler Auth m () - , getEmailCreds :: Email -> GHandler Auth m (Maybe EmailCreds) - , getEmail :: EmailId -> GHandler Auth m (Maybe Email) + , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) + , setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () + , verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) + , getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) + , setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () + , getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) + , getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) } -- | User credentials -data Creds = Creds +data Creds m = Creds { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. , credsAuthType :: AuthType -- ^ How the user was authenticated , credsEmail :: Maybe String -- ^ Verified e-mail address. , credsDisplayName :: Maybe String -- ^ Display name. - , credsId :: Maybe Integer -- ^ Numeric ID, if used. + , credsId :: Maybe (AuthId m) -- ^ Numeric ID, if used. , credsFacebookToken :: Maybe Facebook.AccessToken } - deriving (Show, Read, Eq) credsKey :: String -credsKey = "_CREDS" +credsKey = "_ID" setCreds :: YesodAuth master - => Creds -> [(String, String)] -> GHandler Auth master () + => Creds master -> [(String, String)] -> GHandler Auth master () setCreds creds extra = do - setSession credsKey $ show creds - onLogin creds extra + maid <- getAuthId creds extra + case maid of + Nothing -> return () + Just aid -> showAuthId aid >>= setSession credsKey -- | Retrieves user credentials, if user is authenticated. -maybeCreds :: RequestReader r => r (Maybe Creds) +maybeCreds :: YesodAuth m => GHandler s m (Maybe (AuthId m)) maybeCreds = do - mstring <- lookupSession credsKey - return $ mstring >>= readMay - where - readMay x = case reads x of - (y, _):_ -> Just y - _ -> Nothing + ms <- lookupSession credsKey + case ms of + Nothing -> return Nothing + Just s -> readAuthId s mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] @@ -188,7 +183,7 @@ mkYesodSub "Auth" testOpenId :: YesodAuth master => GHandler Auth master () testOpenId = do a <- getYesod - unless (authIsOpenIdEnabled a) notFound + unless (openIdEnabled a) notFound getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml getOpenIdR = do @@ -242,7 +237,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod auth <- getYesod - apiKey <- case authRpxnowApiKey auth of + apiKey <- case rpxnowApiKey auth of Just x -> return x Nothing -> notFound token1 <- lookupGetParam "token" @@ -275,7 +270,7 @@ getDisplayName extra = where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] -getCheckR :: Yesod master => GHandler Auth master RepHtmlJson +getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson getCheckR = do creds <- maybeCreds defaultLayoutJson (do @@ -285,15 +280,13 @@ getCheckR = do html creds = [$hamlet| %h1 Authentication Status $if isNothing.creds - %p Not logged in -$maybe creds c - %p Logged in as $credsIdent.c$ + %p Not logged in. +$maybe creds _ + %p Logged in. |] json creds = jsonMap - [ ("ident", jsonScalar $ maybe "" credsIdent creds) - , ("displayName", jsonScalar $ fromMaybe "" - $ creds >>= credsDisplayName) + [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds) ] getLogoutR :: YesodAuth master => GHandler Auth master () @@ -303,20 +296,22 @@ getLogoutR = do redirectUltDest RedirectTemporary $ defaultDest y -- | Retrieve user credentials. If user is not logged in, redirects to the --- 'defaultLoginRoute'. Sets ultimate destination to current route, so user +-- 'authRoute'. Sets ultimate destination to current route, so user -- should be sent back here after authenticating. -requireCreds :: YesodAuth master => GHandler sub master Creds +requireCreds :: YesodAuth m => GHandler sub m (AuthId m) requireCreds = maybeCreds >>= maybe redirectLogin return where redirectLogin = do y <- getYesod setUltDest' - redirect RedirectTemporary $ defaultLoginRoute y + case authRoute y of + Just z -> redirect RedirectTemporary z + Nothing -> permissionDenied "Please configure authRoute" getAuthEmailSettings :: YesodAuth master => GHandler Auth master (AuthEmailSettings master) -getAuthEmailSettings = getYesod >>= maybe notFound return . authEmailSettings +getAuthEmailSettings = getYesod >>= maybe notFound return . emailSettings getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR = do @@ -350,7 +345,7 @@ postEmailRegisterR = do return (lid, key) render <- getUrlRender tm <- getRouteToMaster - let verUrl = render $ tm $ EmailVerifyR lid verKey + let verUrl = render $ tm $ EmailVerifyR (fromIntegral lid) verKey sendVerifyEmail ae email verKey verUrl defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| %p A confirmation e-mail has been sent to $email$. @@ -358,20 +353,25 @@ postEmailRegisterR = do getEmailVerifyR :: YesodAuth master => Integer -> String -> GHandler Auth master RepHtml -getEmailVerifyR lid key = do +getEmailVerifyR lid' key = do + let lid = fromInteger lid' ae <- getAuthEmailSettings realKey <- getVerifyKey ae lid memail <- getEmail ae lid case (realKey == Just key, memail) of (True, Just email) -> do - verifyAccount ae lid - setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) - Nothing) [] - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> defaultLayout $ do - setTitle "Invalid verification key" - addBody [$hamlet| + muid <- verifyAccount ae lid + case muid of + Nothing -> return () + Just uid -> do + setCreds (Creds email AuthEmail (Just email) Nothing (Just uid) + Nothing) [] + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster EmailPasswordR + _ -> return () + defaultLayout $ do + setTitle "Invalid verification key" + addBody [$hamlet| %p I'm sorry, but that was an invalid verification key. |] @@ -411,14 +411,20 @@ postEmailLoginR = do <*> stringInput "password" y <- getYesod mecreds <- getEmailCreds ae email - let mlid = - case mecreds of - Just (EmailCreds lid (Just realpass) True _) -> - if isValidPass pass realpass then Just lid else Nothing - _ -> Nothing - case mlid of - Just lid -> do - setCreds (Creds email AuthEmail (Just email) Nothing (Just lid) + maid <- + case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of + (Just aid, Just True) -> do + mrealpass <- getPassword ae aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ + if isValidPass pass realpass + then Just aid + else Nothing + _ -> return Nothing + case maid of + Just aid -> do + setCreds (Creds email AuthEmail (Just email) Nothing (Just aid) Nothing) [] redirectUltDest RedirectTemporary $ defaultDest y Nothing -> do @@ -430,18 +436,15 @@ getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml getEmailPasswordR = do _ae <- getAuthEmailSettings toMaster <- getRouteToMaster - mcreds <- maybeCreds - case mcreds of - Just (Creds _ AuthEmail _ _ (Just _) _) -> return () - _ -> do + maid <- maybeCreds + case maid of + Just _ -> return () + Nothing -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR - msg <- getMessage defaultLayout $ do setTitle "Set password" addBody [$hamlet| -$maybe msg ms - %p.message $ms$ %h3 Set a new password %form!method=post!action=@toMaster.EmailPasswordR@ %table @@ -468,16 +471,17 @@ postEmailPasswordR = do when (new /= confirm) $ do setMessage $ string "Passwords did not match, please try again" redirect RedirectTemporary $ toMaster EmailPasswordR - mcreds <- maybeCreds - lid <- case mcreds of - Just (Creds _ AuthEmail _ _ (Just lid) _) -> return lid - _ -> do + maid <- maybeCreds + aid <- case maid of + Nothing -> do setMessage $ string "You must be logged in to set a password" redirect RedirectTemporary $ toMaster EmailLoginR + Just aid -> return aid salted <- liftIO $ saltPass new - setPassword ae lid salted + setPassword ae aid salted setMessage $ string "Password updated" - redirect RedirectTemporary $ toMaster EmailLoginR + y <- getYesod + redirect RedirectTemporary $ defaultDest y saltLength :: Int saltLength = 5 @@ -498,47 +502,10 @@ saltPass pass = do saltPass' :: String -> String -> String saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) --- | A simplistic set of email settings, useful only for testing purposes. In --- particular, it doesn't actually send emails, but instead prints verification --- URLs to stderr. -inMemoryEmailSettings :: IO (AuthEmailSettings a) -inMemoryEmailSettings = do - mm <- newMVar [] - return AuthEmailSettings - { addUnverified = \email verkey -> liftIO $ modifyMVar mm $ \m -> do - let helper (_, EmailCreds x _ _ _) = x - let newId = 1 + maximum (0 : map helper m) - let ec = EmailCreds newId Nothing False $ Just verkey - return ((email, ec) : m, newId) - , sendVerifyEmail = \_email _verkey verurl -> liftIO $ - hPutStrLn stderr $ "Please go to: " ++ verurl - , getVerifyKey = \eid -> liftIO $ withMVar mm $ \m -> return $ - join $ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m - , setVerifyKey = \eid key -> liftIO $ modifyMVar_ mm $ \m -> return $ - map (setHelper eid key) m - , verifyAccount = \eid -> liftIO $ modifyMVar_ mm $ return . map (vago eid) - , setPassword = \eid pass -> liftIO $ modifyMVar_ mm $ return . map (spgo eid pass) - , getEmailCreds = \email -> liftIO $ withMVar mm $ return . lookup email - , getEmail = \eid -> liftIO $ withMVar mm $ \m -> return $ - case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of - ((email, _):_) -> Just email - _ -> Nothing - } - where - setHelper eid key pair@(k, EmailCreds eid' b c _) - | eid == eid' = (k, EmailCreds eid b c $ Just key) - | otherwise = pair - vago eid (email, EmailCreds eid' pass status key) - | eid == eid' = (email, EmailCreds eid pass True key) - | otherwise = (email, EmailCreds eid' pass status key) - spgo eid pass (email, EmailCreds eid' pass' status key) - | eid == eid' = (email, EmailCreds eid (Just pass) status key) - | otherwise = (email, EmailCreds eid' pass' status key) - getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR = do y <- getYesod - a <- authFacebook <$> getYesod + a <- facebookKeys <$> getYesod case a of Nothing -> notFound Just (cid, secret, _) -> do @@ -561,7 +528,7 @@ getFacebookR = do getStartFacebookR :: YesodAuth master => GHandler Auth master () getStartFacebookR = do y <- getYesod - case authFacebook y of + case facebookKeys y of Nothing -> notFound Just (cid, secret, perms) -> do render <- getUrlRender @@ -569,33 +536,3 @@ getStartFacebookR = do let fb = Facebook.Facebook cid secret $ render $ tm FacebookR let fburl = Facebook.getForwardUrl fb perms redirectString RedirectTemporary fburl - -class ( YesodAuth m - , YesodPersist m - , PersistEntity (AuthEntity m) - ) => YesodAuthId m where - type AuthEntity m - newAuthEntity :: Creds -> (YesodDB m) (GHandler s m) (AuthEntity m) - getAuthEntity :: Creds - -> (YesodDB m) (GHandler s m) - (Maybe (Key (AuthEntity m), AuthEntity m)) - -maybeAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) - => GHandler s m (Maybe (Key (AuthEntity m), AuthEntity m)) -maybeAuthId = maybeCreds >>= maybe (return Nothing) (fmap Just . authIdHelper) - -requireAuthId :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) - => GHandler s m (Key (AuthEntity m), AuthEntity m) -requireAuthId = requireCreds >>= authIdHelper - -authIdHelper :: (YesodAuthId m, PersistBackend (YesodDB m (GHandler s m))) - => Creds - -> GHandler s m (Key (AuthEntity m), AuthEntity m) -authIdHelper creds = runDB $ do - x <- getAuthEntity creds - case x of - Just y -> return y - Nothing -> do - user <- newAuthEntity creds - uid <- insert user - return (uid, user) From 465366766b14c6991c66a8595516d65053a3674f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 27 Aug 2010 13:09:43 +0300 Subject: [PATCH 433/624] Unified Auth login page --- Yesod/Helpers/Auth.hs | 190 ++++++++++++++++++++++-------------------- 1 file changed, 100 insertions(+), 90 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 51407c94..9edcbd19 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -31,10 +31,12 @@ module Yesod.Helpers.Auth , Creds (..) , EmailCreds (..) , AuthType (..) - , AuthEmailSettings (..) + , RpxnowSettings (..) + , EmailSettings (..) + , FacebookSettings (..) -- * Functions - , maybeCreds - , requireCreds + , maybeAuthId + , requireAuthId ) where import qualified Web.Authenticate.Rpxnow as Rpxnow @@ -86,15 +88,15 @@ class (Integral (AuthEmailId master), Yesod master, openIdEnabled :: master -> Bool openIdEnabled _ = False - rpxnowApiKey :: master -> Maybe String - rpxnowApiKey _ = Nothing + rpxnowSettings :: master -> Maybe RpxnowSettings + rpxnowSettings _ = Nothing - emailSettings :: master -> Maybe (AuthEmailSettings master) + emailSettings :: master -> Maybe (EmailSettings master) emailSettings _ = Nothing -- | client id, secret and requested permissions - facebookKeys :: master -> Maybe (String, String, [String]) - facebookKeys _ = Nothing + facebookSettings :: master -> Maybe FacebookSettings + facebookSettings _ = Nothing data Auth = Auth @@ -119,7 +121,12 @@ data EmailCreds m = EmailCreds , emailCredsVerkey :: Maybe VerKey } -data AuthEmailSettings m = AuthEmailSettings +data RpxnowSettings = RpxnowSettings + { rpxnowApp :: String + , rpxnowKey :: String + } + +data EmailSettings m = EmailSettings { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) @@ -131,6 +138,12 @@ data AuthEmailSettings m = AuthEmailSettings , getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) } +data FacebookSettings = FacebookSettings + { fbAppId :: String + , fbSecret :: String + , fbPerms :: [String] + } + -- | User credentials data Creds m = Creds { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. @@ -153,8 +166,8 @@ setCreds creds extra = do Just aid -> showAuthId aid >>= setSession credsKey -- | Retrieves user credentials, if user is authenticated. -maybeCreds :: YesodAuth m => GHandler s m (Maybe (AuthId m)) -maybeCreds = do +maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) +maybeAuthId = do ms <- lookupSession credsKey case ms of Nothing -> return Nothing @@ -166,18 +179,18 @@ mkYesodSub "Auth" [$parseRoutes| /check CheckR GET /logout LogoutR GET -/openid OpenIdR GET /openid/forward OpenIdForwardR GET /openid/complete OpenIdCompleteR GET /login/rpxnow RpxnowR /facebook FacebookR GET -/facebook/start StartFacebookR GET /register EmailRegisterR GET POST /verify/#Integer/#String EmailVerifyR GET -/login EmailLoginR GET POST +/email-login EmailLoginR POST /set-password EmailPasswordR GET POST + +/login LoginR GET |] testOpenId :: YesodAuth master => GHandler Auth master () @@ -185,23 +198,6 @@ testOpenId = do a <- getYesod unless (openIdEnabled a) notFound -getOpenIdR :: YesodAuth master => GHandler Auth master RepHtml -getOpenIdR = do - testOpenId - lookupGetParam "dest" >>= maybe (return ()) setUltDestString - rtom <- getRouteToMaster - message <- getMessage - defaultLayout $ do - setTitle "Log in via OpenID" - addBody [$hamlet| -$maybe message msg - %p.message $msg$ -%form!method=get!action=@rtom.OpenIdForwardR@ - %label!for=openid OpenID: $ - %input#openid!type=text!name=openid - %input!type=submit!value=Login -|] - getOpenIdForwardR :: YesodAuth master => GHandler Auth master () getOpenIdForwardR = do testOpenId @@ -213,7 +209,7 @@ getOpenIdForwardR = do attempt (\err -> do setMessage $ string $ show err - redirect RedirectTemporary $ toMaster OpenIdR) + redirect RedirectTemporary $ toMaster LoginR) (redirectString RedirectTemporary) res @@ -226,7 +222,7 @@ getOpenIdCompleteR = do toMaster <- getRouteToMaster let onFailure err = do setMessage $ string $ show err - redirect RedirectTemporary $ toMaster OpenIdR + redirect RedirectTemporary $ toMaster LoginR let onSuccess (OpenId.Identifier ident) = do y <- getYesod setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) [] @@ -237,7 +233,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod auth <- getYesod - apiKey <- case rpxnowApiKey auth of + apiKey <- case rpxnowApp <$> rpxnowSettings auth of Just x -> return x Nothing -> notFound token1 <- lookupGetParam "token" @@ -272,7 +268,7 @@ getDisplayName extra = getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson getCheckR = do - creds <- maybeCreds + creds <- maybeAuthId defaultLayoutJson (do setTitle "Authentication Status" addBody $ html creds) (json creds) @@ -298,9 +294,9 @@ getLogoutR = do -- | Retrieve user credentials. If user is not logged in, redirects to the -- 'authRoute'. Sets ultimate destination to current route, so user -- should be sent back here after authenticating. -requireCreds :: YesodAuth m => GHandler sub m (AuthId m) -requireCreds = - maybeCreds >>= maybe redirectLogin return +requireAuthId :: YesodAuth m => GHandler sub m (AuthId m) +requireAuthId = + maybeAuthId >>= maybe redirectLogin return where redirectLogin = do y <- getYesod @@ -309,13 +305,13 @@ requireCreds = Just z -> redirect RedirectTemporary z Nothing -> permissionDenied "Please configure authRoute" -getAuthEmailSettings :: YesodAuth master - => GHandler Auth master (AuthEmailSettings master) -getAuthEmailSettings = getYesod >>= maybe notFound return . emailSettings +getEmailSettings :: YesodAuth master + => GHandler Auth master (EmailSettings master) +getEmailSettings = getYesod >>= maybe notFound return . emailSettings getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml getEmailRegisterR = do - _ae <- getAuthEmailSettings + _ae <- getEmailSettings toMaster <- getRouteToMaster defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet| %p Enter your e-mail address below, and a confirmation e-mail will be sent to you. @@ -327,7 +323,7 @@ getEmailRegisterR = do postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml postEmailRegisterR = do - ae <- getAuthEmailSettings + ae <- getEmailSettings email <- runFormPost' $ emailInput "email" mecreds <- getEmailCreds ae email (lid, verKey) <- @@ -355,7 +351,7 @@ getEmailVerifyR :: YesodAuth master => Integer -> String -> GHandler Auth master RepHtml getEmailVerifyR lid' key = do let lid = fromInteger lid' - ae <- getAuthEmailSettings + ae <- getEmailSettings realKey <- getVerifyKey ae lid memail <- getEmail ae lid case (realKey == Just key, memail) of @@ -375,37 +371,9 @@ getEmailVerifyR lid' key = do %p I'm sorry, but that was an invalid verification key. |] -getEmailLoginR :: YesodAuth master => GHandler Auth master RepHtml -getEmailLoginR = do - _ae <- getAuthEmailSettings - toMaster <- getRouteToMaster - msg <- getMessage - defaultLayout $ do - setTitle "Login" - addBody [$hamlet| -$maybe msg ms - %p.message $ms$ -%p Please log in to your account. -%p - %a!href=@toMaster.EmailRegisterR@ I don't have an account -%form!method=post!action=@toMaster.EmailLoginR@ - %table - %tr - %th E-mail - %td - %input!type=email!name=email - %tr - %th Password - %td - %input!type=password!name=password - %tr - %td!colspan=2 - %input!type=submit!value=Login -|] - postEmailLoginR :: YesodAuth master => GHandler Auth master () postEmailLoginR = do - ae <- getAuthEmailSettings + ae <- getEmailSettings (email, pass) <- runFormPost' $ (,) <$> emailInput "email" <*> stringInput "password" @@ -430,13 +398,13 @@ postEmailLoginR = do Nothing -> do setMessage $ string "Invalid email/password combination" toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster EmailLoginR + redirect RedirectTemporary $ toMaster LoginR getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml getEmailPasswordR = do - _ae <- getAuthEmailSettings + _ae <- getEmailSettings toMaster <- getRouteToMaster - maid <- maybeCreds + maid <- maybeAuthId case maid of Just _ -> return () Nothing -> do @@ -463,7 +431,7 @@ getEmailPasswordR = do postEmailPasswordR :: YesodAuth master => GHandler Auth master () postEmailPasswordR = do - ae <- getAuthEmailSettings + ae <- getEmailSettings (new, confirm) <- runFormPost' $ (,) <$> stringInput "new" <*> stringInput "confirm" @@ -471,7 +439,7 @@ postEmailPasswordR = do when (new /= confirm) $ do setMessage $ string "Passwords did not match, please try again" redirect RedirectTemporary $ toMaster EmailPasswordR - maid <- maybeCreds + maid <- maybeAuthId aid <- case maid of Nothing -> do setMessage $ string "You must be logged in to set a password" @@ -505,10 +473,10 @@ saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) getFacebookR :: YesodAuth master => GHandler Auth master () getFacebookR = do y <- getYesod - a <- facebookKeys <$> getYesod + a <- facebookSettings <$> getYesod case a of Nothing -> notFound - Just (cid, secret, _) -> do + Just (FacebookSettings cid secret _) -> do render <- getUrlRender tm <- getRouteToMaster let fb = Facebook.Facebook cid secret $ render $ tm FacebookR @@ -525,14 +493,56 @@ getFacebookR = do setCreds c [] redirectUltDest RedirectTemporary $ defaultDest y -getStartFacebookR :: YesodAuth master => GHandler Auth master () -getStartFacebookR = do +getLoginR :: YesodAuth master => GHandler Auth master RepHtml +getLoginR = do + lookupGetParam "dest" >>= maybe (return ()) setUltDestString + tm <- getRouteToMaster y <- getYesod - case facebookKeys y of - Nothing -> notFound - Just (cid, secret, perms) -> do - render <- getUrlRender - tm <- getRouteToMaster - let fb = Facebook.Facebook cid secret $ render $ tm FacebookR - let fburl = Facebook.getForwardUrl fb perms - redirectString RedirectTemporary fburl + render <- getUrlRender + let facebookUrl f = + let fb = + Facebook.Facebook + (fbAppId f) + (fbSecret f) + (render $ tm FacebookR) + in Facebook.getForwardUrl fb $ fbPerms f + defaultLayout $ do + setTitle "Login" + addStyle [$cassius| +#openid + background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; + padding-left: 18px; +|] + addBody [$hamlet| +$maybe emailSettings.y _ + %h3 Email + %form!method=post!action=@tm.EmailLoginR@ + %table + %tr + %th E-mail + %td + %input!type=email!name=email + %tr + %th Password + %td + %input!type=password!name=password + %tr + %td!colspan=2 + %input!type=submit!value="Login via email" + %a!href=@tm.EmailRegisterR@ I don't have an account +$if openIdEnabled.y + %h3 OpenID + %form!action=@tm.OpenIdForwardR@ + %label!for=openid OpenID: $ + %input#openid!type=text!name=openid + %input!type=submit!value="Login via OpenID" +$maybe facebookSettings.y f + %h3 Facebook + %p + %a!href=$facebookUrl.f$ Login via Facebook +$maybe rpxnowSettings.y r + %h3 OpenID + %p + %a!onclick="return false;"!href="https://$rpxnowApp.r$.rpxnow.com/openid/v2/signin?token_url=@tm.RpxnowR@" + Login via Rpxnow +|] From 7e4ec407797243520ff502253c3091e61b757249 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 27 Aug 2010 13:42:31 +0300 Subject: [PATCH 434/624] Authentication included in scaffolded site --- Yesod/Helpers/Auth.hs | 77 ++++++++++++++-------- scaffold.hs | 148 +++++++++++++++++++++++++++++++----------- 2 files changed, 160 insertions(+), 65 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 9edcbd19..d930f521 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -35,7 +35,9 @@ module Yesod.Helpers.Auth , EmailSettings (..) , FacebookSettings (..) -- * Functions + , maybeAuth , maybeAuthId + , requireAuth , requireAuthId ) where @@ -47,6 +49,7 @@ import Yesod import Yesod.Mail (randomString) import Data.Maybe +import Data.Int (Int64) import Control.Monad import System.Random import Data.Digest.Pure.MD5 @@ -56,19 +59,15 @@ import Data.ByteString.Lazy.UTF8 (fromString) import Data.Object import Language.Haskell.TH.Syntax -class (Integral (AuthEmailId master), Yesod master, - Show (AuthId master), Read (AuthId master), Eq (AuthId master) - ) => YesodAuth master where - type AuthId master - type AuthEmailId master +type AuthId m = Key (AuthEntity m) +type AuthEmailId m = Key (AuthEmailEntity m) - showAuthId :: AuthId master -> GHandler s master String - showAuthId = return . show - - readAuthId :: String -> GHandler s master (Maybe (AuthId master)) - readAuthId s = return $ case reads s of - [] -> Nothing - ((x, _):_) -> Just x +class ( Yesod master + , PersistEntity (AuthEntity master) + , PersistEntity (AuthEmailEntity master) + ) => YesodAuth master where + type AuthEntity master + type AuthEmailEntity master -- | Default destination on successful login or logout, if no other -- destination exists. @@ -163,7 +162,7 @@ setCreds creds extra = do maid <- getAuthId creds extra case maid of Nothing -> return () - Just aid -> showAuthId aid >>= setSession credsKey + Just aid -> setSession credsKey $ show $ fromPersistKey aid -- | Retrieves user credentials, if user is authenticated. maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) @@ -171,7 +170,23 @@ maybeAuthId = do ms <- lookupSession credsKey case ms of Nothing -> return Nothing - Just s -> readAuthId s + Just s -> case reads s of + [] -> return Nothing + (i, _):_ -> return $ Just $ toPersistKey i + +maybeAuth :: ( PersistBackend (YesodDB m (GHandler s m)) + , YesodPersist m + , YesodAuth m + ) => GHandler s m (Maybe (AuthId m, AuthEntity m)) +maybeAuth = do + maid <- maybeAuthId + case maid of + Nothing -> return Nothing + Just aid -> do + ma <- runDB $ get aid + case ma of + Nothing -> return Nothing + Just a -> return $ Just (aid, a) mkYesodSub "Auth" [ ClassP ''YesodAuth [VarT $ mkName "master"] @@ -186,7 +201,7 @@ mkYesodSub "Auth" /facebook FacebookR GET /register EmailRegisterR GET POST -/verify/#Integer/#String EmailVerifyR GET +/verify/#Int64/#String EmailVerifyR GET /email-login EmailLoginR POST /set-password EmailPasswordR GET POST @@ -233,7 +248,7 @@ handleRpxnowR :: YesodAuth master => GHandler Auth master () handleRpxnowR = do ay <- getYesod auth <- getYesod - apiKey <- case rpxnowApp <$> rpxnowSettings auth of + apiKey <- case rpxnowKey <$> rpxnowSettings auth of Just x -> return x Nothing -> notFound token1 <- lookupGetParam "token" @@ -295,15 +310,21 @@ getLogoutR = do -- 'authRoute'. Sets ultimate destination to current route, so user -- should be sent back here after authenticating. requireAuthId :: YesodAuth m => GHandler sub m (AuthId m) -requireAuthId = - maybeAuthId >>= maybe redirectLogin return - where - redirectLogin = do - y <- getYesod - setUltDest' - case authRoute y of - Just z -> redirect RedirectTemporary z - Nothing -> permissionDenied "Please configure authRoute" +requireAuthId = maybeAuthId >>= maybe redirectLogin return + +requireAuth :: ( PersistBackend (YesodDB m (GHandler s m)) + , YesodPersist m + , YesodAuth m + ) => GHandler s m (AuthId m, AuthEntity m) +requireAuth = maybeAuth >>= maybe redirectLogin return + +redirectLogin :: Yesod m => GHandler s m a +redirectLogin = do + y <- getYesod + setUltDest' + case authRoute y of + Just z -> redirect RedirectTemporary z + Nothing -> permissionDenied "Please configure authRoute" getEmailSettings :: YesodAuth master => GHandler Auth master (EmailSettings master) @@ -341,16 +362,16 @@ postEmailRegisterR = do return (lid, key) render <- getUrlRender tm <- getRouteToMaster - let verUrl = render $ tm $ EmailVerifyR (fromIntegral lid) verKey + let verUrl = render $ tm $ EmailVerifyR (fromPersistKey lid) verKey sendVerifyEmail ae email verKey verUrl defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| %p A confirmation e-mail has been sent to $email$. |] getEmailVerifyR :: YesodAuth master - => Integer -> String -> GHandler Auth master RepHtml + => Int64 -> String -> GHandler Auth master RepHtml getEmailVerifyR lid' key = do - let lid = fromInteger lid' + let lid = toPersistKey lid' ae <- getEmailSettings realKey <- getVerifyKey ae lid memail <- getEmail ae lid diff --git a/scaffold.hs b/scaffold.hs index 2a09b8d5..71148489 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -173,13 +173,19 @@ module ~sitearg~ , ~sitearg~Route (..) , resources~sitearg~ , Handler + , maybeAuth + , requireAuth , module Yesod , module Settings , module Model + , StaticRoute (..) + , AuthRoute (..) ) where import Yesod +import Yesod.Mail import Yesod.Helpers.Static +import Yesod.Helpers.Auth import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L @@ -187,6 +193,8 @@ import Yesod.WebRoutes import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile) import Model +import Control.Monad (join) +import Data.Maybe (isJust) data ~sitearg~ = ~sitearg~ { getStatic :: Static @@ -196,10 +204,13 @@ data ~sitearg~ = ~sitearg~ type Handler = GHandler ~sitearg~ ~sitearg~ mkYesodData "~sitearg~" [$parseRoutes| -/ RootR GET POST /static StaticR Static getStatic +/auth AuthR Auth getAuth + /favicon.ico FaviconR GET /robots.txt RobotsR GET + +/ RootR GET |~~] instance Yesod ~sitearg~ where @@ -217,6 +228,7 @@ instance Yesod ~sitearg~ where ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) ss = getSubSite urlRenderOverride _ _ = Nothing + authRoute _ = Just $ AuthR LoginR addStaticContent ext' _ content = do let fn = base64md5 content ++ '.' : ext' let statictmp = Settings.staticdir ++ "/tmp/" @@ -227,6 +239,76 @@ instance Yesod ~sitearg~ where instance YesodPersist ~sitearg~ where type YesodDB ~sitearg~ = SqlPersist runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db + +instance YesodAuth ~sitearg~ where + type AuthEntity ~sitearg~ = User + type AuthEmailEntity ~sitearg~ = Email + + defaultDest _ = RootR + + getAuthId creds _extra = runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (uid, _) -> return $ Just uid + Nothing -> do + fmap Just $ insert $ User (credsIdent creds) Nothing + + openIdEnabled _ = True + + emailSettings _ = Just EmailSettings + { addUnverified = \email verkey -> + runDB $ insert $ Email email Nothing (Just verkey) + , sendVerifyEmail = sendVerifyEmail' + , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get + , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key] + , verifyAccount = \eid -> runDB $ do + me <- get eid + case me of + Nothing -> return Nothing + Just e -> do + let email = emailEmail e + case emailUser e of + Just uid -> return $ Just uid + Nothing -> do + uid <- insert $ User email Nothing + update eid [EmailUser $ Just uid] + return $ Just uid + , getPassword = runDB . fmap (join . fmap userPassword) . get + , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass] + , getEmailCreds = \email -> runDB $ do + me <- getBy $ UniqueEmail email + case me of + Nothing -> return Nothing + Just (eid, e) -> return $ Just EmailCreds + { emailCredsId = eid + , emailCredsAuthId = emailUser e + , emailCredsStatus = isJust $ emailUser e + , emailCredsVerkey = emailVerkey e + } + , getEmail = runDB . fmap (fmap emailEmail) . get + } + +sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () +sendVerifyEmail' email _ verurl = + liftIO $ renderSendMail Mail + { mailHeaders = + [ ("From", "noreply") + , ("To", email) + , ("Subject", "Verify your email address") + ] + , mailPlain = verurl + , mailParts = return Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partDisposition = Inline + , partContent = renderHamlet id [$hamlet| +%p Please confirm your email address by clicking on the link below. +%p + %a!href=$verurl$ $verurl$ +%p Thank you +|~~] + } + } |] writeFile' "Controller.hs" [$codegen| @@ -240,6 +322,7 @@ module Controller import ~sitearg~ import Settings import Yesod.Helpers.Static +import Yesod.Helpers.Auth import Database.Persist.GenericSql import Handler.Root @@ -255,7 +338,8 @@ getRobotsR = return $ RepPlain $ toContent "User-agent: *" with~sitearg~ :: (Application -> IO a) -> IO a with~sitearg~ f = Settings.withConnectionPool $ \p -> do flip runConnectionPool p $ runMigration $ do - migrate (undefined :: Message) + migrate (undefined :: User) + migrate (undefined :: Email) let h = ~sitearg~ s p toWaiApp h >>= f where @@ -269,30 +353,15 @@ module Handler.Root where import ~sitearg~ import Control.Applicative -messageFormlet :: Formlet sub master Message -messageFormlet x = fieldsToTable - $ Message <$> textareaField "Message" - (fmap messageContent x) - getRootR :: Handler RepHtml getRootR = do - messages <- runDB $ selectList [] [] 10 0 - (_, wform, _) <- runFormGet $ messageFormlet Nothing + mu <- maybeAuth defaultLayout $ do + h2id <- newIdent setTitle "~project~ homepage" - ident <- newIdent - form <- extractBody wform addBody $(hamletFile "homepage") addStyle $(cassiusFile "homepage") addJavascript $(juliusFile "homepage") - -postRootR :: Handler () -postRootR = do - (res, _, _) <- runFormPost $ messageFormlet Nothing - case res of - FormSuccess message -> runDB (insert message) >> return () - _ -> return () - redirect RedirectTemporary RootR |] writeFile' "Model.hs" [$codegen| @@ -302,8 +371,15 @@ module Model where import Yesod mkPersist [$persist| -Message - content Textarea +User + ident String + password String null update + UniqueUser ident +Email + email String + user UserId null update + verkey String null update + UniqueEmail email |~~] |] @@ -399,21 +475,17 @@ body writeFile' "hamlet/homepage.hamlet" [$codegen| %h1 Hello -%p#$ident$ Welcome. -%h3 Messages -$if null.messages - %p No messages. -$else - %ul - $forall messages m - %li $messageContent.snd.m$ -%h3 Add Message -%form!method=post!action=@RootR@ - %table - ^form^ - %tr - %td!colspan=2 - %input!type=submit!value="Add Message" +%h2#$h2id$ You do not have Javascript enabled. +$maybe mu u + %p + You are logged in as $userIdent.snd.u$. $ + %a!href=@AuthR.LogoutR@ Logout + \. +$nothing + %p + You are not logged in. $ + %a!href=@AuthR.LoginR@ Login now + \. |] writeFile' "cassius/homepage.cassius" [$codegen| @@ -421,11 +493,13 @@ body font-family: sans-serif h1 text-align: center +h2#$h2id$ + color: #990 |] writeFile' "julius/homepage.julius" [$codegen| window.onload = function(){ - document.getElementById("%ident%").innerHTML = "<i>Added from JavaScript.</i>"; + document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; } |] From c4c3d0b10d9aa04aa1333acd5d2926038d45a611 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 27 Aug 2010 15:05:58 +0300 Subject: [PATCH 435/624] getFacebookUrl function --- Yesod/Helpers/Auth.hs | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d930f521..aa9ea994 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -34,6 +34,7 @@ module Yesod.Helpers.Auth , RpxnowSettings (..) , EmailSettings (..) , FacebookSettings (..) + , getFacebookUrl -- * Functions , maybeAuth , maybeAuthId @@ -514,19 +515,27 @@ getFacebookR = do setCreds c [] redirectUltDest RedirectTemporary $ defaultDest y -getLoginR :: YesodAuth master => GHandler Auth master RepHtml -getLoginR = do - lookupGetParam "dest" >>= maybe (return ()) setUltDestString - tm <- getRouteToMaster +getFacebookUrl :: YesodAuth m + => (AuthRoute -> Route m) -> GHandler s m (Maybe String) +getFacebookUrl tm = do y <- getYesod render <- getUrlRender - let facebookUrl f = + case facebookSettings y of + Nothing -> return Nothing + Just f -> do let fb = Facebook.Facebook (fbAppId f) (fbSecret f) (render $ tm FacebookR) - in Facebook.getForwardUrl fb $ fbPerms f + return $ Just $ Facebook.getForwardUrl fb $ fbPerms f + +getLoginR :: YesodAuth master => GHandler Auth master RepHtml +getLoginR = do + lookupGetParam "dest" >>= maybe (return ()) setUltDestString + tm <- getRouteToMaster + y <- getYesod + fb <- getFacebookUrl tm defaultLayout $ do setTitle "Login" addStyle [$cassius| @@ -557,10 +566,10 @@ $if openIdEnabled.y %label!for=openid OpenID: $ %input#openid!type=text!name=openid %input!type=submit!value="Login via OpenID" -$maybe facebookSettings.y f +$maybe fb f %h3 Facebook %p - %a!href=$facebookUrl.f$ Login via Facebook + %a!href=$f$ Login via Facebook $maybe rpxnowSettings.y r %h3 OpenID %p From 0691d69f19a2e7c36a3cac365c715ccef7d8ffc9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 29 Aug 2010 11:15:50 +0300 Subject: [PATCH 436/624] DEBUG -> PRODUCTION --- scaffold.hs | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index 71148489..21383872 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -113,7 +113,6 @@ Flag production executable simple-server if flag(production) Buildable: False - cpp-options: -DDEBUG main-is: simple-server.hs build-depends: base >= 4 && < 5, yesod >= 0.5 && < 0.6, @@ -132,6 +131,7 @@ executable fastcgi Buildable: True else Buildable: False + cpp-options: -DPRODUCTION main-is: fastcgi.hs build-depends: wai-handler-fastcgi ghc-options: -Wall @@ -351,7 +351,6 @@ with~sitearg~ f = Settings.withConnectionPool $ \p -> do module Handler.Root where import ~sitearg~ -import Control.Applicative getRootR :: Handler RepHtml getRootR = do @@ -406,31 +405,31 @@ import Database.Persist.Sqlite import Yesod (MonadCatchIO) hamletFile :: FilePath -> Q Exp -#ifdef DEBUG -hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" -#else +#ifdef PRODUCTION hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" +#else +hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" #endif cassiusFile :: FilePath -> Q Exp -#ifdef DEBUG -cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" -#else +#ifdef PRODUCTION cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius" +#else +cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" #endif juliusFile :: FilePath -> Q Exp -#ifdef DEBUG -juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" -#else +#ifdef PRODUCTION juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" +#else +juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" #endif connStr :: String -#ifdef DEBUG -connStr = "debug.db3" -#else +#ifdef PRODUCTION connStr = "production.db3" +#else +connStr = "debug.db3" #endif connectionCount :: Int @@ -443,7 +442,7 @@ runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool approot :: String -#ifdef DEBUG +#ifdef PRODUCTION approot = "http://localhost:3000" #else approot = "http://localhost:3000" From 331b2049ffb7bfd88616241890c2de0ae3c7c5b4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 29 Aug 2010 11:21:38 +0300 Subject: [PATCH 437/624] Including favicon.ico, removing Werror --- yesod.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 6153ea9c..462ad921 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -14,6 +14,7 @@ stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/yesod/ +extra-source-files: favicon.ico flag buildtests description: Build the executable to run unit tests @@ -72,7 +73,7 @@ library Yesod.Helpers.Sitemap Yesod.Helpers.Static Yesod.WebRoutes - ghc-options: -Wall -Werror + ghc-options: -Wall executable yesod build-depends: parsec >= 2.1 && < 4 From 3affc81c5226c6a3c01b10ae9518dc204293931e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 31 Aug 2010 08:21:49 +0300 Subject: [PATCH 438/624] Fixed mkToForm --- Yesod/Form.hs | 7 +++---- yesod.cabal | 2 +- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index e65c898a..7001826e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -153,12 +153,11 @@ mkToForm = mapM derive nothing <- [|Nothing|] let just' = just `AppE` ConE (mkName $ entityName t) string' <- [|string|] - mfx <- [|mapFormXml|] ftt <- [|fieldsToTable|] ffs' <- [|FormFieldSettings|] let stm "" = nothing stm x = just `AppE` LitE (StringL x) - let go_ = go ap just' ffs' stm string' mfx ftt + let go_ = go ap just' ffs' stm string' ftt let c1 = Clause [ ConP (mkName "Nothing") [] ] (NormalB $ go_ $ zip cols $ map (const nothing) cols) @@ -178,9 +177,9 @@ mkToForm = mapM derive `AppT` ConT (mkName $ entityName t) `AppT` VarT y) [FunD (mkName "toForm") [c1, c2]] - go ap just' ffs' stm string' mfx ftt a = + go ap just' ffs' stm string' ftt a = let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a - in mfx `AppE` ftt `AppE` x + in ftt `AppE` x go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = let label' = string' `AppE` LitE (StringL label) tooltip' = string' `AppE` LitE (StringL tooltip) diff --git a/yesod.cabal b/yesod.cabal index 462ad921..6406be6f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0 +version: 0.5.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 67f98de1c92d55135fe4f3f56daad145de6e1e48 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 1 Sep 2010 08:22:43 +0300 Subject: [PATCH 439/624] text 0.8 --- yesod.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 6406be6f..a23682da 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0.1 +version: 0.5.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -28,7 +28,7 @@ library authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, directory >= 1 && < 1.1, - text >= 0.5 && < 0.8, + text >= 0.5 && < 0.9, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes-quasi >= 0.6 && < 0.7, From d55c78dc19557d642f450d4f4ef0cecb9eaeb395 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 2 Sep 2010 00:56:14 +0300 Subject: [PATCH 440/624] Minor bug fixes --- ChangeLog.md | 90 ++++++++++++++++++++++++++++++++++++++++++++ Yesod/Form/Fields.hs | 8 +++- scaffold.hs | 11 +++--- yesod.cabal | 2 +- 4 files changed, 103 insertions(+), 8 deletions(-) create mode 100644 ChangeLog.md diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 00000000..d9808462 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,90 @@ +### Yesod 0.5.0 (August 29, 2010) + +* Forms no longer have special types for special views; instead, there is a +toFormField attribute when declaring entities to specify a form rendering +function. + +* URL settings for jQuery and Nic are now in their own typeclasses. This will +be the approach used in the future when adding more widgets and forms that +require Javascript libraries. + +* You can explicitly specify the id and name attributes to be used in forms if +you like. When omitted, a unique name is automatically generated. + +* The isAuthorized function now takes a function specifying whether the +request is a write request. This should make it simpler to develop read/write +authorization systems. Bonus points: if you use HTTP request methods properly, +the isWriteRequest function will automatically determine whether a request is +a read or write request. + +* You can now specify splitPath and joinPath functions yourself. Previously, +the built-in versions had very specific URL rules, such as enforcing a +trailing slash. If you want something more flexible, you can override these +functions. + +* addStaticContent is used to serve CSS and Javascript code from widgets from +external files. This allows caching to take place as you'd normally like. + +* Static files served from the static subsite can have a hash string added to +the query string; this is done automatically when using the getStaticFiles +function. This allows you to set your expires headers far in the future. + +* A new Yesod.Mail module provides datatypes and functions for creating +multipart MIME email messages and sending them via the sendmail executable. +Since these functions generate lazy bytestrings, you can use any delivery +mechanism you want. + +* Change the type of defaultLayout to use Widgets instead of PageContent. This +makes it easier to avoid double-including scripts and stylesheets. + +* Major reworking of the Auth subsite to make it easier to use. + +* Update of the site scaffolder to include much more functionality. Also +removed the Handler type alias from the library, as the scaffolder now +provides that. + +### New in Yesod 0.4.0 + +A big thanks on this release to Simon Michael, who pointed out a number of +places where the docs were unclear, the API was unintuitive, or the names were +inconsistent. + +* Widgets. These allow you to create composable pieces of a webpage that +keep track of their own Javascript and CSS. It includes a function for +obtaining unique identifiers to avoid name collisions, and does automatic +dependency combining; in other words, if you have two widgets that depend on +jQuery, the combined widget will only include it once. + +* Combined the Yesod.Form and Yesod.Formable module into a single, consistent, +widget-based API. It includes basic input functions as well as fancier +Javascript-driven functions; for example, there is a plain day entry field, +and a day entry field which automatically loads the jQuery UI date picker. + +* Added the yesod executable which performs basic scaffolding. + +* Cleaned up a bunch of API function names for consistency. For example, +Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming +scheme. + +* Changed the type of basicHandler to require less typing, and added +basicHandler' which allows you to modify the line output to STDOUT (or skip it +altogether). + +* Switched the Handler monad from ContT to MEitherT (provided by the neither +package). ContT does not have a valid MonadCatchIO instance, which is used for +the sqlite persitent backend. + +* Facebook support in the Auth helper. + +* Ensure that HTTP request methods are given in ALL CAPS. + +* Cleaned up signatures of many methods in the Yesod typeclass. In particular, +due to changes in web-routes-quasi, many of those functions can now live in +the Handler monad, making it easier to use standard functions on them. + +* The static file helper now has extensible file-extension-to-mimetype +mappings. + +* Added the sendResponse function for handler short-circuiting. + +* Renamed Routes to Route. diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index b1c3f229..611df896 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -95,6 +95,8 @@ boolField ffs orig = GForm $ do then (FormMissing, fromMaybe False orig) else case lookup name env of Nothing -> (FormSuccess False, False) + Just "" -> (FormSuccess False, False) + Just "false" -> (FormSuccess False, False) Just _ -> (FormSuccess True, True) let fi = FieldInfo { fiLabel = label @@ -214,7 +216,11 @@ maybeStringInput n = boolInput :: String -> FormInput sub master Bool boolInput n = GForm $ do env <- askParams - let res = FormSuccess $ fromMaybe "" (lookup n env) /= "" + let res = case lookup n env of + Nothing -> FormSuccess False + Just "" -> FormSuccess False + Just "false" -> FormSuccess False + Just _ -> FormSuccess True let xml = addBody [$hamlet| %input#$n$!type=checkbox!name=$n$ |] diff --git a/scaffold.hs b/scaffold.hs index 21383872..86ce7db4 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -120,7 +120,7 @@ executable simple-server directory, bytestring, persistent, - persistent-sqlite, + persistent-~lower~, template-haskell, hamlet ghc-options: -Wall @@ -313,7 +313,6 @@ sendVerifyEmail' email _ verurl = writeFile' "Controller.hs" [$codegen| {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~ @@ -401,7 +400,7 @@ import qualified Text.Hamlet as H import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax -import Database.Persist.Sqlite +import Database.Persist.~upper~ import Yesod (MonadCatchIO) hamletFile :: FilePath -> Q Exp @@ -427,16 +426,16 @@ juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" connStr :: String #ifdef PRODUCTION -connStr = "production.db3" +connStr = "~connstr2~" #else -connStr = "debug.db3" +connStr = "~connstr1~" #endif connectionCount :: Int connectionCount = 10 withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a -withConnectionPool = withSqlitePool connStr connectionCount +withConnectionPool = with~upper~Pool connStr connectionCount runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/yesod.cabal b/yesod.cabal index a23682da..13e2b2d1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0.2 +version: 0.5.0.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From cf4ff040ced0a87c54c78b479449817394d2493a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 13 Sep 2010 11:21:32 +0200 Subject: [PATCH 441/624] TemplateHaskell extension added --- yesod.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 13e2b2d1..cc909a60 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0.3 +version: 0.5.0.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -80,6 +80,7 @@ executable yesod ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGenQ + extensions: TemplateHaskell executable runtests if flag(buildtests) From 3edbd38168bac25f3ffb5aaa902b822b6857f2f6 Mon Sep 17 00:00:00 2001 From: Rehno Lindeque <errantkid@gmail.com> Date: Tue, 14 Sep 2010 11:48:25 +0200 Subject: [PATCH 442/624] Added some documentation for StaticRoute. (Needs to be checked...) --- Yesod/Helpers/Static.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 593dd5d7..c739001f 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -67,6 +67,13 @@ data Static = Static , staticTypes :: [(String, ContentType)] } +-- | Manually construct a static route. +-- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. +-- For example, +-- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] +-- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' +-- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. +-- E.g. When generating image galleries. data StaticRoute = StaticRoute [String] [(String, String)] deriving (Eq, Show, Read) @@ -138,8 +145,8 @@ getFileList = flip go id -- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: -- --- > style_css = StaticRoute ["style.css"] --- > js_script_js = StaticRoute ["js/script.js"] +-- > style_css = StaticRoute ["style.css"] [] +-- > js_script_js = StaticRoute ["js/script.js"] [] staticFiles :: FilePath -> Q [Dec] staticFiles fp = do fs <- qRunIO $ getFileList fp From d7832b0535047cab651017b666c5415f3619f254 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 15 Sep 2010 11:44:42 +0200 Subject: [PATCH 443/624] EscapedHtml --- Yesod/Form/Class.hs | 7 ++++++- Yesod/Form/Fields.hs | 8 ++++++++ Yesod/Form/Profiles.hs | 19 +++++++++++++++++++ yesod.cabal | 2 +- 4 files changed, 34 insertions(+), 2 deletions(-) diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 290b15d7..1b77eb2e 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -9,7 +9,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea) +import Yesod.Form.Profiles (Textarea, EscapedHtml) import Data.Int (Int64) import Data.Time (Day, TimeOfDay) @@ -59,3 +59,8 @@ instance ToFormField Textarea y where toFormField = textareaField instance ToFormField (Maybe Textarea) y where toFormField = maybeTextareaField + +instance ToFormField EscapedHtml y where + toFormField = escapedHtmlField +instance ToFormField (Maybe EscapedHtml) y where + toFormField = maybeEscapedHtmlField diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 611df896..58b838b1 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -4,6 +4,7 @@ module Yesod.Form.Fields -- ** Required stringField , textareaField + , escapedHtmlField , hiddenField , intField , doubleField @@ -17,6 +18,7 @@ module Yesod.Form.Fields -- ** Optional , maybeStringField , maybeTextareaField + , maybeEscapedHtmlField , maybeHiddenField , maybeIntField , maybeDoubleField @@ -267,6 +269,12 @@ textareaField = requiredFieldHelper textareaFieldProfile maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile +escapedHtmlField :: FormFieldSettings -> FormletField sub y EscapedHtml +escapedHtmlField = requiredFieldHelper escapedHtmlFieldProfile + +maybeEscapedHtmlField :: FormFieldSettings -> FormletField sub y (Maybe EscapedHtml) +maybeEscapedHtmlField = optionalFieldHelper escapedHtmlFieldProfile + hiddenField :: FormFieldSettings -> FormletField sub y String hiddenField = requiredFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 521a7cd1..f8c73347 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -4,6 +4,7 @@ module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile + , escapedHtmlFieldProfile , hiddenFieldProfile , intFieldProfile , dayFieldProfile @@ -16,6 +17,7 @@ module Yesod.Form.Profiles , parseDate , parseTime , Textarea (..) + , EscapedHtml (..) ) where import Yesod.Form.Core @@ -110,6 +112,23 @@ textareaFieldProfile = FieldProfile |] } +-- | A newtype wrapper around a 'Html' that automatically entity-escapes all +-- input from the user. This means that values stored in the database are +-- already entity-escaped, avoiding escaping each time it is rendered. +newtype EscapedHtml = EscapedHtml { unEscapedHtml :: Html } + deriving (Show, Eq, PersistField) +instance ToHtml EscapedHtml where + toHtml = unEscapedHtml + +escapedHtmlFieldProfile :: FieldProfile sub y EscapedHtml +escapedHtmlFieldProfile = FieldProfile + { fpParse = Right . EscapedHtml . string + , fpRender = U.toString . renderHtml . unEscapedHtml + , fpWidget = \theId name val _isReq -> addBody [$hamlet| +%textarea#$theId$!name=$name$ $val$ +|] + } + hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile = FieldProfile { fpParse = Right diff --git a/yesod.cabal b/yesod.cabal index cc909a60..25533e8b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0.4 +version: 0.5.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From b13c08f00182a06b13929a0f8e8a3ad5ca30231a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Sep 2010 07:26:34 +0200 Subject: [PATCH 444/624] Revert "EscapedHtml" This reverts commit d7832b0535047cab651017b666c5415f3619f254. --- Yesod/Form/Class.hs | 7 +------ Yesod/Form/Fields.hs | 8 -------- Yesod/Form/Profiles.hs | 19 ------------------- yesod.cabal | 2 +- 4 files changed, 2 insertions(+), 34 deletions(-) diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs index 1b77eb2e..290b15d7 100644 --- a/Yesod/Form/Class.hs +++ b/Yesod/Form/Class.hs @@ -9,7 +9,7 @@ module Yesod.Form.Class import Text.Hamlet import Yesod.Form.Fields import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea, EscapedHtml) +import Yesod.Form.Profiles (Textarea) import Data.Int (Int64) import Data.Time (Day, TimeOfDay) @@ -59,8 +59,3 @@ instance ToFormField Textarea y where toFormField = textareaField instance ToFormField (Maybe Textarea) y where toFormField = maybeTextareaField - -instance ToFormField EscapedHtml y where - toFormField = escapedHtmlField -instance ToFormField (Maybe EscapedHtml) y where - toFormField = maybeEscapedHtmlField diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 58b838b1..611df896 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -4,7 +4,6 @@ module Yesod.Form.Fields -- ** Required stringField , textareaField - , escapedHtmlField , hiddenField , intField , doubleField @@ -18,7 +17,6 @@ module Yesod.Form.Fields -- ** Optional , maybeStringField , maybeTextareaField - , maybeEscapedHtmlField , maybeHiddenField , maybeIntField , maybeDoubleField @@ -269,12 +267,6 @@ textareaField = requiredFieldHelper textareaFieldProfile maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile -escapedHtmlField :: FormFieldSettings -> FormletField sub y EscapedHtml -escapedHtmlField = requiredFieldHelper escapedHtmlFieldProfile - -maybeEscapedHtmlField :: FormFieldSettings -> FormletField sub y (Maybe EscapedHtml) -maybeEscapedHtmlField = optionalFieldHelper escapedHtmlFieldProfile - hiddenField :: FormFieldSettings -> FormletField sub y String hiddenField = requiredFieldHelper hiddenFieldProfile diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index f8c73347..521a7cd1 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -4,7 +4,6 @@ module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile - , escapedHtmlFieldProfile , hiddenFieldProfile , intFieldProfile , dayFieldProfile @@ -17,7 +16,6 @@ module Yesod.Form.Profiles , parseDate , parseTime , Textarea (..) - , EscapedHtml (..) ) where import Yesod.Form.Core @@ -112,23 +110,6 @@ textareaFieldProfile = FieldProfile |] } --- | A newtype wrapper around a 'Html' that automatically entity-escapes all --- input from the user. This means that values stored in the database are --- already entity-escaped, avoiding escaping each time it is rendered. -newtype EscapedHtml = EscapedHtml { unEscapedHtml :: Html } - deriving (Show, Eq, PersistField) -instance ToHtml EscapedHtml where - toHtml = unEscapedHtml - -escapedHtmlFieldProfile :: FieldProfile sub y EscapedHtml -escapedHtmlFieldProfile = FieldProfile - { fpParse = Right . EscapedHtml . string - , fpRender = U.toString . renderHtml . unEscapedHtml - , fpWidget = \theId name val _isReq -> addBody [$hamlet| -%textarea#$theId$!name=$name$ $val$ -|] - } - hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile = FieldProfile { fpParse = Right diff --git a/yesod.cabal b/yesod.cabal index 25533e8b..cc909a60 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.1 +version: 0.5.0.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 83368b05fd5bbf07ca14fc74810a6537ef972c6d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Sep 2010 09:24:42 +0200 Subject: [PATCH 445/624] Scaffolder uses separate files --- CodeGenQ.hs => CodeGen.hs | 21 +- scaffold.hs | 491 ++----------------------- scaffold/Controller_hs.cg | 32 ++ scaffold/LICENSE.cg | 26 ++ scaffold/Model_hs.cg | 17 + scaffold/Root_hs.cg | 15 + scaffold/Settings_hs.cg | 71 ++++ scaffold/cabal.cg | 45 +++ scaffold/database.cg | 6 + scaffold/default-layout_cassius.cg | 3 + scaffold/default-layout_hamlet.cg | 10 + scaffold/dir-name.cg | 5 + scaffold/fastcgi_hs.cg | 6 + favicon.ico => scaffold/favicon_ico.cg | Bin scaffold/homepage_cassius.cg | 5 + scaffold/homepage_hamlet.cg | 13 + scaffold/homepage_julius.cg | 4 + scaffold/pconn1.cg | 1 + scaffold/pconn2.cg | 1 + scaffold/project-name.cg | 4 + scaffold/simple-server_hs.cg | 6 + scaffold/site-arg.cg | 5 + scaffold/sitearg_hs.cg | 143 +++++++ scaffold/welcome.cg | 6 + yesod.cabal | 4 +- 25 files changed, 461 insertions(+), 479 deletions(-) rename CodeGenQ.hs => CodeGen.hs (63%) create mode 100644 scaffold/Controller_hs.cg create mode 100644 scaffold/LICENSE.cg create mode 100644 scaffold/Model_hs.cg create mode 100644 scaffold/Root_hs.cg create mode 100644 scaffold/Settings_hs.cg create mode 100644 scaffold/cabal.cg create mode 100644 scaffold/database.cg create mode 100644 scaffold/default-layout_cassius.cg create mode 100644 scaffold/default-layout_hamlet.cg create mode 100644 scaffold/dir-name.cg create mode 100644 scaffold/fastcgi_hs.cg rename favicon.ico => scaffold/favicon_ico.cg (100%) create mode 100644 scaffold/homepage_cassius.cg create mode 100644 scaffold/homepage_hamlet.cg create mode 100644 scaffold/homepage_julius.cg create mode 100644 scaffold/pconn1.cg create mode 100644 scaffold/pconn2.cg create mode 100644 scaffold/project-name.cg create mode 100644 scaffold/simple-server_hs.cg create mode 100644 scaffold/site-arg.cg create mode 100644 scaffold/sitearg_hs.cg create mode 100644 scaffold/welcome.cg diff --git a/CodeGenQ.hs b/CodeGen.hs similarity index 63% rename from CodeGenQ.hs rename to CodeGen.hs index ddd5d740..75f1e609 100644 --- a/CodeGenQ.hs +++ b/CodeGen.hs @@ -1,29 +1,24 @@ {-# LANGUAGE TemplateHaskell #-} --- | A code generation quasi-quoter. Everything is taken as literal text, with ~var~ variable interpolation, and ~~ is completely ignored. -module CodeGenQ (codegen) where +-- | A code generation template haskell. Everything is taken as literal text, +-- with ~var~ variable interpolation. +module CodeGen (codegen) where -import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.ParserCombinators.Parsec - -codegen :: QuasiQuoter -codegen = QuasiQuoter codegen' $ error "codegen cannot be a pattern" +import qualified System.IO.UTF8 as U data Token = VarToken String | LitToken String | EmptyToken -codegen' :: String -> Q Exp -codegen' s' = do - let s = killFirstBlank s' +codegen :: FilePath -> Q Exp +codegen fp = do + s' <- qRunIO $ U.readFile $ "scaffold/" ++ fp ++ ".cg" + let s = init s' case parse (many parseToken) s s of Left e -> error $ show e Right tokens' -> do let tokens'' = map toExp tokens' concat' <- [|concat|] return $ concat' `AppE` ListE tokens'' - where - killFirstBlank ('\n':x) = x - killFirstBlank ('\r':'\n':x) = x - killFirstBlank x = x toExp :: Token -> Exp toExp (LitToken s) = LitE $ StringL s diff --git a/scaffold.hs b/scaffold.hs index 86ce7db4..8b72e5e6 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell #-} -import CodeGenQ +{-# LANGUAGE TemplateHaskell #-} +import CodeGen import System.IO import System.Directory import qualified Data.ByteString.Char8 as S @@ -7,63 +7,35 @@ import Language.Haskell.TH.Syntax main :: IO () main = do - putStr [$codegen|Welcome to the Yesod scaffolder. -I'm going to be creating a skeleton Yesod project for you. - -What is your name? We're going to put this in the cabal and LICENSE files. - -Your name: |] + putStr $(codegen "welcome") hFlush stdout name <- getLine - putStr [$codegen| -Welcome ~name~. -What do you want to call your project? We'll use this for the cabal name. - -Project name: |] + putStr $(codegen "project-name") hFlush stdout project <- getLine - putStr [$codegen| -Now where would you like me to place your generated files? I'm smart enough -to create the directories, don't worry about that. If you leave this answer -blank, we'll place the files in ~project~. - -Directory name: |] + putStr $(codegen "dir-name") hFlush stdout dirRaw <- getLine let dir = if null dirRaw then project else dirRaw - putStr [$codegen| -Great, we'll be creating ~project~ today, and placing it in ~dir~. -What's going to be the name of your site argument datatype? This name must -start with a capital letter. - -Site argument: |] + putStr $(codegen "site-arg") hFlush stdout sitearg <- getLine - putStr [$codegen| -That's it! I'm creating your files now... -|] - - putStr [$codegen| -Yesod uses Persistent for its (you guessed it) persistence layer. -This tool will build in either SQLite or PostgreSQL support for you. If you -want to use a different backend, you'll have to make changes manually. -If you're not sure, stick with SQLite: it has no dependencies. - -So, what'll it be? s for sqlite, p for postgresql: |] + putStr $(codegen "database") hFlush stdout backendS <- getLine - let pconn1 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug|] - let pconn2 = [$codegen|user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production|] + let pconn1 = $(codegen "pconn1") + let pconn2 = $(codegen "pconn2") let (lower, upper, connstr1, connstr2) = case backendS of "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3") "p" -> ("postgresql", "Postgresql", pconn1, pconn2) _ -> error $ "Invalid backend: " ++ backendS + putStrLn "That's it! I'm creating your files now..." let writeFile' fp s = do putStrLn $ "Generating " ++ fp @@ -75,433 +47,24 @@ So, what'll it be? s for sqlite, p for postgresql: |] mkDir "cassius" mkDir "julius" - writeFile' "simple-server.hs" [$codegen| -import Controller -import Network.Wai.Handler.SimpleServer (run) - -main :: IO () -main = putStrLn "Loaded" >> with~sitearg~ (run 3000) -|] - - writeFile' "fastcgi.hs" [$codegen| -import Controller -import Network.Wai.Handler.FastCGI (run) - -main :: IO () -main = with~sitearg~ run -|] - - writeFile' (project ++ ".cabal") [$codegen| -name: ~project~ -version: 0.0.0 -license: BSD3 -license-file: LICENSE -author: ~name~ -maintainer: ~name~ -synopsis: The greatest Yesod web application ever. -description: I'm sure you can say something clever here if you try. -category: Web -stability: Experimental -cabal-version: >= 1.6 -build-type: Simple -homepage: http://www.yesodweb.com/~project~ - -Flag production - Description: Build the production executable. - Default: False - -executable simple-server - if flag(production) - Buildable: False - main-is: simple-server.hs - build-depends: base >= 4 && < 5, - yesod >= 0.5 && < 0.6, - wai-extra, - directory, - bytestring, - persistent, - persistent-~lower~, - template-haskell, - hamlet - ghc-options: -Wall - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies - -executable fastcgi - if flag(production) - Buildable: True - else - Buildable: False - cpp-options: -DPRODUCTION - main-is: fastcgi.hs - build-depends: wai-handler-fastcgi - ghc-options: -Wall - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies -|] - - writeFile' "LICENSE" [$codegen| -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, ~name~. 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. -|] - - writeFile' (sitearg ++ ".hs") [$codegen| -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} -module ~sitearg~ - ( ~sitearg~ (..) - , ~sitearg~Route (..) - , resources~sitearg~ - , Handler - , maybeAuth - , requireAuth - , module Yesod - , module Settings - , module Model - , StaticRoute (..) - , AuthRoute (..) - ) where - -import Yesod -import Yesod.Mail -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import qualified Settings -import System.Directory -import qualified Data.ByteString.Lazy as L -import Yesod.WebRoutes -import Database.Persist.GenericSql -import Settings (hamletFile, cassiusFile, juliusFile) -import Model -import Control.Monad (join) -import Data.Maybe (isJust) - -data ~sitearg~ = ~sitearg~ - { getStatic :: Static - , connPool :: Settings.ConnectionPool - } - -type Handler = GHandler ~sitearg~ ~sitearg~ - -mkYesodData "~sitearg~" [$parseRoutes| -/static StaticR Static getStatic -/auth AuthR Auth getAuth - -/favicon.ico FaviconR GET -/robots.txt RobotsR GET - -/ RootR GET -|~~] - -instance Yesod ~sitearg~ where - approot _ = Settings.approot - defaultLayout widget = do - mmsg <- getMessage - pc <- widgetToPageContent $ do - widget - addStyle $(Settings.cassiusFile "default-layout") - hamletToRepHtml $(Settings.hamletFile "default-layout") - urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ format s - where - format = formatPathSegments ss - ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) - ss = getSubSite - urlRenderOverride _ _ = Nothing - authRoute _ = Just $ AuthR LoginR - addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : ext' - let statictmp = Settings.staticdir ++ "/tmp/" - liftIO $ createDirectoryIfMissing True statictmp - liftIO $ L.writeFile (statictmp ++ fn) content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - -instance YesodPersist ~sitearg~ where - type YesodDB ~sitearg~ = SqlPersist - runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db - -instance YesodAuth ~sitearg~ where - type AuthEntity ~sitearg~ = User - type AuthEmailEntity ~sitearg~ = Email - - defaultDest _ = RootR - - getAuthId creds _extra = runDB $ do - x <- getBy $ UniqueUser $ credsIdent creds - case x of - Just (uid, _) -> return $ Just uid - Nothing -> do - fmap Just $ insert $ User (credsIdent creds) Nothing - - openIdEnabled _ = True - - emailSettings _ = Just EmailSettings - { addUnverified = \email verkey -> - runDB $ insert $ Email email Nothing (Just verkey) - , sendVerifyEmail = sendVerifyEmail' - , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get - , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key] - , verifyAccount = \eid -> runDB $ do - me <- get eid - case me of - Nothing -> return Nothing - Just e -> do - let email = emailEmail e - case emailUser e of - Just uid -> return $ Just uid - Nothing -> do - uid <- insert $ User email Nothing - update eid [EmailUser $ Just uid] - return $ Just uid - , getPassword = runDB . fmap (join . fmap userPassword) . get - , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass] - , getEmailCreds = \email -> runDB $ do - me <- getBy $ UniqueEmail email - case me of - Nothing -> return Nothing - Just (eid, e) -> return $ Just EmailCreds - { emailCredsId = eid - , emailCredsAuthId = emailUser e - , emailCredsStatus = isJust $ emailUser e - , emailCredsVerkey = emailVerkey e - } - , getEmail = runDB . fmap (fmap emailEmail) . get - } - -sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () -sendVerifyEmail' email _ verurl = - liftIO $ renderSendMail Mail - { mailHeaders = - [ ("From", "noreply") - , ("To", email) - , ("Subject", "Verify your email address") - ] - , mailPlain = verurl - , mailParts = return Part - { partType = "text/html; charset=utf-8" - , partEncoding = None - , partDisposition = Inline - , partContent = renderHamlet id [$hamlet| -%p Please confirm your email address by clicking on the link below. -%p - %a!href=$verurl$ $verurl$ -%p Thank you -|~~] - } - } -|] - - writeFile' "Controller.hs" [$codegen| -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Controller - ( with~sitearg~ - ) where - -import ~sitearg~ -import Settings -import Yesod.Helpers.Static -import Yesod.Helpers.Auth -import Database.Persist.GenericSql - -import Handler.Root - -mkYesodDispatch "~sitearg~" resources~sitearg~ - -getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" "favicon.ico" - -getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent "User-agent: *" - -with~sitearg~ :: (Application -> IO a) -> IO a -with~sitearg~ f = Settings.withConnectionPool $ \p -> do - flip runConnectionPool p $ runMigration $ do - migrate (undefined :: User) - migrate (undefined :: Email) - let h = ~sitearg~ s p - toWaiApp h >>= f - where - s = fileLookupDir Settings.staticdir typeByExt -|] - - writeFile' "Handler/Root.hs" [$codegen| -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} -module Handler.Root where - -import ~sitearg~ - -getRootR :: Handler RepHtml -getRootR = do - mu <- maybeAuth - defaultLayout $ do - h2id <- newIdent - setTitle "~project~ homepage" - addBody $(hamletFile "homepage") - addStyle $(cassiusFile "homepage") - addJavascript $(juliusFile "homepage") -|] - - writeFile' "Model.hs" [$codegen| -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} -module Model where - -import Yesod - -mkPersist [$persist| -User - ident String - password String null update - UniqueUser ident -Email - email String - user UserId null update - verkey String null update - UniqueEmail email -|~~] -|] - - writeFile' "Settings.hs" [$codegen| -{-# LANGUAGE CPP #-} -module Settings - ( hamletFile - , cassiusFile - , juliusFile - , connStr - , ConnectionPool - , withConnectionPool - , runConnectionPool - , approot - , staticroot - , staticdir - ) where - -import qualified Text.Hamlet as H -import qualified Text.Cassius as H -import qualified Text.Julius as H -import Language.Haskell.TH.Syntax -import Database.Persist.~upper~ -import Yesod (MonadCatchIO) - -hamletFile :: FilePath -> Q Exp -#ifdef PRODUCTION -hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" -#else -hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" -#endif - -cassiusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius" -#else -cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" -#endif - -juliusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" -#else -juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" -#endif - -connStr :: String -#ifdef PRODUCTION -connStr = "~connstr2~" -#else -connStr = "~connstr1~" -#endif - -connectionCount :: Int -connectionCount = 10 - -withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a -withConnectionPool = with~upper~Pool connStr connectionCount - -runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a -runConnectionPool = runSqlPool - -approot :: String -#ifdef PRODUCTION -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif - -staticroot :: String -staticroot = approot ++ "/static" - -staticdir :: FilePath -staticdir = "static" -|] - - writeFile' "cassius/default-layout.cassius" [$codegen| -body - font-family: sans-serif -|] - - writeFile' "hamlet/default-layout.hamlet" [$codegen| -!!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ -|] - - writeFile' "hamlet/homepage.hamlet" [$codegen| -%h1 Hello -%h2#$h2id$ You do not have Javascript enabled. -$maybe mu u - %p - You are logged in as $userIdent.snd.u$. $ - %a!href=@AuthR.LogoutR@ Logout - \. -$nothing - %p - You are not logged in. $ - %a!href=@AuthR.LoginR@ Login now - \. -|] - - writeFile' "cassius/homepage.cassius" [$codegen| -body - font-family: sans-serif -h1 - text-align: center -h2#$h2id$ - color: #990 -|] - - writeFile' "julius/homepage.julius" [$codegen| -window.onload = function(){ - document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; -} -|] + writeFile' "simple-server.hs" $(codegen "simple-server_hs") + writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") + writeFile' (project ++ ".cabal") $(codegen "cabal") + writeFile' "LICENSE" $(codegen "LICENSE") + writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs") + writeFile' "Controller.hs" $(codegen "Controller_hs") + writeFile' "Handler/Root.hs" $(codegen "Root_hs") + writeFile' "Model.hs" $(codegen "Model_hs") + writeFile' "Settings.hs" $(codegen "Settings_hs") + writeFile' "cassius/default-layout.cassius" + $(codegen "default-layout_cassius") + writeFile' "hamlet/default-layout.hamlet" + $(codegen "default-layout_hamlet") + writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet") + writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") + writeFile' "julius/homepage.julius" $(codegen "homepage_julius") S.writeFile (dir ++ "/favicon.ico") - $(runIO (S.readFile "favicon.ico") >>= \bs -> do + $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg new file mode 100644 index 00000000..b0ef7f7d --- /dev/null +++ b/scaffold/Controller_hs.cg @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( with~sitearg~ + ) where + +import ~sitearg~ +import Settings +import Yesod.Helpers.Static +import Yesod.Helpers.Auth +import Database.Persist.GenericSql + +import Handler.Root + +mkYesodDispatch "~sitearg~" resources~sitearg~ + +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" "favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent "User-agent: *" + +with~sitearg~ :: (Application -> IO a) -> IO a +with~sitearg~ f = Settings.withConnectionPool $ \p -> do + flip runConnectionPool p $ runMigration $ do + migrate (undefined :: User) + migrate (undefined :: Email) + let h = ~sitearg~ s p + toWaiApp h >>= f + where + s = fileLookupDir Settings.staticdir typeByExt + diff --git a/scaffold/LICENSE.cg b/scaffold/LICENSE.cg new file mode 100644 index 00000000..049c97b2 --- /dev/null +++ b/scaffold/LICENSE.cg @@ -0,0 +1,26 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, ~name~. 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. + diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg new file mode 100644 index 00000000..e7c25078 --- /dev/null +++ b/scaffold/Model_hs.cg @@ -0,0 +1,17 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} +module Model where + +import Yesod + +mkPersist [$persist| +User + ident String + password String null update + UniqueUser ident +Email + email String + user UserId null update + verkey String null update + UniqueEmail email +|~~] + diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg new file mode 100644 index 00000000..88b16022 --- /dev/null +++ b/scaffold/Root_hs.cg @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +module Handler.Root where + +import ~sitearg~ + +getRootR :: Handler RepHtml +getRootR = do + mu <- maybeAuth + defaultLayout $ do + h2id <- newIdent + setTitle "~project~ homepage" + addBody $(hamletFile "homepage") + addStyle $(cassiusFile "homepage") + addJavascript $(juliusFile "homepage") + diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg new file mode 100644 index 00000000..24aab568 --- /dev/null +++ b/scaffold/Settings_hs.cg @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +module Settings + ( hamletFile + , cassiusFile + , juliusFile + , connStr + , ConnectionPool + , withConnectionPool + , runConnectionPool + , approot + , staticroot + , staticdir + ) where + +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import Language.Haskell.TH.Syntax +import Database.Persist.~upper~ +import Yesod (MonadCatchIO) + +hamletFile :: FilePath -> Q Exp +#ifdef PRODUCTION +hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" +#else +hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" +#endif + +cassiusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius" +#else +cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" +#endif + +juliusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" +#else +juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" +#endif + +connStr :: String +#ifdef PRODUCTION +connStr = "~connstr2~" +#else +connStr = "~connstr1~" +#endif + +connectionCount :: Int +connectionCount = 10 + +withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a +withConnectionPool = with~upper~Pool connStr connectionCount + +runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +approot :: String +#ifdef PRODUCTION +approot = "http://localhost:3000" +#else +approot = "http://localhost:3000" +#endif + +staticroot :: String +staticroot = approot ++ "/static" + +staticdir :: FilePath +staticdir = "static" + diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg new file mode 100644 index 00000000..b9d0d890 --- /dev/null +++ b/scaffold/cabal.cg @@ -0,0 +1,45 @@ +name: ~project~ +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: ~name~ +maintainer: ~name~ +synopsis: The greatest Yesod web application ever. +description: I'm sure you can say something clever here if you try. +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com/~project~ + +Flag production + Description: Build the production executable. + Default: False + +executable simple-server + if flag(production) + Buildable: False + main-is: simple-server.hs + build-depends: base >= 4 && < 5, + yesod >= 0.5 && < 0.6, + wai-extra, + directory, + bytestring, + persistent, + persistent-~lower~, + template-haskell, + hamlet + ghc-options: -Wall + extensions: TemplateHaskell, QuasiQuotes, TypeFamilies + +executable fastcgi + if flag(production) + Buildable: True + else + Buildable: False + cpp-options: -DPRODUCTION + main-is: fastcgi.hs + build-depends: wai-handler-fastcgi + ghc-options: -Wall + extensions: TemplateHaskell, QuasiQuotes, TypeFamilies + diff --git a/scaffold/database.cg b/scaffold/database.cg new file mode 100644 index 00000000..25c13784 --- /dev/null +++ b/scaffold/database.cg @@ -0,0 +1,6 @@ +Yesod uses Persistent for its (you guessed it) persistence layer. +This tool will build in either SQLite or PostgreSQL support for you. If you +want to use a different backend, you'll have to make changes manually. +If you're not sure, stick with SQLite: it has no dependencies. + +So, what'll it be? s for sqlite, p for postgresql: diff --git a/scaffold/default-layout_cassius.cg b/scaffold/default-layout_cassius.cg new file mode 100644 index 00000000..77177469 --- /dev/null +++ b/scaffold/default-layout_cassius.cg @@ -0,0 +1,3 @@ +body + font-family: sans-serif + diff --git a/scaffold/default-layout_hamlet.cg b/scaffold/default-layout_hamlet.cg new file mode 100644 index 00000000..3bcfae41 --- /dev/null +++ b/scaffold/default-layout_hamlet.cg @@ -0,0 +1,10 @@ +!!! +%html + %head + %title $pageTitle.pc$ + ^pageHead.pc^ + %body + $maybe mmsg msg + #message $msg$ + ^pageBody.pc^ + diff --git a/scaffold/dir-name.cg b/scaffold/dir-name.cg new file mode 100644 index 00000000..dc74c147 --- /dev/null +++ b/scaffold/dir-name.cg @@ -0,0 +1,5 @@ +Now where would you like me to place your generated files? I'm smart enough +to create the directories, don't worry about that. If you leave this answer +blank, we'll place the files in ~project~. + +Directory name: diff --git a/scaffold/fastcgi_hs.cg b/scaffold/fastcgi_hs.cg new file mode 100644 index 00000000..d946d7c7 --- /dev/null +++ b/scaffold/fastcgi_hs.cg @@ -0,0 +1,6 @@ +import Controller +import Network.Wai.Handler.FastCGI (run) + +main :: IO () +main = with~sitearg~ run + diff --git a/favicon.ico b/scaffold/favicon_ico.cg similarity index 100% rename from favicon.ico rename to scaffold/favicon_ico.cg diff --git a/scaffold/homepage_cassius.cg b/scaffold/homepage_cassius.cg new file mode 100644 index 00000000..c2873e00 --- /dev/null +++ b/scaffold/homepage_cassius.cg @@ -0,0 +1,5 @@ +h1 + text-align: center +h2#$h2id$ + color: #990 + diff --git a/scaffold/homepage_hamlet.cg b/scaffold/homepage_hamlet.cg new file mode 100644 index 00000000..55bf9683 --- /dev/null +++ b/scaffold/homepage_hamlet.cg @@ -0,0 +1,13 @@ +%h1 Hello +%h2#$h2id$ You do not have Javascript enabled. +$maybe mu u + %p + You are logged in as $userIdent.snd.u$. $ + %a!href=@AuthR.LogoutR@ Logout + \. +$nothing + %p + You are not logged in. $ + %a!href=@AuthR.LoginR@ Login now + \. + diff --git a/scaffold/homepage_julius.cg b/scaffold/homepage_julius.cg new file mode 100644 index 00000000..281c89aa --- /dev/null +++ b/scaffold/homepage_julius.cg @@ -0,0 +1,4 @@ +window.onload = function(){ + document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; +} + diff --git a/scaffold/pconn1.cg b/scaffold/pconn1.cg new file mode 100644 index 00000000..2fbf5964 --- /dev/null +++ b/scaffold/pconn1.cg @@ -0,0 +1 @@ +user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug diff --git a/scaffold/pconn2.cg b/scaffold/pconn2.cg new file mode 100644 index 00000000..5dbfefe0 --- /dev/null +++ b/scaffold/pconn2.cg @@ -0,0 +1 @@ +user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production diff --git a/scaffold/project-name.cg b/scaffold/project-name.cg new file mode 100644 index 00000000..a9742993 --- /dev/null +++ b/scaffold/project-name.cg @@ -0,0 +1,4 @@ +Welcome ~name~. +What do you want to call your project? We'll use this for the cabal name. + +Project name: diff --git a/scaffold/simple-server_hs.cg b/scaffold/simple-server_hs.cg new file mode 100644 index 00000000..9a630481 --- /dev/null +++ b/scaffold/simple-server_hs.cg @@ -0,0 +1,6 @@ +import Controller +import Network.Wai.Handler.SimpleServer (run) + +main :: IO () +main = putStrLn "Loaded" >> with~sitearg~ (run 3000) + diff --git a/scaffold/site-arg.cg b/scaffold/site-arg.cg new file mode 100644 index 00000000..28e7e31a --- /dev/null +++ b/scaffold/site-arg.cg @@ -0,0 +1,5 @@ +Great, we'll be creating ~project~ today, and placing it in ~dir~. +What's going to be the name of your site argument datatype? This name must +start with a capital letter. + +Site argument: diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg new file mode 100644 index 00000000..3c7530a5 --- /dev/null +++ b/scaffold/sitearg_hs.cg @@ -0,0 +1,143 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module ~sitearg~ + ( ~sitearg~ (..) + , ~sitearg~Route (..) + , resources~sitearg~ + , Handler + , maybeAuth + , requireAuth + , module Yesod + , module Settings + , module Model + , StaticRoute (..) + , AuthRoute (..) + ) where + +import Yesod +import Yesod.Mail +import Yesod.Helpers.Static +import Yesod.Helpers.Auth +import qualified Settings +import System.Directory +import qualified Data.ByteString.Lazy as L +import Yesod.WebRoutes +import Database.Persist.GenericSql +import Settings (hamletFile, cassiusFile, juliusFile) +import Model +import Control.Monad (join) +import Data.Maybe (isJust) + +data ~sitearg~ = ~sitearg~ + { getStatic :: Static + , connPool :: Settings.ConnectionPool + } + +type Handler = GHandler ~sitearg~ ~sitearg~ + +mkYesodData "~sitearg~" [$parseRoutes| +/static StaticR Static getStatic +/auth AuthR Auth getAuth + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET +|~~] + +instance Yesod ~sitearg~ where + approot _ = Settings.approot + defaultLayout widget = do + mmsg <- getMessage + pc <- widgetToPageContent $ do + widget + addStyle $(Settings.cassiusFile "default-layout") + hamletToRepHtml $(Settings.hamletFile "default-layout") + urlRenderOverride a (StaticR s) = + Just $ uncurry (joinPath a Settings.staticroot) $ format s + where + format = formatPathSegments ss + ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) + ss = getSubSite + urlRenderOverride _ _ = Nothing + authRoute _ = Just $ AuthR LoginR + addStaticContent ext' _ content = do + let fn = base64md5 content ++ '.' : ext' + let statictmp = Settings.staticdir ++ "/tmp/" + liftIO $ createDirectoryIfMissing True statictmp + liftIO $ L.writeFile (statictmp ++ fn) content + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) + +instance YesodPersist ~sitearg~ where + type YesodDB ~sitearg~ = SqlPersist + runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db + +instance YesodAuth ~sitearg~ where + type AuthEntity ~sitearg~ = User + type AuthEmailEntity ~sitearg~ = Email + + defaultDest _ = RootR + + getAuthId creds _extra = runDB $ do + x <- getBy $ UniqueUser $ credsIdent creds + case x of + Just (uid, _) -> return $ Just uid + Nothing -> do + fmap Just $ insert $ User (credsIdent creds) Nothing + + openIdEnabled _ = True + + emailSettings _ = Just EmailSettings + { addUnverified = \email verkey -> + runDB $ insert $ Email email Nothing (Just verkey) + , sendVerifyEmail = sendVerifyEmail' + , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get + , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key] + , verifyAccount = \eid -> runDB $ do + me <- get eid + case me of + Nothing -> return Nothing + Just e -> do + let email = emailEmail e + case emailUser e of + Just uid -> return $ Just uid + Nothing -> do + uid <- insert $ User email Nothing + update eid [EmailUser $ Just uid] + return $ Just uid + , getPassword = runDB . fmap (join . fmap userPassword) . get + , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass] + , getEmailCreds = \email -> runDB $ do + me <- getBy $ UniqueEmail email + case me of + Nothing -> return Nothing + Just (eid, e) -> return $ Just EmailCreds + { emailCredsId = eid + , emailCredsAuthId = emailUser e + , emailCredsStatus = isJust $ emailUser e + , emailCredsVerkey = emailVerkey e + } + , getEmail = runDB . fmap (fmap emailEmail) . get + } + +sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () +sendVerifyEmail' email _ verurl = + liftIO $ renderSendMail Mail + { mailHeaders = + [ ("From", "noreply") + , ("To", email) + , ("Subject", "Verify your email address") + ] + , mailPlain = verurl + , mailParts = return Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partDisposition = Inline + , partContent = renderHamlet id [$hamlet| +%p Please confirm your email address by clicking on the link below. +%p + %a!href=$verurl$ $verurl$ +%p Thank you +|~~] + } + } + diff --git a/scaffold/welcome.cg b/scaffold/welcome.cg new file mode 100644 index 00000000..ac3742a7 --- /dev/null +++ b/scaffold/welcome.cg @@ -0,0 +1,6 @@ +Welcome to the Yesod scaffolder. +I'm going to be creating a skeleton Yesod project for you. + +What is your name? We're going to put this in the cabal and LICENSE files. + +Your name: diff --git a/yesod.cabal b/yesod.cabal index cc909a60..8d194cb7 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -14,7 +14,7 @@ stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://docs.yesodweb.com/yesod/ -extra-source-files: favicon.ico +extra-source-files: scaffold/*.cg flag buildtests description: Build the executable to run unit tests @@ -79,7 +79,7 @@ executable yesod build-depends: parsec >= 2.1 && < 4 ghc-options: -Wall main-is: scaffold.hs - other-modules: CodeGenQ + other-modules: CodeGen extensions: TemplateHaskell executable runtests From d741e335c48390a6fe4975b3c195482eb867af84 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Sep 2010 09:57:21 +0200 Subject: [PATCH 446/624] Added devel-server executable to scaffolded site --- scaffold.hs | 1 + scaffold/cabal.cg | 7 +++++++ scaffold/devel-server_hs.cg | 23 +++++++++++++++++++++++ yesod.cabal | 2 +- 4 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 scaffold/devel-server_hs.cg diff --git a/scaffold.hs b/scaffold.hs index 8b72e5e6..6bd636a6 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -49,6 +49,7 @@ main = do writeFile' "simple-server.hs" $(codegen "simple-server_hs") writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") + writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs") diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index b9d0d890..452ae3db 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -32,6 +32,13 @@ executable simple-server ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies +executable devel-server + if flag(production) + Buildable: False + main-is: devel-server.hs + build-depends: wai-handler-devel >= 0.1.0 && < 0.2 + ghc-options: -Wall -O2 + executable fastcgi if flag(production) Buildable: True diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg new file mode 100644 index 00000000..0d118d7a --- /dev/null +++ b/scaffold/devel-server_hs.cg @@ -0,0 +1,23 @@ +import Network.Wai.Handler.DevelServer (run) +import Control.Concurrent (forkIO) + +main :: IO () +main = do + mapM_ putStrLn + [ "Starting your server process. Code changes will be automatically" + , "loaded as you save your files. Type \"quit\" to exit." + , "You can view your app at http://localhost:3000/" + , "" + ] + _ <- forkIO () run 3000 "Controller" "with~sitearg~" + [ "hamlet" + , "cassius" + , "julius" + ] + go + where + go = do + x <- getLine + case x of + 'q':_ -> putStrLn "Quitting, goodbye!" + _ -> go diff --git a/yesod.cabal b/yesod.cabal index 8d194cb7..d93d159c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.0.4 +version: 0.5.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 7547aaa8fdb5630de762ee7236d83741e70b6d28 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Sep 2010 10:44:42 +0200 Subject: [PATCH 447/624] Commented the scaffolded site --- scaffold.hs | 5 ++ scaffold/Controller_hs.cg | 10 ++++ scaffold/LICENSE.cg | 2 +- scaffold/Model_hs.cg | 5 +- scaffold/Root_hs.cg | 7 +++ scaffold/Settings_hs.cg | 102 ++++++++++++++++++++++++++++-------- scaffold/cabal.cg | 5 +- scaffold/devel-server_hs.cg | 3 +- scaffold/sitearg_hs.cg | 45 ++++++++++++++-- 9 files changed, 153 insertions(+), 31 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index 6bd636a6..a1d68b6a 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -4,6 +4,8 @@ import System.IO import System.Directory import qualified Data.ByteString.Char8 as S import Language.Haskell.TH.Syntax +import Data.Time (getCurrentTime, utctDay, toGregorian) +import Control.Applicative ((<$>)) main :: IO () main = do @@ -37,6 +39,9 @@ main = do putStrLn "That's it! I'm creating your files now..." + let fst3 (x, _, _) = x + year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime + let writeFile' fp s = do putStrLn $ "Generating " ++ fp writeFile (dir ++ '/' : fp) s diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index b0ef7f7d..35ff7506 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -10,16 +10,26 @@ import Yesod.Helpers.Static import Yesod.Helpers.Auth import Database.Persist.GenericSql +-- Import all relevant handler modules here. import Handler.Root +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in ~sitearg~.hs. Please see +-- the comments there for more details. mkYesodDispatch "~sitearg~" resources~sitearg~ +-- Some default handlers that ship with the Yesod site template. You will +-- very rarely need to modify this. getFaviconR :: Handler () getFaviconR = sendFile "image/x-icon" "favicon.ico" getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent "User-agent: *" +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. with~sitearg~ :: (Application -> IO a) -> IO a with~sitearg~ f = Settings.withConnectionPool $ \p -> do flip runConnectionPool p $ runMigration $ do diff --git a/scaffold/LICENSE.cg b/scaffold/LICENSE.cg index 049c97b2..7830a89e 100644 --- a/scaffold/LICENSE.cg +++ b/scaffold/LICENSE.cg @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2010, ~name~. All rights reserved. +Copyright ~year~, ~name~. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index e7c25078..3602e7ce 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -3,6 +3,9 @@ module Model where import Yesod +-- You can define all of your database entities here. You can find more +-- information on persistent and how to declare entities at: +-- http://docs.yesodweb.com/book/persistent/ mkPersist [$persist| User ident String @@ -13,5 +16,5 @@ Email user UserId null update verkey String null update UniqueEmail email -|~~] +|] diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index 88b16022..d442d350 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -3,6 +3,13 @@ module Handler.Root where import ~sitearg~ +-- This is a handler function for the GET request method on the RootR +-- resource pattern. All of your resource patterns are defined in +-- ~sitearg~.hs; look for the line beginning with mkYesodData. +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. getRootR :: Handler RepHtml getRootR = do mu <- maybeAuth diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 24aab568..64cce2cf 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -1,4 +1,9 @@ {-# LANGUAGE CPP #-} +-- | Settings are centralized, as much as possible, into this file. This +-- includes database connection settings, static file locations, etc. +-- In addition, you can configure a number of different aspects of Yesod +-- by overriding methods in the Yesod typeclass. That instance is +-- declared in the ~sitearg~.hs file. module Settings ( hamletFile , cassiusFile @@ -19,6 +24,76 @@ import Language.Haskell.TH.Syntax import Database.Persist.~upper~ import Yesod (MonadCatchIO) +-- | The base URL for your application. This will usually be different for +-- development and production. Yesod automatically constructs URLs for you, +-- so this value must be accurate to create valid links. +approot :: String +#ifdef PRODUCTION +-- You probably want to change this. If your domain name was "yesod.com", +-- you would probably want it to be: +-- > approot = "http://www.yesod.com" +-- Please note that there is no trailing slash. +approot = "http://localhost:3000" +#else +approot = "http://localhost:3000" +#endif + +-- | The location of static files on your system. This is a file system +-- path. The default value works properly with your scaffolded site. +staticdir :: FilePath +staticdir = "static" + +-- | The base URL for your static files. As you can see by the default +-- value, this can simply be "static" appended to your application root. +-- A powerful optimization can be serving static files from a separate +-- domain name. This allows you to use a web server optimized for static +-- files, more easily set expires and cache values, and avoid possibly +-- costly transference of cookies on static files. For more information, +-- please see: +-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain +-- +-- If you change the resource pattern for StaticR in ~sitearg~.hs, you will +-- have to make a corresponding change here. +-- +-- To see how this value is used, see urlRenderOverride in ~sitearg~.hs +staticroot :: String +staticroot = approot ++ "/static" + +-- | The database connection string. The meaning of this string is backend- +-- specific. +connStr :: String +#ifdef PRODUCTION +connStr = "~connstr2~" +#else +connStr = "~connstr1~" +#endif + +-- | Your application will keep a connection pool and take connections from +-- there as necessary instead of continually creating new connections. This +-- value gives the maximum number of connections to be open at a given time. +-- If your application requests a connection when all connections are in +-- use, that request will fail. Try to choose a number that will work well +-- with the system resources available to you while providing enough +-- connections for your expected load. +-- +-- Also, connections are returned to the pool as quickly as possible by +-- Yesod to avoid resource exhaustion. A connection is only considered in +-- use while within a call to runDB. +connectionCount :: Int +connectionCount = 10 + +-- The rest of this file contains settings which rarely need changing by a +-- user. + +-- The following three functions are used for calling HTML, CSS and +-- Javascript templates from your Haskell code. During development, +-- the "Debug" versions of these functions are used so that changes to +-- the templates are immediately reflected in an already running +-- application. When making a production compile, the non-debug version +-- is used for increased performance. +-- +-- You can see an example of how to call these functions in Handler/Root.hs + hamletFile :: FilePath -> Q Exp #ifdef PRODUCTION hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" @@ -40,32 +115,13 @@ juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" #endif -connStr :: String -#ifdef PRODUCTION -connStr = "~connstr2~" -#else -connStr = "~connstr1~" -#endif - -connectionCount :: Int -connectionCount = 10 - +-- The next two functions are for allocating a connection pool and running +-- database actions using a pool, respectively. It is used internally +-- by the scaffolded application, and therefore you will rarely need to use +-- them yourself. withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool -approot :: String -#ifdef PRODUCTION -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif - -staticroot :: String -staticroot = approot ++ "/static" - -staticdir :: FilePath -staticdir = "static" - diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 452ae3db..b9ee9e41 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -10,7 +10,7 @@ category: Web stability: Experimental cabal-version: >= 1.6 build-type: Simple -homepage: http://www.yesodweb.com/~project~ +homepage: http://~project~.yesodweb.com/ Flag production Description: Build the production executable. @@ -35,8 +35,9 @@ executable simple-server executable devel-server if flag(production) Buildable: False + else + build-depends: wai-handler-devel >= 0.1.0 && < 0.2 main-is: devel-server.hs - build-depends: wai-handler-devel >= 0.1.0 && < 0.2 ghc-options: -Wall -O2 executable fastcgi diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg index 0d118d7a..8c32765b 100644 --- a/scaffold/devel-server_hs.cg +++ b/scaffold/devel-server_hs.cg @@ -9,7 +9,7 @@ main = do , "You can view your app at http://localhost:3000/" , "" ] - _ <- forkIO () run 3000 "Controller" "with~sitearg~" + _ <- forkIO $ run 3000 "Controller" "with~sitearg~" [ "hamlet" , "cassius" , "julius" @@ -21,3 +21,4 @@ main = do case x of 'q':_ -> putStrLn "Quitting, goodbye!" _ -> go + diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 3c7530a5..3dbecd70 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -27,13 +27,38 @@ import Model import Control.Monad (join) import Data.Maybe (isJust) +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. data ~sitearg~ = ~sitearg~ - { getStatic :: Static - , connPool :: Settings.ConnectionPool + { getStatic :: Static -- ^ Settings for static file serving. + , connPool :: Settings.ConnectionPool -- ^ Database connection pool. } +-- | A useful synonym; most of the handler functions in your application +-- will need to be of this type. type Handler = GHandler ~sitearg~ ~sitearg~ +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://docs.yesodweb.com/book/web-routes-quasi/ +-- +-- This function does three things: +-- +-- * Creates the route datatype ~sitearg~Route. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route ~sitearg~ = ~sitearg~Route +-- * Creates the value resources~sitearg~ which contains information on the +-- resources declared below. This is used in Controller.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- ~sitearg~. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the ~sitearg~Route datatype. Therefore, we +-- split these actions into two functions and place them in separate files. mkYesodData "~sitearg~" [$parseRoutes| /static StaticR Static getStatic /auth AuthR Auth getAuth @@ -42,16 +67,22 @@ mkYesodData "~sitearg~" [$parseRoutes| /robots.txt RobotsR GET / RootR GET -|~~] +|] +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. instance Yesod ~sitearg~ where approot _ = Settings.approot + defaultLayout widget = do mmsg <- getMessage pc <- widgetToPageContent $ do widget addStyle $(Settings.cassiusFile "default-layout") hamletToRepHtml $(Settings.hamletFile "default-layout") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = Just $ uncurry (joinPath a Settings.staticroot) $ format s where @@ -59,7 +90,14 @@ instance Yesod ~sitearg~ where ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) ss = getSubSite urlRenderOverride _ _ = Nothing + + -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. addStaticContent ext' _ content = do let fn = base64md5 content ++ '.' : ext' let statictmp = Settings.staticdir ++ "/tmp/" @@ -67,6 +105,7 @@ instance Yesod ~sitearg~ where liftIO $ L.writeFile (statictmp ++ fn) content return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) +-- How to run database actions. instance YesodPersist ~sitearg~ where type YesodDB ~sitearg~ = SqlPersist runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db From 60fab19ef6086d196c35bb4d0ee296ae8f328285 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 24 Sep 2010 05:10:57 +0200 Subject: [PATCH 448/624] Using web-routes again (version 0.23) --- Yesod/WebRoutes.hs | 84 ++-------------------------------------------- yesod.cabal | 5 +-- 2 files changed, 5 insertions(+), 84 deletions(-) diff --git a/Yesod/WebRoutes.hs b/Yesod/WebRoutes.hs index 07d08288..dcf7855e 100644 --- a/Yesod/WebRoutes.hs +++ b/Yesod/WebRoutes.hs @@ -4,85 +4,5 @@ module Yesod.WebRoutes , Site (..) ) where -import Codec.Binary.UTF8.String (encodeString) -import Data.List (intercalate) -import Network.URI - -encodePathInfo :: [String] -> [(String, String)] -> String -encodePathInfo pieces qs = - let x = map encodeString `o` -- utf-8 encode the data characters in path components (we have not added any delimiters yet) - map (escapeURIString (\c -> isUnreserved c || c `elem` ":@&=+$,")) `o` -- percent encode the characters - map (\str -> case str of "." -> "%2E" ; ".." -> "%2E%2E" ; _ -> str) `o` -- encode . and .. - intercalate "/" -- add in the delimiters - y = showParams qs - in x pieces ++ y - where - -- reverse composition - o :: (a -> b) -> (b -> c) -> a -> c - o = flip (.) - -{-| - -A site groups together the three functions necesary to make an application: - -* A function to convert from the URL type to path segments. - -* A function to convert from path segments to the URL, if possible. - -* A function to return the application for a given URL. - -There are two type parameters for Site: the first is the URL datatype, the -second is the application datatype. The application datatype will depend upon -your server backend. --} -data Site url a - = Site { - {-| - Return the appropriate application for a given URL. - - The first argument is a function which will give an appropriate - URL (as a String) for a URL datatype. This is usually - constructed by a combination of 'formatPathSegments' and the - prepending of an absolute application root. - - Well behaving applications should use this function to - generating all internal URLs. - -} - handleSite :: (url -> [(String, String)] -> String) -> url -> a - -- | This function must be the inverse of 'parsePathSegments'. - , formatPathSegments :: url -> ([String], [(String, String)]) - -- | This function must be the inverse of 'formatPathSegments'. - , parsePathSegments :: [String] -> Either String url - } - -showParams :: [(String, String)] -> String -showParams [] = "" -showParams z = - '?' : intercalate "&" (map go z) - where - go (x, "") = go' x - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar - --- | Taken straight from web-encodings; reimplemented here to avoid extra --- dependencies. -encodeUrlChar :: Char -> String -encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] -encodeUrlChar c@'-' = [c] -encodeUrlChar c@'_' = [c] -encodeUrlChar c@'.' = [c] -encodeUrlChar c@'~' = [c] -encodeUrlChar ' ' = "+" -encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] +import Web.Routes.Base (encodePathInfo) +import Web.Routes.Site (Site (..)) diff --git a/yesod.cabal b/yesod.cabal index d93d159c..6c90ffc7 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -13,7 +13,7 @@ category: Web stability: Stable cabal-version: >= 1.6 build-type: Simple -homepage: http://docs.yesodweb.com/yesod/ +homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg flag buildtests @@ -48,7 +48,8 @@ library data-object >= 0.3.1 && < 0.4, network >= 2.2.1.5 && < 2.3, email-validate >= 0.2.5 && < 0.3, - process >= 1.0.1 && < 1.1 + process >= 1.0.1 && < 1.1, + web-routes >= 0.23 && < 0.24 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 00a01936d4b7586dac324d119ee99105e4190ee2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 26 Sep 2010 12:32:18 +0200 Subject: [PATCH 449/624] hamlet 0.5.1 --- Yesod/Widget.hs | 14 ++++++++++++++ yesod.cabal | 2 +- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 13101494..efbeacfa 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Widget @@ -61,6 +62,19 @@ instance Monoid (GWidget sub master ()) where -- | A 'GWidget' specialized to when the subsite and master site are the same. type Widget y = GWidget y y +instance HamletValue (GWidget s m ()) where + newtype HamletMonad (GWidget s m ()) a = + GWidget' { runGWidget' :: GWidget s m a } + type HamletUrl (GWidget s m ()) = Route m + toHamletValue = runGWidget' + htmlToHamletMonad = GWidget' . addBody . const + urlToHamletMonad url params = GWidget' $ + addBody $ \r -> preEscapedString (r url params) + fromHamletValue = GWidget' +instance Monad (HamletMonad (GWidget s m ())) where + return = GWidget' . return + x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y + -- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' -- monad. liftHandler :: GHandler sub master a -> GWidget sub master a diff --git a/yesod.cabal b/yesod.cabal index 6c90ffc7..21f38577 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,7 +32,7 @@ library utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, web-routes-quasi >= 0.6 && < 0.7, - hamlet >= 0.5.0 && < 0.6, + hamlet >= 0.5.1 && < 0.6, blaze-builder >= 0.1 && < 0.2, transformers >= 0.2 && < 0.3, clientsession >= 0.4.0 && < 0.5, From 9101220549b7feac9a0dc6cc40a4a526485dda58 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 28 Sep 2010 07:00:24 +0200 Subject: [PATCH 450/624] GHC 7 --- yesod.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 21f38577..a644cadd 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -27,10 +27,10 @@ library wai-extra >= 0.2.2 && < 0.3, authenticate >= 0.6.3 && < 0.7, bytestring >= 0.9.1.4 && < 0.10, - directory >= 1 && < 1.1, - text >= 0.5 && < 0.9, + directory >= 1 && < 1.2, + text >= 0.5 && < 0.10, utf8-string >= 0.3.4 && < 0.4, - template-haskell >= 2.4 && < 2.5, + template-haskell >= 2.4 && < 2.6, web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.1 && < 0.6, blaze-builder >= 0.1 && < 0.2, From 49a2bcea57c68cda9dda0c9fb575cae2342baad3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 28 Sep 2010 09:20:55 +0200 Subject: [PATCH 451/624] Prettier dep list --- yesod.cabal | 58 ++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index a644cadd..d54f8188 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -21,35 +21,35 @@ flag buildtests default: False library - build-depends: base >= 4 && < 5, - time >= 1.1.4 && < 1.3, - wai >= 0.2.0 && < 0.3, - wai-extra >= 0.2.2 && < 0.3, - authenticate >= 0.6.3 && < 0.7, - bytestring >= 0.9.1.4 && < 0.10, - directory >= 1 && < 1.2, - text >= 0.5 && < 0.10, - utf8-string >= 0.3.4 && < 0.4, - template-haskell >= 2.4 && < 2.6, - web-routes-quasi >= 0.6 && < 0.7, - hamlet >= 0.5.1 && < 0.6, - blaze-builder >= 0.1 && < 0.2, - transformers >= 0.2 && < 0.3, - clientsession >= 0.4.0 && < 0.5, - pureMD5 >= 1.1.0.0 && < 1.2, - random >= 1.0.0.2 && < 1.1, - control-monad-attempt >= 0.3 && < 0.4, - cereal >= 0.2 && < 0.3, - dataenc >= 0.13.0.2 && < 0.14, - old-locale >= 1.0.0.2 && < 1.1, - persistent >= 0.2.0 && < 0.3, - neither >= 0.0.0 && < 0.1, - MonadCatchIO-transformers >= 0.2.2.0 && < 0.3, - data-object >= 0.3.1 && < 0.4, - network >= 2.2.1.5 && < 2.3, - email-validate >= 0.2.5 && < 0.3, - process >= 1.0.1 && < 1.1, - web-routes >= 0.23 && < 0.24 + build-depends: base >= 4 && < 5 + , time >= 1.1.4 && < 1.3 + , wai >= 0.2.0 && < 0.3 + , wai-extra >= 0.2.2 && < 0.3 + , authenticate >= 0.6.3 && < 0.7 + , bytestring >= 0.9.1.4 && < 0.10 + , directory >= 1 && < 1.2 + , text >= 0.5 && < 0.10 + , utf8-string >= 0.3.4 && < 0.4 + , template-haskell >= 2.4 && < 2.6 + , web-routes-quasi >= 0.6 && < 0.7 + , hamlet >= 0.5.1 && < 0.6 + , blaze-builder >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.3 + , clientsession >= 0.4.0 && < 0.5 + , pureMD5 >= 1.1.0.0 && < 1.2 + , random >= 1.0.0.2 && < 1.1 + , control-monad-attempt >= 0.3 && < 0.4 + , cereal >= 0.2 && < 0.3 + , dataenc >= 0.13.0.2 && < 0.14 + , old-locale >= 1.0.0.2 && < 1.1 + , persistent >= 0.2.0 && < 0.3 + , neither >= 0.0.0 && < 0.1 + , MonadCatchIO-transformers >= 0.2.2.0 && < 0.3 + , data-object >= 0.3.1 && < 0.4 + , network >= 2.2.1.5 && < 2.3 + , email-validate >= 0.2.5 && < 0.3 + , process >= 1.0.1 && < 1.1 + , web-routes >= 0.23 && < 0.24 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 7064e8bdccb42eb2a1973b6c4803339087d868b1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 28 Sep 2010 10:03:49 +0200 Subject: [PATCH 452/624] Sanitizing HTML input --- Yesod/Form/Nic.hs | 3 ++- Yesod/Form/Profiles.hs | 3 ++- yesod.cabal | 5 +++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 0e450046..fa83ffdd 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -10,6 +10,7 @@ import Yesod.Form.Core import Yesod.Hamlet import Yesod.Widget import qualified Data.ByteString.Lazy.UTF8 as U +import Text.HTML.SanitizeXSS (sanitizeXSS) class YesodNic a where -- | NIC Editor. @@ -24,7 +25,7 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString + { fpParse = Right . preEscapedString . sanitizeXSS , fpRender = U.toString . renderHtml , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 521a7cd1..2a65d900 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -27,6 +27,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField) +import Text.HTML.SanitizeXSS (sanitizeXSS) import Text.Blaze.Builder.Utf8 (writeChar) import Text.Blaze.Builder.Core (writeList, writeByteString) @@ -77,7 +78,7 @@ timeFieldProfile = FieldProfile htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString + { fpParse = Right . preEscapedString . sanitizeXSS , fpRender = U.toString . renderHtml , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea.html#$theId$!name=$name$ $val$ diff --git a/yesod.cabal b/yesod.cabal index d54f8188..17e8a091 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -25,7 +25,7 @@ library , time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.2 && < 0.3 - , authenticate >= 0.6.3 && < 0.7 + , authenticate >= 0.6.3.2 && < 0.7 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.10 @@ -42,7 +42,7 @@ library , cereal >= 0.2 && < 0.3 , dataenc >= 0.13.0.2 && < 0.14 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.2.0 && < 0.3 + , persistent >= 0.2.2 && < 0.3 , neither >= 0.0.0 && < 0.1 , MonadCatchIO-transformers >= 0.2.2.0 && < 0.3 , data-object >= 0.3.1 && < 0.4 @@ -50,6 +50,7 @@ library , email-validate >= 0.2.5 && < 0.3 , process >= 1.0.1 && < 1.1 , web-routes >= 0.23 && < 0.24 + , xss-sanitize >= 0.1.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 2a04410571fd85e3253a2bc0056a28a6b0a72c68 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Sep 2010 16:05:27 +0200 Subject: [PATCH 453/624] Include message in default site template --- Yesod/Helpers/Auth.hs | 2 +- Yesod/Yesod.hs | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index aa9ea994..da4bb32e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -571,7 +571,7 @@ $maybe fb f %p %a!href=$f$ Login via Facebook $maybe rpxnowSettings.y r - %h3 OpenID + %h3 Rpxnow %p %a!onclick="return false;"!href="https://$rpxnowApp.r$.rpxnow.com/openid/v2/signin?token_url=@tm.RpxnowR@" Login via Rpxnow diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index f87ab328..ffcebc88 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -112,6 +112,7 @@ class Eq (Route a) => Yesod a where defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml defaultLayout w = do p <- widgetToPageContent w + mmsg <- getMessage hamletToRepHtml [$hamlet| !!! %html @@ -119,6 +120,8 @@ class Eq (Route a) => Yesod a where %title $pageTitle.p$ ^pageHead.p^ %body + $maybe mmsg msg + %p.message $msg$ ^pageBody.p^ |] From 9954d60f8e61ea41c8fe3a8fb581d613d6e5851e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 3 Oct 2010 20:47:23 +0200 Subject: [PATCH 454/624] xss-sanitize 0.2 --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 17e8a091..5c7b15a5 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -50,7 +50,7 @@ library , email-validate >= 0.2.5 && < 0.3 , process >= 1.0.1 && < 1.1 , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.1.1 && < 0.2 + , xss-sanitize >= 0.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 7e95ce974dc54cba6d5c949290d3a38ea9cabe44 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 7 Oct 2010 09:22:29 +0200 Subject: [PATCH 455/624] Added redirectToPost --- Yesod/Yesod.hs | 20 ++++++++++++++++++++ yesod.cabal | 2 +- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index ffcebc88..4e44d1bc 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -22,6 +22,7 @@ module Yesod.Yesod , maybeAuthorized , widgetToPageContent , defaultLayoutJson + , redirectToPost -- * Defaults , defaultErrorHandler -- * Data types @@ -418,3 +419,22 @@ caseUtf8JoinPath :: Assertion caseUtf8JoinPath = do "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] #endif + +-- | Redirect to a POST resource. +-- +-- This is not technically a redirect; instead, it returns an HTML page with a +-- POST form, and some Javascript to automatically submit the form. This can be +-- useful when you need to post a plain link somewhere that needs to cause +-- changes on the server. +redirectToPost :: Route master -> GHandler sub master a +redirectToPost dest = hamletToRepHtml [$hamlet| +!!! +%html + %head + %title Redirecting... + %body!onload="document.getElementById('form').submit()" + %form#form!method=post!action=@dest@ + %noscript + %p Javascript has been disabled; please click on the button below to be redirected. + %input!type=submit!value=Continue +|] >>= sendResponse diff --git a/yesod.cabal b/yesod.cabal index 5c7b15a5..b4038e2d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.1 +version: 0.5.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 7377919f6c6c6548f57e119da1b8794f9e671c40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 7 Oct 2010 23:34:02 +0200 Subject: [PATCH 456/624] checkField --- Yesod/Form/Core.hs | 23 ++++++++++++++++++++++- yesod.cabal | 2 +- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 46c81f0d..4661947f 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -190,7 +190,7 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do , fiName = name , fiInput = mkWidget theId name val False , fiErrors = case res of - FormFailure [x] -> Just $ string x + FormFailure x -> Just $ string $ unlines x _ -> Nothing } return (res, [fi], UrlEncoded) @@ -241,6 +241,7 @@ type FormField sub y = GForm sub y [FieldInfo sub y] type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] +-- | FIXME Add some docs, especially about how failures from this function don't show up in the HTML. checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b checkForm f (GForm form) = GForm $ do (res, xml, enc) <- form @@ -250,6 +251,26 @@ checkForm f (GForm form) = GForm $ do FormMissing -> FormMissing return (res', xml, enc) +checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b +checkField f (GForm form) = GForm $ do + (res, xml, enc) <- form + let (res', merr) = + case res of + FormSuccess a -> + case f a of + Left e -> (FormFailure [e], Just e) + Right x -> (FormSuccess x, Nothing) + let xml' = + case merr of + Nothing -> xml + Just err -> flip map xml $ \fi -> fi + { fiErrors = Just $ + case fiErrors fi of + Nothing -> string err + Just x -> x + } + return (res', xml', enc) + askParams :: Monad m => StateT Ints (ReaderT Env m) Env askParams = lift ask diff --git a/yesod.cabal b/yesod.cabal index b4038e2d..4129ff7c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -25,7 +25,7 @@ library , time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.2 && < 0.3 - , authenticate >= 0.6.3.2 && < 0.7 + , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.10 From 0c611f58fdb1b066ef2d6e573e56cd0f8acad8d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Oct 2010 10:28:00 +0200 Subject: [PATCH 457/624] Some FIXMEs --- Yesod/Form/Core.hs | 12 +++++++++++- Yesod/Form/Profiles.hs | 5 ----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 4661947f..8a2e9553 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -14,6 +14,7 @@ module Yesod.Form.Core , fieldsToInput , mapFormXml , checkForm + , checkField , askParams , askFiles , liftForm @@ -241,7 +242,10 @@ type FormField sub y = GForm sub y [FieldInfo sub y] type FormletField sub y a = Maybe a -> FormField sub y a type FormInput sub y = GForm sub y [GWidget sub y ()] --- | FIXME Add some docs, especially about how failures from this function don't show up in the HTML. +-- | Add a validation check to a form. +-- +-- Note that if there is a validation error, this message will /not/ +-- automatically appear on the form; for that, you need to use 'checkField'. checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b checkForm f (GForm form) = GForm $ do (res, xml, enc) <- form @@ -251,6 +255,10 @@ checkForm f (GForm form) = GForm $ do FormMissing -> FormMissing return (res', xml, enc) +-- | Add a validation check to a 'FormField'. +-- +-- Unlike 'checkForm', the validation error will appear in the generated HTML +-- of the form. checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b checkField f (GForm form) = GForm $ do (res, xml, enc) <- form @@ -260,6 +268,8 @@ checkField f (GForm form) = GForm $ do case f a of Left e -> (FormFailure [e], Just e) Right x -> (FormSuccess x, Nothing) + FormFailure e -> (FormFailure e, Nothing) + FormMissing -> (FormMissing, Nothing) let xml' = case merr of Nothing -> xml diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 2a65d900..eef0f833 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -12,7 +12,6 @@ module Yesod.Form.Profiles , emailFieldProfile , urlFieldProfile , doubleFieldProfile - , fileFieldProfile , parseDate , parseTime , Textarea (..) @@ -20,7 +19,6 @@ module Yesod.Form.Profiles import Yesod.Form.Core import Yesod.Widget -import Yesod.Request import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) import qualified Data.ByteString.Lazy.UTF8 as U @@ -55,9 +53,6 @@ doubleFieldProfile = FieldProfile |] } -fileFieldProfile :: FieldProfile s m FileInfo -fileFieldProfile = undefined -- FIXME - dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate From 4451378c5d10e8e3cd102693754a395f81f64c0c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Oct 2010 13:05:06 +0200 Subject: [PATCH 458/624] maybeIntInput --- Yesod/Form/Fields.hs | 6 ++++++ yesod.cabal | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 611df896..2469b6ed 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -37,6 +37,7 @@ module Yesod.Form.Fields -- ** Optional , maybeStringInput , maybeDayInput + , maybeIntInput ) where import Yesod.Form.Core @@ -59,6 +60,11 @@ intInput n = mapFormXml fieldsToInput $ requiredFieldHelper intFieldProfile (nameSettings n) Nothing +maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i) +maybeIntInput n = + mapFormXml fieldsToInput $ + optionalFieldHelper intFieldProfile (nameSettings n) Nothing + intField :: Integral i => FormFieldSettings -> FormletField sub y i intField = requiredFieldHelper intFieldProfile diff --git a/yesod.cabal b/yesod.cabal index 4129ff7c..659f3c1f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.2 +version: 0.5.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 3052bad1c1c7566892c9a778a9d5d61debd4eff3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 11 Oct 2010 16:53:25 +0200 Subject: [PATCH 459/624] Doubles do not use type=number --- Yesod/Form/Profiles.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index eef0f833..7762ed35 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -49,7 +49,7 @@ doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpWidget = \theId name val isReq -> addBody [$hamlet| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ +%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } From fd53c60fc9dcf7d106797576e0913c38edd13611 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 12 Oct 2010 13:28:06 +0200 Subject: [PATCH 460/624] Removed fiName --- Yesod/Form/Core.hs | 3 --- Yesod/Form/Fields.hs | 3 --- 2 files changed, 6 deletions(-) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 8a2e9553..39f9f97b 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -156,7 +156,6 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do { fiLabel = label , fiTooltip = tooltip , fiIdent = theId - , fiName = name , fiInput = mkWidget theId name val True , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -188,7 +187,6 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do { fiLabel = label , fiTooltip = tooltip , fiIdent = theId - , fiName = name , fiInput = mkWidget theId name val False , fiErrors = case res of FormFailure x -> Just $ string $ unlines x @@ -212,7 +210,6 @@ data FieldInfo sub y = FieldInfo { fiLabel :: Html , fiTooltip :: Html , fiIdent :: String - , fiName :: String , fiInput :: GWidget sub y () , fiErrors :: Maybe Html } diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 2469b6ed..4fd4b3db 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -108,7 +108,6 @@ boolField ffs orig = GForm $ do { fiLabel = label , fiTooltip = tooltip , fiIdent = theId - , fiName = name , fiInput = addBody [$hamlet| %input#$theId$!type=checkbox!name=$name$!:val:checked |] @@ -158,7 +157,6 @@ selectField pairs ffs initial = GForm $ do { fiLabel = label , fiTooltip = tooltip , fiIdent = theId - , fiName = name , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x @@ -201,7 +199,6 @@ maybeSelectField pairs ffs initial' = GForm $ do { fiLabel = label , fiTooltip = tooltip , fiIdent = theId - , fiName = name , fiInput = addBody input , fiErrors = case res of FormFailure [x] -> Just $ string x From fde19d629159e794fcd7d6a4ac1c691306c9181a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 15:26:34 +0200 Subject: [PATCH 461/624] googleHostedJqueryUiCss --- Yesod/Form/Jquery.hs | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 1d190f0c..a0237ad5 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -8,6 +8,7 @@ module Yesod.Form.Jquery , jqueryAutocompleteField , maybeJqueryAutocompleteField , jqueryDayFieldProfile + , googleHostedJqueryUiCss ) where import Yesod.Handler @@ -19,18 +20,26 @@ import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, import Yesod.Hamlet import Data.Char (isSpace) +-- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. +googleHostedJqueryUiCss :: String -> String +googleHostedJqueryUiCss theme = concat + [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" + , theme + , "/jquery-ui.css" + ] + class YesodJquery a where - -- | The jQuery Javascript file. + -- | The jQuery 1.4 Javascript file. urlJqueryJs :: a -> Either (Route a) String - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" + urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js" - -- | The jQuery UI 1.8.1 Javascript file. + -- | The jQuery UI 1.8 Javascript file. urlJqueryUiJs :: a -> Either (Route a) String - urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/jquery-ui.min.js" + urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" - -- | The jQuery UI 1.8.1 CSS file; defaults to cupertino theme. + -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. urlJqueryUiCss :: a -> Either (Route a) String - urlJqueryUiCss _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8.1/themes/cupertino/jquery-ui.css" + urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" -- | jQuery UI time picker add-on. urlJqueryUiDateTimePicker :: a -> Either (Route a) String From d9ebdfca13bfb34abc25249d205cd9146ae52435 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 15:26:48 +0200 Subject: [PATCH 462/624] hellowidget working again --- hellowidget.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/hellowidget.hs b/hellowidget.hs index 6177d172..11bf855f 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -27,8 +27,11 @@ instance Yesod HW where liftIO $ L.writeFile ("static/tmp/" ++ fn) content return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) +type Handler = GHandler HW HW + instance YesodNic HW -instance YesodJquery HW +instance YesodJquery HW where + urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness" wrapper h = [$hamlet| #wrapper ^h^ %footer Brought to you by Yesod Widgets™ @@ -109,7 +112,7 @@ textarea.html main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt -getAutoCompleteR :: Handler HW RepJson +getAutoCompleteR :: Handler RepJson getAutoCompleteR = do term <- runFormGet' $ stringInput "term" jsonToRepJson $ jsonList From 881fab7ff0075966385e3bcaa4994169e57121c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 15:52:52 +0200 Subject: [PATCH 463/624] Cache-Control and Expires header function --- Yesod/Content.hs | 5 +++++ Yesod/Handler.hs | 31 ++++++++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 48ffd145..75e22d0f 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -44,6 +44,7 @@ module Yesod.Content , RepXml (..) -- * Utilities , formatW3 + , formatRFC1123 #if TEST , testSuite #endif @@ -252,3 +253,7 @@ caseTypeByExt = do -- | Format a 'UTCTime' in W3 format; useful for setting cookies. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" + +-- | Format as per RFC 1123. +formatRFC1123 :: UTCTime -> String +formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 5dcbace9..f460f2cd 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -51,6 +51,11 @@ module Yesod.Handler , deleteCookie , setHeader , setLanguage + -- ** Content caching and expiration + , cacheSeconds + , neverExpires + , alreadyExpired + , expiresAt -- * Session , setSession , deleteSession @@ -75,6 +80,7 @@ import Yesod.Content import Yesod.Internal import Data.List (foldl') import Data.Neither +import Data.Time (UTCTime) import Control.Exception hiding (Handler, catch) import qualified Control.Exception as E @@ -383,10 +389,33 @@ deleteCookie = addHeader . DeleteCookie setLanguage :: String -> GHandler sub master () setLanguage = setSession langKey --- | Set an arbitrary header on the client. +-- | Set an arbitrary response header. setHeader :: String -> String -> GHandler sub master () setHeader a = addHeader . Header a +-- | Set the Cache-Control header to indicate this response should be cached +-- for the given number of seconds. +cacheSeconds :: Int -> GHandler s m () +cacheSeconds i = setHeader "Cache-Control" $ concat + [ "max-age=" + , show i + , ", public" + ] + +-- | Set the Expires header to some date in 2037. In other words, this content +-- is never (realistically) expired. +neverExpires :: GHandler s m () +neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" + +-- | Set an Expires header in the past, meaning this content should not be +-- cached. +alreadyExpired :: GHandler s m () +alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" + +-- | Set an Expires header to the given date. +expiresAt :: UTCTime -> GHandler s m () +expiresAt = setHeader "Expires" . formatRFC1123 + -- | Set a variable in the user's session. -- -- The session is handled by the clientsession package: it sets an encrypted From 1708d804eac6da012239cb2393c6859fd642552d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 14 Oct 2010 16:10:11 +0200 Subject: [PATCH 464/624] Added Handler finally test case (fails) --- Yesod.hs | 3 ++- Yesod/Dispatch.hs | 4 +++- Yesod/Handler.hs | 39 +++++++++++++++++++++++++++++++++++++-- Yesod/Json.hs | 2 +- Yesod/Yesod.hs | 8 +++++--- runtests.hs | 2 ++ 6 files changed, 50 insertions(+), 8 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index eabc19ab..f2e6916e 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -22,17 +22,18 @@ import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) import Yesod.Dispatch hiding (testSuite) import Yesod.Yesod hiding (testSuite) +import Yesod.Handler hiding (runHandler, testSuite) #else import Yesod.Content import Yesod.Json import Yesod.Dispatch import Yesod.Yesod +import Yesod.Handler hiding (runHandler) #endif import Yesod.Request import Yesod.Form import Yesod.Widget -import Yesod.Handler hiding (runHandler) import Network.Wai (Application) import Yesod.Hamlet import "transformers" Control.Monad.Trans.Class (lift) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 2ca147b5..70e514f5 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes @@ -25,11 +26,12 @@ module Yesod.Dispatch #if TEST import Yesod.Yesod hiding (testSuite) +import Yesod.Handler hiding (testSuite) #else import Yesod.Yesod +import Yesod.Handler #endif -import Yesod.Handler import Yesod.Request import Yesod.Internal diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index f460f2cd..462f3921 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -72,17 +73,19 @@ module Yesod.Handler , YesodApp (..) , toMasterHandler , localNoCurrent +#if TEST + , testSuite +#endif ) where import Prelude hiding (catch) import Yesod.Request -import Yesod.Content import Yesod.Internal import Data.List (foldl') import Data.Neither import Data.Time (UTCTime) -import Control.Exception hiding (Handler, catch) +import Control.Exception hiding (Handler, catch, finally) import qualified Control.Exception as E import Control.Applicative @@ -100,6 +103,17 @@ import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit hiding (Test) +import Yesod.Content hiding (testSuite) +import "MonadCatchIO-transformers" Control.Monad.CatchIO (finally) +import Data.IORef +#else +import Yesod.Content +#endif + -- | The type-safe URLs associated with a site argument. type family Route a @@ -455,3 +469,24 @@ data RedirectType = RedirectPermanent localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Handler" + [ testCase "finally" caseFinally + ] + +caseFinally :: Assertion +caseFinally = do + i <- newIORef (1 :: Int) + let h = finally (do + liftIO $ writeIORef i 2 + () <- redirectString RedirectTemporary "" + return ()) $ liftIO $ writeIORef i 3 + let y = runHandler h undefined undefined undefined undefined undefined + _ <- unYesodApp y undefined undefined undefined + j <- readIORef i + j @?= 3 + +#endif diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 46b1ba00..fe96cfbd 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -20,7 +20,7 @@ module Yesod.Json import qualified Data.ByteString.Char8 as S import Data.Char (isControl) -import Yesod.Handler +import Yesod.Handler (GHandler) import Numeric (showHex) import Data.Monoid (Monoid (..)) import Text.Blaze.Builder.Core diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 4e44d1bc..4071d345 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -35,15 +35,16 @@ module Yesod.Yesod #if TEST import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) +import Yesod.Handler hiding (testSuite) #else import Yesod.Content import Yesod.Json +import Yesod.Handler #endif import Yesod.Widget import Yesod.Request import Yesod.Hamlet -import Yesod.Handler import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) @@ -261,10 +262,10 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path = BSU.toString $ pathInfo r + let path' = BSU.toString $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found -%p $path$ +%p $path'$ |] where pathInfo = W.pathInfo @@ -398,6 +399,7 @@ data TmpRoute = TmpRoute deriving Eq type instance Route TmpYesod = TmpRoute instance Yesod TmpYesod where approot _ = "" +propJoinSplitPath :: [String] -> Bool propJoinSplitPath ss = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) == Right ss' diff --git a/runtests.hs b/runtests.hs index 7e06ab98..e3fe7bc8 100644 --- a/runtests.hs +++ b/runtests.hs @@ -5,6 +5,7 @@ import qualified Yesod.Json import qualified Yesod.Dispatch import qualified Yesod.Helpers.Static import qualified Yesod.Yesod +import qualified Yesod.Handler main :: IO () main = defaultMain @@ -13,4 +14,5 @@ main = defaultMain , Yesod.Dispatch.testSuite , Yesod.Helpers.Static.testSuite , Yesod.Yesod.testSuite + , Yesod.Handler.testSuite ] From 9158268904081eb4efa6ca3d1c1011a279b1d338 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 14 Oct 2010 16:47:02 +0200 Subject: [PATCH 465/624] finallyHandler --- Yesod/Handler.hs | 10 ++++++++-- yesod.cabal | 2 +- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 462f3921..4d88ef17 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -73,6 +73,7 @@ module Yesod.Handler , YesodApp (..) , toMasterHandler , localNoCurrent + , finallyHandler #if TEST , testSuite #endif @@ -94,6 +95,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) +import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C import System.IO import qualified Network.Wai as W @@ -108,7 +110,6 @@ import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit hiding (Test) import Yesod.Content hiding (testSuite) -import "MonadCatchIO-transformers" Control.Monad.CatchIO (finally) import Data.IORef #else import Yesod.Content @@ -480,7 +481,7 @@ testSuite = testGroup "Yesod.Handler" caseFinally :: Assertion caseFinally = do i <- newIORef (1 :: Int) - let h = finally (do + let h = finallyHandler (do liftIO $ writeIORef i 2 () <- redirectString RedirectTemporary "" return ()) $ liftIO $ writeIORef i 3 @@ -490,3 +491,8 @@ caseFinally = do j @?= 3 #endif + +-- | A version of 'finally' which works correctly with short-circuiting. +finallyHandler :: GHandler s m a -> GHandler s m b -> GHandler s m a +finallyHandler (GHandler (ReaderT thing)) (GHandler (ReaderT after)) = + GHandler $ ReaderT $ \hd -> mapMEitherT (`C.finally` runMEitherT (after hd)) (thing hd) diff --git a/yesod.cabal b/yesod.cabal index 659f3c1f..86038e92 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.3 +version: 0.5.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 98c5adfa1d04bc97ca495f0aa059ac8225f6ccc9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Oct 2010 17:12:46 +0200 Subject: [PATCH 466/624] pureMD5 and cereal version bumps --- yesod.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 86038e92..dfdd0154 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.4 +version: 0.5.4.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -36,10 +36,10 @@ library , blaze-builder >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 - , pureMD5 >= 1.1.0.0 && < 1.2 + , pureMD5 >= 1.1.0.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 , control-monad-attempt >= 0.3 && < 0.4 - , cereal >= 0.2 && < 0.3 + , cereal >= 0.2 && < 0.4 , dataenc >= 0.13.0.2 && < 0.14 , old-locale >= 1.0.0.2 && < 1.1 , persistent >= 0.2.2 && < 0.3 From bd2e033acbf49e6c430e5c65233d0179eda615f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 19 Oct 2010 19:17:55 +0200 Subject: [PATCH 467/624] wai-extra bump --- yesod.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index dfdd0154..395c561f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.4.1 +version: 0.5.4.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -24,7 +24,7 @@ library build-depends: base >= 4 && < 5 , time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 - , wai-extra >= 0.2.2 && < 0.3 + , wai-extra >= 0.2.4 && < 0.3 , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 From 6d326855d92edd6df92acf59718c0ee29e59f04b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 15:17:25 +0200 Subject: [PATCH 468/624] Removed Widget alias, defined by scaffolder now --- Yesod/Widget.hs | 3 --- scaffold/sitearg_hs.cg | 4 ++++ yesod.cabal | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index efbeacfa..6d72f44c 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -8,7 +8,6 @@ module Yesod.Widget ( -- * Datatype GWidget (..) - , Widget , liftHandler -- * Creating , newIdent @@ -59,8 +58,6 @@ newtype GWidget sub master a = GWidget ( instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y --- | A 'GWidget' specialized to when the subsite and master site are the same. -type Widget y = GWidget y y instance HamletValue (GWidget s m ()) where newtype HamletMonad (GWidget s m ()) a = diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 3dbecd70..47cb0dc8 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -40,6 +40,10 @@ data ~sitearg~ = ~sitearg~ -- will need to be of this type. type Handler = GHandler ~sitearg~ ~sitearg~ +-- | A useful synonym; most of the widgets functions in your application +-- will need to be of this type. +type Widget = GWidget ~sitearg~ ~sitearg~ + -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://docs.yesodweb.com/book/web-routes-quasi/ diff --git a/yesod.cabal b/yesod.cabal index 395c561f..3adaabb7 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.5.4.2 +version: 0.6.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From eaffbb93ff040f40834a35c0634401026d18196f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 15:21:43 +0200 Subject: [PATCH 469/624] mkToForm takes undefined instead of lists of EntityDef --- Yesod/Form.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 7001826e..8a4a5a33 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -48,7 +48,7 @@ import Control.Monad ((<=<)) import Control.Monad.Trans.State import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..)) +import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper) import Yesod.Widget import Control.Arrow ((&&&)) @@ -112,9 +112,10 @@ runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f --- | Create 'ToForm' instances for the entities given. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: [EntityDef] -> Q [Dec] -mkToForm = mapM derive +-- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. +mkToForm :: PersistEntity v => v -> Q [Dec] +mkToForm = + fmap return . derive . entityDef where afterPeriod s = case dropWhile (/= '.') s of From 27a63b1b7571908a840f7267b99dcbf7cb65b82b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 13 Oct 2010 18:06:35 +0200 Subject: [PATCH 470/624] JqueryDaySettings --- Yesod/Form/Jquery.hs | 55 ++++++++++++++++++++++++++++++++++++++------ hellowidget.hs | 8 ++++++- yesod.cabal | 1 + 3 files changed, 56 insertions(+), 8 deletions(-) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index a0237ad5..aee21f69 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -9,6 +9,7 @@ module Yesod.Form.Jquery , maybeJqueryAutocompleteField , jqueryDayFieldProfile , googleHostedJqueryUiCss + , JqueryDaySettings (..) ) where import Yesod.Handler @@ -19,6 +20,7 @@ import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, timeToTimeOfDay) import Yesod.Hamlet import Data.Char (isSpace) +import Data.Default -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: String -> String @@ -45,14 +47,21 @@ class YesodJquery a where urlJqueryUiDateTimePicker :: a -> Either (Route a) String urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -jqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y Day -jqueryDayField = requiredFieldHelper jqueryDayFieldProfile +jqueryDayField :: YesodJquery y + => JqueryDaySettings + -> FormFieldSettings + -> FormletField sub y Day +jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile -maybeJqueryDayField :: YesodJquery y => FormFieldSettings -> FormletField sub y (Maybe Day) -maybeJqueryDayField = optionalFieldHelper jqueryDayFieldProfile +maybeJqueryDayField :: YesodJquery y + => JqueryDaySettings + -> FormFieldSettings + -> FormletField sub y (Maybe Day) +maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile -jqueryDayFieldProfile :: YesodJquery y => FieldProfile sub y Day -jqueryDayFieldProfile = FieldProfile +jqueryDayFieldProfile :: YesodJquery y + => JqueryDaySettings -> FieldProfile sub y Day +jqueryDayFieldProfile jds = FieldProfile { fpParse = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right @@ -66,9 +75,26 @@ jqueryDayFieldProfile = FieldProfile addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss addJavascript [$julius| -$(function(){$("#%theId%").datepicker({dateFormat:'yy-mm-dd'})}); +$(function(){$("#%theId%").datepicker({ + dateFormat:'yy-mm-dd', + changeMonth:%jsBool.jdsChangeMonth.jds%, + changeYear:%jsBool.jdsChangeYear.jds%, + numberOfMonths:%mos.jdsNumberOfMonths.jds%, + yearRange:"%jdsYearRange.jds%" +})}); |] } + where + jsBool True = "true" + jsBool False = "false" + mos (Left i) = show i + mos (Right (x, y)) = concat + [ "[" + , show x + , "," + , show y + , "]" + ] ifRight :: Either a b -> (b -> c) -> Either a c ifRight e f = case e of @@ -162,3 +188,18 @@ readMay s = case reads s of -- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) + +data JqueryDaySettings = JqueryDaySettings + { jdsChangeMonth :: Bool + , jdsChangeYear :: Bool + , jdsYearRange :: String + , jdsNumberOfMonths :: Either Int (Int, Int) + } + +instance Default JqueryDaySettings where + def = JqueryDaySettings + { jdsChangeMonth = False + , jdsChangeYear = False + , jdsYearRange = "c-10:c+10" + , jdsNumberOfMonths = Left 1 + } diff --git a/hellowidget.hs b/hellowidget.hs index 11bf855f..c8951dc4 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -10,6 +10,7 @@ import Control.Applicative import qualified Data.ByteString.Lazy as L import System.Directory import Control.Monad.Trans.Class +import Data.Default data HW = HW { hwStatic :: Static } mkYesod "HW" [$parseRoutes| @@ -64,7 +65,12 @@ handleFormR = do <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) - <*> jqueryDayField ("A day field") Nothing + <*> jqueryDayField def + { jdsChangeMonth = True + , jdsChangeYear = True + , jdsYearRange = "1900:c+10" + , jdsNumberOfMonths = Right (2, 3) + } ("A day field") Nothing <*> timeField ("A time field") Nothing <*> jqueryDayTimeField ("A day/time field") Nothing <*> boolField FormFieldSettings diff --git a/yesod.cabal b/yesod.cabal index 3adaabb7..5e479236 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -51,6 +51,7 @@ library , process >= 1.0.1 && < 1.1 , web-routes >= 0.23 && < 0.24 , xss-sanitize >= 0.2 && < 0.3 + , data-default >= 0.2 && < 0.3 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 370dad86df0ddb1922d02510bb056f07d1e3e6c0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 14 Oct 2010 15:53:49 +0200 Subject: [PATCH 471/624] Remove Auth module --- Yesod/Helpers/Auth.hs | 578 ------------------------------------------ yesod.cabal | 2 - 2 files changed, 580 deletions(-) delete mode 100644 Yesod/Helpers/Auth.hs diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs deleted file mode 100644 index da4bb32e..00000000 --- a/Yesod/Helpers/Auth.hs +++ /dev/null @@ -1,578 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE OverloadedStrings #-} ---------------------------------------------------------- --- --- 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 - ( -- * Subsite - Auth (..) - , getAuth - , AuthRoute (..) - -- * Settings - , YesodAuth (..) - , Creds (..) - , EmailCreds (..) - , AuthType (..) - , RpxnowSettings (..) - , EmailSettings (..) - , FacebookSettings (..) - , getFacebookUrl - -- * Functions - , maybeAuth - , maybeAuthId - , requireAuth - , requireAuthId - ) where - -import qualified Web.Authenticate.Rpxnow as Rpxnow -import qualified Web.Authenticate.OpenId as OpenId -import qualified Web.Authenticate.Facebook as Facebook - -import Yesod -import Yesod.Mail (randomString) - -import Data.Maybe -import Data.Int (Int64) -import Control.Monad -import System.Random -import Data.Digest.Pure.MD5 -import Control.Applicative -import Control.Monad.Attempt -import Data.ByteString.Lazy.UTF8 (fromString) -import Data.Object -import Language.Haskell.TH.Syntax - -type AuthId m = Key (AuthEntity m) -type AuthEmailId m = Key (AuthEmailEntity m) - -class ( Yesod master - , PersistEntity (AuthEntity master) - , PersistEntity (AuthEmailEntity master) - ) => YesodAuth master where - type AuthEntity master - type AuthEmailEntity master - - -- | Default destination on successful login or logout, if no other - -- destination exists. - defaultDest :: master -> Route master - - getAuthId :: Creds master -> [(String, String)] - -> GHandler s master (Maybe (AuthId master)) - - -- | Generate a random alphanumeric string. - -- - -- This is used for verify string in email authentication. - randomKey :: master -> IO String - randomKey _ = do - stdgen <- newStdGen - return $ fst $ randomString 10 stdgen - - openIdEnabled :: master -> Bool - openIdEnabled _ = False - - rpxnowSettings :: master -> Maybe RpxnowSettings - rpxnowSettings _ = Nothing - - emailSettings :: master -> Maybe (EmailSettings master) - emailSettings _ = Nothing - - -- | client id, secret and requested permissions - facebookSettings :: master -> Maybe FacebookSettings - facebookSettings _ = Nothing - -data Auth = Auth - -getAuth :: a -> Auth -getAuth = const Auth - --- | Which subsystem authenticated the user. -data AuthType = AuthOpenId | AuthRpxnow | AuthEmail | AuthFacebook - deriving (Show, Read, Eq) - -type Email = String -type VerKey = String -type VerUrl = String -type SaltedPass = String -type VerStatus = Bool - --- | Data stored in a database for each e-mail address. -data EmailCreds m = EmailCreds - { emailCredsId :: AuthEmailId m - , emailCredsAuthId :: Maybe (AuthId m) - , emailCredsStatus :: VerStatus - , emailCredsVerkey :: Maybe VerKey - } - -data RpxnowSettings = RpxnowSettings - { rpxnowApp :: String - , rpxnowKey :: String - } - -data EmailSettings m = EmailSettings - { addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) - , sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () - , getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) - , setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () - , verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) - , getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) - , setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () - , getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) - , getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) - } - -data FacebookSettings = FacebookSettings - { fbAppId :: String - , fbSecret :: String - , fbPerms :: [String] - } - --- | User credentials -data Creds m = Creds - { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'. - , credsAuthType :: AuthType -- ^ How the user was authenticated - , credsEmail :: Maybe String -- ^ Verified e-mail address. - , credsDisplayName :: Maybe String -- ^ Display name. - , credsId :: Maybe (AuthId m) -- ^ Numeric ID, if used. - , credsFacebookToken :: Maybe Facebook.AccessToken - } - -credsKey :: String -credsKey = "_ID" - -setCreds :: YesodAuth master - => Creds master -> [(String, String)] -> GHandler Auth master () -setCreds creds extra = do - maid <- getAuthId creds extra - case maid of - Nothing -> return () - Just aid -> setSession credsKey $ show $ fromPersistKey aid - --- | Retrieves user credentials, if user is authenticated. -maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) -maybeAuthId = do - ms <- lookupSession credsKey - case ms of - Nothing -> return Nothing - Just s -> case reads s of - [] -> return Nothing - (i, _):_ -> return $ Just $ toPersistKey i - -maybeAuth :: ( PersistBackend (YesodDB m (GHandler s m)) - , YesodPersist m - , YesodAuth m - ) => GHandler s m (Maybe (AuthId m, AuthEntity m)) -maybeAuth = do - maid <- maybeAuthId - case maid of - Nothing -> return Nothing - Just aid -> do - ma <- runDB $ get aid - case ma of - Nothing -> return Nothing - Just a -> return $ Just (aid, a) - -mkYesodSub "Auth" - [ ClassP ''YesodAuth [VarT $ mkName "master"] - ] - [$parseRoutes| -/check CheckR GET -/logout LogoutR GET -/openid/forward OpenIdForwardR GET -/openid/complete OpenIdCompleteR GET -/login/rpxnow RpxnowR - -/facebook FacebookR GET - -/register EmailRegisterR GET POST -/verify/#Int64/#String EmailVerifyR GET -/email-login EmailLoginR POST -/set-password EmailPasswordR GET POST - -/login LoginR GET -|] - -testOpenId :: YesodAuth master => GHandler Auth master () -testOpenId = do - a <- getYesod - unless (openIdEnabled a) notFound - -getOpenIdForwardR :: YesodAuth master => GHandler Auth master () -getOpenIdForwardR = do - testOpenId - oid <- runFormGet' $ stringInput "openid" - render <- getUrlRender - toMaster <- getRouteToMaster - let complete = render $ toMaster OpenIdCompleteR - res <- runAttemptT $ OpenId.getForwardUrl oid complete - attempt - (\err -> do - setMessage $ string $ show err - redirect RedirectTemporary $ toMaster LoginR) - (redirectString RedirectTemporary) - res - -getOpenIdCompleteR :: YesodAuth master => GHandler Auth master () -getOpenIdCompleteR = do - testOpenId - rr <- getRequest - let gets' = reqGetParams rr - res <- runAttemptT $ OpenId.authenticate gets' - toMaster <- getRouteToMaster - let onFailure err = do - setMessage $ string $ show err - redirect RedirectTemporary $ toMaster LoginR - let onSuccess (OpenId.Identifier ident) = do - y <- getYesod - setCreds (Creds ident AuthOpenId Nothing Nothing Nothing Nothing) [] - redirectUltDest RedirectTemporary $ defaultDest y - attempt onFailure onSuccess res - -handleRpxnowR :: YesodAuth master => GHandler Auth master () -handleRpxnowR = do - ay <- getYesod - auth <- getYesod - apiKey <- case rpxnowKey <$> rpxnowSettings auth of - Just x -> return x - Nothing -> notFound - token1 <- lookupGetParam "token" - token2 <- lookupPostParam "token" - let token = case token1 `mplus` token2 of - Nothing -> invalidArgs ["token: Value not supplied"] - Just x -> x - Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token - let creds = Creds - ident - AuthRpxnow - (lookup "verifiedEmail" extra) - (getDisplayName extra) - Nothing - Nothing - setCreds creds extra - dest1 <- lookupPostParam "dest" - dest2 <- lookupGetParam "dest" - either (redirect RedirectTemporary) (redirectString RedirectTemporary) $ - case dest1 `mplus` dest2 of - Just "" -> Left $ defaultDest ay - Nothing -> Left $ defaultDest ay - Just ('#':d) -> Right d - Just d -> Right d - --- | Get some form of a display name. -getDisplayName :: [(String, String)] -> Maybe String -getDisplayName extra = - foldr (\x -> mplus (lookup x extra)) Nothing choices - where - choices = ["verifiedEmail", "email", "displayName", "preferredUsername"] - -getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson -getCheckR = do - creds <- maybeAuthId - defaultLayoutJson (do - setTitle "Authentication Status" - addBody $ html creds) (json creds) - where - html creds = [$hamlet| -%h1 Authentication Status -$if isNothing.creds - %p Not logged in. -$maybe creds _ - %p Logged in. -|] - json creds = - jsonMap - [ ("logged_in", jsonScalar $ maybe "false" (const "true") creds) - ] - -getLogoutR :: YesodAuth master => GHandler Auth master () -getLogoutR = do - y <- getYesod - deleteSession credsKey - redirectUltDest RedirectTemporary $ defaultDest y - --- | Retrieve user credentials. If user is not logged in, redirects to the --- 'authRoute'. Sets ultimate destination to current route, so user --- should be sent back here after authenticating. -requireAuthId :: YesodAuth m => GHandler sub m (AuthId m) -requireAuthId = maybeAuthId >>= maybe redirectLogin return - -requireAuth :: ( PersistBackend (YesodDB m (GHandler s m)) - , YesodPersist m - , YesodAuth m - ) => GHandler s m (AuthId m, AuthEntity m) -requireAuth = maybeAuth >>= maybe redirectLogin return - -redirectLogin :: Yesod m => GHandler s m a -redirectLogin = do - y <- getYesod - setUltDest' - case authRoute y of - Just z -> redirect RedirectTemporary z - Nothing -> permissionDenied "Please configure authRoute" - -getEmailSettings :: YesodAuth master - => GHandler Auth master (EmailSettings master) -getEmailSettings = getYesod >>= maybe notFound return . emailSettings - -getEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml -getEmailRegisterR = do - _ae <- getEmailSettings - toMaster <- getRouteToMaster - defaultLayout $ setTitle "Register a new account" >> addBody [$hamlet| -%p Enter your e-mail address below, and a confirmation e-mail will be sent to you. -%form!method=post!action=@toMaster.EmailRegisterR@ - %label!for=email E-mail - %input#email!type=email!name=email!width=150 - %input!type=submit!value=Register -|] - -postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml -postEmailRegisterR = do - ae <- getEmailSettings - email <- runFormPost' $ emailInput "email" - mecreds <- getEmailCreds ae email - (lid, verKey) <- - case mecreds of - Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) - Just (EmailCreds lid _ _ Nothing) -> do - y <- getYesod - key <- liftIO $ randomKey y - setVerifyKey ae lid key - return (lid, key) - Nothing -> do - y <- getYesod - key <- liftIO $ randomKey y - lid <- addUnverified ae email key - return (lid, key) - render <- getUrlRender - tm <- getRouteToMaster - let verUrl = render $ tm $ EmailVerifyR (fromPersistKey lid) verKey - sendVerifyEmail ae email verKey verUrl - defaultLayout $ setTitle "Confirmation e-mail sent" >> addBody [$hamlet| -%p A confirmation e-mail has been sent to $email$. -|] - -getEmailVerifyR :: YesodAuth master - => Int64 -> String -> GHandler Auth master RepHtml -getEmailVerifyR lid' key = do - let lid = toPersistKey lid' - ae <- getEmailSettings - realKey <- getVerifyKey ae lid - memail <- getEmail ae lid - case (realKey == Just key, memail) of - (True, Just email) -> do - muid <- verifyAccount ae lid - case muid of - Nothing -> return () - Just uid -> do - setCreds (Creds email AuthEmail (Just email) Nothing (Just uid) - Nothing) [] - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster EmailPasswordR - _ -> return () - defaultLayout $ do - setTitle "Invalid verification key" - addBody [$hamlet| -%p I'm sorry, but that was an invalid verification key. -|] - -postEmailLoginR :: YesodAuth master => GHandler Auth master () -postEmailLoginR = do - ae <- getEmailSettings - (email, pass) <- runFormPost' $ (,) - <$> emailInput "email" - <*> stringInput "password" - y <- getYesod - mecreds <- getEmailCreds ae email - maid <- - case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of - (Just aid, Just True) -> do - mrealpass <- getPassword ae aid - case mrealpass of - Nothing -> return Nothing - Just realpass -> return $ - if isValidPass pass realpass - then Just aid - else Nothing - _ -> return Nothing - case maid of - Just aid -> do - setCreds (Creds email AuthEmail (Just email) Nothing (Just aid) - Nothing) [] - redirectUltDest RedirectTemporary $ defaultDest y - Nothing -> do - setMessage $ string "Invalid email/password combination" - toMaster <- getRouteToMaster - redirect RedirectTemporary $ toMaster LoginR - -getEmailPasswordR :: YesodAuth master => GHandler Auth master RepHtml -getEmailPasswordR = do - _ae <- getEmailSettings - toMaster <- getRouteToMaster - maid <- maybeAuthId - case maid of - Just _ -> return () - Nothing -> do - setMessage $ string "You must be logged in to set a password" - redirect RedirectTemporary $ toMaster EmailLoginR - defaultLayout $ do - setTitle "Set password" - addBody [$hamlet| -%h3 Set a new password -%form!method=post!action=@toMaster.EmailPasswordR@ - %table - %tr - %th New password - %td - %input!type=password!name=new - %tr - %th Confirm - %td - %input!type=password!name=confirm - %tr - %td!colspan=2 - %input!type=submit!value=Submit -|] - -postEmailPasswordR :: YesodAuth master => GHandler Auth master () -postEmailPasswordR = do - ae <- getEmailSettings - (new, confirm) <- runFormPost' $ (,) - <$> stringInput "new" - <*> stringInput "confirm" - toMaster <- getRouteToMaster - when (new /= confirm) $ do - setMessage $ string "Passwords did not match, please try again" - redirect RedirectTemporary $ toMaster EmailPasswordR - maid <- maybeAuthId - aid <- case maid of - Nothing -> do - setMessage $ string "You must be logged in to set a password" - redirect RedirectTemporary $ toMaster EmailLoginR - Just aid -> return aid - salted <- liftIO $ saltPass new - setPassword ae aid salted - setMessage $ string "Password updated" - y <- getYesod - redirect RedirectTemporary $ defaultDest y - -saltLength :: Int -saltLength = 5 - -isValidPass :: String -- ^ cleartext password - -> String -- ^ salted password - -> Bool -isValidPass clear salted = - let salt = take saltLength salted - in salted == saltPass' salt clear - -saltPass :: String -> IO String -saltPass pass = do - stdgen <- newStdGen - let salt = take saltLength $ randomRs ('A', 'Z') stdgen - return $ saltPass' salt pass - -saltPass' :: String -> String -> String -saltPass' salt pass = salt ++ show (md5 $ fromString $ salt ++ pass) - -getFacebookR :: YesodAuth master => GHandler Auth master () -getFacebookR = do - y <- getYesod - a <- facebookSettings <$> getYesod - case a of - Nothing -> notFound - Just (FacebookSettings cid secret _) -> do - render <- getUrlRender - tm <- getRouteToMaster - let fb = Facebook.Facebook cid secret $ render $ tm FacebookR - code <- runFormGet' $ stringInput "code" - at <- liftIO $ Facebook.getAccessToken fb code - so <- liftIO $ Facebook.getGraphData at "me" - let c = fromMaybe (error "Invalid response from Facebook") $ do - m <- fromMapping so - id' <- lookupScalar "id" m - let name = lookupScalar "name" m - let email = lookupScalar "email" m - let id'' = "http://graph.facebook.com/" ++ id' - return $ Creds id'' AuthFacebook email name Nothing $ Just at - setCreds c [] - redirectUltDest RedirectTemporary $ defaultDest y - -getFacebookUrl :: YesodAuth m - => (AuthRoute -> Route m) -> GHandler s m (Maybe String) -getFacebookUrl tm = do - y <- getYesod - render <- getUrlRender - case facebookSettings y of - Nothing -> return Nothing - Just f -> do - let fb = - Facebook.Facebook - (fbAppId f) - (fbSecret f) - (render $ tm FacebookR) - return $ Just $ Facebook.getForwardUrl fb $ fbPerms f - -getLoginR :: YesodAuth master => GHandler Auth master RepHtml -getLoginR = do - lookupGetParam "dest" >>= maybe (return ()) setUltDestString - tm <- getRouteToMaster - y <- getYesod - fb <- getFacebookUrl tm - defaultLayout $ do - setTitle "Login" - addStyle [$cassius| -#openid - background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; - padding-left: 18px; -|] - addBody [$hamlet| -$maybe emailSettings.y _ - %h3 Email - %form!method=post!action=@tm.EmailLoginR@ - %table - %tr - %th E-mail - %td - %input!type=email!name=email - %tr - %th Password - %td - %input!type=password!name=password - %tr - %td!colspan=2 - %input!type=submit!value="Login via email" - %a!href=@tm.EmailRegisterR@ I don't have an account -$if openIdEnabled.y - %h3 OpenID - %form!action=@tm.OpenIdForwardR@ - %label!for=openid OpenID: $ - %input#openid!type=text!name=openid - %input!type=submit!value="Login via OpenID" -$maybe fb f - %h3 Facebook - %p - %a!href=$f$ Login via Facebook -$maybe rpxnowSettings.y r - %h3 Rpxnow - %p - %a!onclick="return false;"!href="https://$rpxnowApp.r$.rpxnow.com/openid/v2/signin?token_url=@tm.RpxnowR@" - Login via Rpxnow -|] diff --git a/yesod.cabal b/yesod.cabal index 5e479236..7955c9d0 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -25,7 +25,6 @@ library , time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.4 && < 0.3 - , authenticate >= 0.7 && < 0.8 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.10 @@ -71,7 +70,6 @@ library Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed - Yesod.Helpers.Auth Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static From 6119f8507e7ba28d0b93ed89abf9ec5036c8f41b Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Thu, 14 Oct 2010 16:54:01 -0700 Subject: [PATCH 472/624] added fiRequired :: Bool to FieldInfo --- Yesod/Form/Core.hs | 3 +++ Yesod/Form/Fields.hs | 3 +++ 2 files changed, 6 insertions(+) diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 39f9f97b..50227baa 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -160,6 +160,7 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing + , fiRequired = True } return (res, [fi], UrlEncoded) @@ -191,6 +192,7 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do , fiErrors = case res of FormFailure x -> Just $ string $ unlines x _ -> Nothing + , fiRequired = False } return (res, [fi], UrlEncoded) @@ -212,6 +214,7 @@ data FieldInfo sub y = FieldInfo , fiIdent :: String , fiInput :: GWidget sub y () , fiErrors :: Maybe Html + , fiRequired :: Bool } data FormFieldSettings = FormFieldSettings diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 4fd4b3db..00efc901 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -114,6 +114,7 @@ boolField ffs orig = GForm $ do , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing + , fiRequired = True } return (res, [fi], UrlEncoded) @@ -161,6 +162,7 @@ selectField pairs ffs initial = GForm $ do , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing + , fiRequired = True } return (res, [fi], UrlEncoded) @@ -203,6 +205,7 @@ maybeSelectField pairs ffs initial' = GForm $ do , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing + , fiRequired = False } return (res, [fi], UrlEncoded) From c242af6d0eb669ece1e08b76a373bebea1a3f822 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Oct 2010 11:31:09 +0200 Subject: [PATCH 473/624] required/optional css class for fieldsToTable --- Yesod/Form.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 8a4a5a33..b6d58dfe 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -65,7 +65,7 @@ fieldsToTable = mapFormXml $ mapM_ go where go fi = do wrapWidget (fiInput fi) $ \w -> [$hamlet| -%tr +%tr.$clazz.fi$ %td %label!for=$fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$ @@ -74,6 +74,7 @@ fieldsToTable = mapFormXml $ mapM_ go $maybe fiErrors.fi err %td.errors $err$ |] + clazz fi = if fiRequired fi then "required" else "optional" runFormGeneric :: Env -> FileEnv From 2f61ef6d39c2025c6fe2fd43535be1cb60f5c51b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Oct 2010 11:34:57 +0200 Subject: [PATCH 474/624] fieldsToDivs --- Yesod/Form.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index b6d58dfe..ae260350 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -24,6 +24,7 @@ module Yesod.Form , runFormPost' -- * Field/form helpers , fieldsToTable + , fieldsToDivs , fieldsToPlain , checkForm -- * Template Haskell @@ -50,7 +51,6 @@ import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper) -import Yesod.Widget import Control.Arrow ((&&&)) import Data.List (group, sort) @@ -63,19 +63,32 @@ fieldsToPlain = mapFormXml $ mapM_ fiInput fieldsToTable :: FormField sub y a -> Form sub y a fieldsToTable = mapFormXml $ mapM_ go where - go fi = do - wrapWidget (fiInput fi) $ \w -> [$hamlet| + go fi = [$hamlet| %tr.$clazz.fi$ %td %label!for=$fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$ %td - ^w^ + ^fiInput.fi^ $maybe fiErrors.fi err %td.errors $err$ |] clazz fi = if fiRequired fi then "required" else "optional" +-- | Display the label, tooltip, input code and errors in a single div. +fieldsToDivs :: FormField sub y a -> Form sub y a +fieldsToDivs = mapFormXml $ mapM_ go + where + go fi = [$hamlet| +.$clazz.fi$ + %label!for=$fiIdent.fi$ $fiLabel.fi$ + .tooltip $fiTooltip.fi$ + ^fiInput.fi^ + $maybe fiErrors.fi err + %div.errors $err$ +|] + clazz fi = if fiRequired fi then "required" else "optional" + runFormGeneric :: Env -> FileEnv -> GForm sub y xml a From ab4c7e3ae280f941ab1dbdef5485af4086cba9cd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Oct 2010 11:50:04 +0200 Subject: [PATCH 475/624] MonadInvertIO --- Yesod.hs | 9 ++++----- Yesod/Handler.hs | 51 +++++++++++++++++++++++------------------------- Yesod/Widget.hs | 22 ++++++++++++++++----- Yesod/Yesod.hs | 2 +- yesod.cabal | 7 +++---- 5 files changed, 49 insertions(+), 42 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index f2e6916e..71d156ea 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} module Yesod ( module Yesod.Request , module Yesod.Content @@ -13,7 +12,7 @@ module Yesod , Application , lift , liftIO - , MonadCatchIO + , MonadInvertIO , mempty ) where @@ -36,7 +35,7 @@ import Yesod.Form import Yesod.Widget import Network.Wai (Application) import Yesod.Hamlet -import "transformers" Control.Monad.Trans.Class (lift) -import "transformers" Control.Monad.IO.Class (liftIO) -import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty) +import Control.Monad.Invert (MonadInvertIO) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 4d88ef17..cf15f133 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -73,7 +73,7 @@ module Yesod.Handler , YesodApp (..) , toMasterHandler , localNoCurrent - , finallyHandler + , HandlerData #if TEST , testSuite #endif @@ -94,17 +94,18 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader -import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) -import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as C import System.IO import qualified Network.Wai as W -import Control.Monad.Attempt +import Control.Failure (Failure (failure)) import Data.ByteString.UTF8 (toString) import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet +import Control.Monad.Invert (MonadInvertIO (..)) +import Control.Monad (liftM) + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.HUnit (testCase) @@ -153,15 +154,28 @@ toMasterHandler tm ts route (GHandler h) = -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling -- special responses. It is declared as a newtype to make compiler errors more -- readable. -newtype GHandler sub master a = GHandler { unGHandler :: - ReaderT (HandlerData sub master) ( +newtype GHandler sub master a = + GHandler + { unGHandler :: GHInner sub master a + } + deriving (Functor, Applicative, Monad, MonadIO) + +type GHInner s m = + ReaderT (HandlerData s m) ( MEitherT HandlerContents ( WriterT (Endo [Header]) ( WriterT (Endo [(String, Maybe String)]) ( IO - )))) a -} - deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) + )))) + +instance MonadInvertIO (GHandler s m) where + newtype InvertedIO (GHandler s m) a = + InvGHandlerIO + { runInvGHandlerIO :: InvertedIO (GHInner s m) a + } + type InvertedArg (GHandler s m) = (HandlerData s m, ()) + invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler + revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f type Endo a = a -> a @@ -475,24 +489,7 @@ localNoCurrent = testSuite :: Test testSuite = testGroup "Yesod.Handler" - [ testCase "finally" caseFinally + [ ] -caseFinally :: Assertion -caseFinally = do - i <- newIORef (1 :: Int) - let h = finallyHandler (do - liftIO $ writeIORef i 2 - () <- redirectString RedirectTemporary "" - return ()) $ liftIO $ writeIORef i 3 - let y = runHandler h undefined undefined undefined undefined undefined - _ <- unYesodApp y undefined undefined undefined - j <- readIORef i - j @?= 3 - #endif - --- | A version of 'finally' which works correctly with short-circuiting. -finallyHandler :: GHandler s m a -> GHandler s m b -> GHandler s m a -finallyHandler (GHandler (ReaderT thing)) (GHandler (ReaderT after)) = - GHandler $ ReaderT $ \hd -> mapMEitherT (`C.finally` runMEitherT (after hd)) (thing hd) diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 6d72f44c..d89b2640 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -33,17 +33,21 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler) +import Yesod.Handler (Route, GHandler, HandlerData) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) -import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO) import Yesod.Internal +import Control.Monad.Invert (MonadInvertIO (..)) +import Control.Monad (liftM) + -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. -newtype GWidget sub master a = GWidget ( +newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } + deriving (Functor, Applicative, Monad, MonadIO) +type GWInner sub master = WriterT (Body (Route master)) ( WriterT (Last Title) ( WriterT (UniqueList (Script (Route master))) ( @@ -53,11 +57,19 @@ newtype GWidget sub master a = GWidget ( WriterT (Head (Route master)) ( StateT Int ( GHandler sub master - )))))))) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) + )))))))) instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y +instance MonadInvertIO (GWidget s m) where + newtype InvertedIO (GWidget s m) a = + InvGWidgetIO + { runInvGWidgetIO :: InvertedIO (GWInner s m) a + } + type InvertedArg (GWidget s m) = + (Int, (HandlerData s m, ())) + invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget + revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f instance HamletValue (GWidget s m ()) where newtype HamletMonad (GWidget s m ()) a = diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 4071d345..5762e6d1 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -52,7 +52,7 @@ import qualified Web.ClientSession as CS import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Monad.Attempt (Failure) +import Control.Failure (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L diff --git a/yesod.cabal b/yesod.cabal index 7955c9d0..71f7e318 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -37,13 +37,11 @@ library , clientsession >= 0.4.0 && < 0.5 , pureMD5 >= 1.1.0.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 - , control-monad-attempt >= 0.3 && < 0.4 , cereal >= 0.2 && < 0.4 , dataenc >= 0.13.0.2 && < 0.14 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.2.2 && < 0.3 - , neither >= 0.0.0 && < 0.1 - , MonadCatchIO-transformers >= 0.2.2.0 && < 0.3 + , persistent >= 0.3.0 && < 0.4 + , neither >= 0.1.0 && < 0.2 , data-object >= 0.3.1 && < 0.4 , network >= 2.2.1.5 && < 2.3 , email-validate >= 0.2.5 && < 0.3 @@ -51,6 +49,7 @@ library , web-routes >= 0.23 && < 0.24 , xss-sanitize >= 0.2 && < 0.3 , data-default >= 0.2 && < 0.3 + , failure >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From ba720b687c0c3c1599f58489147ddf22da66b09e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Oct 2010 11:51:20 +0200 Subject: [PATCH 476/624] buildtests -> test --- yesod.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 71f7e318..79c10539 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,7 +16,7 @@ build-type: Simple homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg -flag buildtests +flag test description: Build the executable to run unit tests default: False @@ -83,7 +83,7 @@ executable yesod extensions: TemplateHaskell executable runtests - if flag(buildtests) + if flag(test) Buildable: True cpp-options: -DTEST build-depends: test-framework, From b930bcbf6230aaf5272acfabbb6743012023b916 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Oct 2010 12:32:14 +0200 Subject: [PATCH 477/624] Removed Yesod.Mail --- Yesod/Mail.hs | 120 -------------------------------------------------- yesod.cabal | 2 - 2 files changed, 122 deletions(-) delete mode 100644 Yesod/Mail.hs diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs deleted file mode 100644 index 256b43b5..00000000 --- a/Yesod/Mail.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Mail - ( Boundary (..) - , Mail (..) - , Part (..) - , Encoding (..) - , renderMail - , renderMail' - , sendmail - , Disposition (..) - , renderSendMail - , randomString - ) where - -import qualified Data.ByteString.Lazy as L -import Text.Blaze.Builder.Utf8 -import Text.Blaze.Builder.Core -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import Codec.Binary.Base64 (encode) -import Control.Monad ((<=<)) - -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -newtype Boundary = Boundary { unBoundary :: String } -instance Random Boundary where - randomR = const random - random = first Boundary . randomString 10 - -data Mail = Mail - { mailHeaders :: [(String, String)] - , mailPlain :: String - , mailParts :: [Part] - } - -data Encoding = None | Base64 - -data Part = Part - { partType :: String -- ^ content type - , partEncoding :: Encoding - , partDisposition :: Disposition - , partContent :: L.ByteString - } - -data Disposition = Inline | Attachment String - -renderMail :: Boundary -> Mail -> L.ByteString -renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat - [ mconcat $ map showHeader headers - , mconcat $ map showHeader - [ ("MIME-Version", "1.0") - , ("Content-Type", "multipart/mixed; boundary=\"" - ++ b ++ "\"") - ] - , fromByteString "\n" - , fromString plain - , mconcat $ map showPart parts - , fromByteString "\n--" - , fromString b - , fromByteString "--" - ] - where - showHeader (k, v) = mconcat - [ fromString k - , fromByteString ": " - , fromString v - , fromByteString "\n" - ] - showPart (Part contentType encoding disposition content) = mconcat - [ fromByteString "\n--" - , fromString b - , fromByteString "\n" - , showHeader ("Content-Type", contentType) - , case encoding of - None -> mempty - Base64 -> showHeader ("Content-Transfer-Encoding", "base64") - , case disposition of - Inline -> mempty - Attachment filename -> - showHeader ("Content-Disposition", "attachment; filename=" ++ filename) - , fromByteString "\n" - , case encoding of - None -> writeList writeByteString $ L.toChunks content - Base64 -> writeList writeByte $ map (toEnum . fromEnum) $ encode $ L.unpack content - ] - -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - b <- randomIO - return $ renderMail b m - -sendmail :: L.ByteString -> IO () -sendmail lbs = do - (Just hin, _, _, phandle) <- createProcess $ (proc - "/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe } - L.hPut hin lbs - hClose hin - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> return () - _ -> error $ "sendmail exited with error code " ++ show exitCode - -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' diff --git a/yesod.cabal b/yesod.cabal index 79c10539..0f6f3228 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -45,7 +45,6 @@ library , data-object >= 0.3.1 && < 0.4 , network >= 2.2.1.5 && < 2.3 , email-validate >= 0.2.5 && < 0.3 - , process >= 1.0.1 && < 1.1 , web-routes >= 0.23 && < 0.24 , xss-sanitize >= 0.2 && < 0.3 , data-default >= 0.2 && < 0.3 @@ -64,7 +63,6 @@ library Yesod.Handler Yesod.Internal Yesod.Json - Yesod.Mail Yesod.Request Yesod.Widget Yesod.Yesod From c29f5af95cf53edf3a2bdd4df9580c18b0d7dc3b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Oct 2010 23:19:35 +0200 Subject: [PATCH 478/624] Support for free-forms This adds a whole bunch of polymorphism to the forms library, and opens up a monad approach which exposes the FieldInfos generated. This allows you to layout your form however you want without mucking around with guessing the location of the fieldinfos in a list. --- Yesod/Form.hs | 30 +++++++----- Yesod/Form/Core.hs | 114 +++++++++++++++++++++++++++++++++++-------- Yesod/Form/Fields.hs | 92 +++++++++++++++++++++------------- freeform.hs | 40 +++++++++++++++ 4 files changed, 211 insertions(+), 65 deletions(-) create mode 100644 freeform.hs diff --git a/Yesod/Form.hs b/Yesod/Form.hs index ae260350..4f85368e 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -11,6 +11,7 @@ module Yesod.Form , Enctype (..) , FormFieldSettings (..) , Textarea (..) + , FieldInfo (..) -- * Type synonyms , Form , Formlet @@ -19,7 +20,9 @@ module Yesod.Form , FormInput -- * Unwrapping functions , runFormGet + , runFormMonadGet , runFormPost + , runFormMonadPost , runFormGet' , runFormPost' -- * Field/form helpers @@ -46,8 +49,6 @@ import Control.Applicative hiding (optional) import Data.Maybe (fromMaybe, mapMaybe) import "transformers" Control.Monad.IO.Class import Control.Monad ((<=<)) -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader import Language.Haskell.TH.Syntax import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) import Data.Char (toUpper, isUpper) @@ -89,17 +90,16 @@ fieldsToDivs = mapFormXml $ mapM_ go |] clazz fi = if fiRequired fi then "required" else "optional" -runFormGeneric :: Env - -> FileEnv - -> GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) -runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe +-- | Run a form against POST parameters. +runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +runFormPost f = do + rr <- getRequest + (pp, files) <- liftIO $ reqRequestBody rr + runFormGeneric pp files f -- | Run a form against POST parameters. -runFormPost :: GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) -runFormPost f = do +runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) +runFormMonadPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr runFormGeneric pp files f @@ -120,12 +120,16 @@ helper (FormFailure e, _, _) = invalidArgs e helper (FormMissing, _, _) = invalidArgs ["No input found"] -- | Run a form against GET parameters. -runFormGet :: GForm sub y xml a - -> GHandler sub y (FormResult a, xml, Enctype) +runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormGet f = do gs <- reqGetParams `fmap` getRequest runFormGeneric gs [] f +runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) +runFormMonadGet f = do + gs <- reqGetParams `fmap` getRequest + runFormGeneric gs [] f + -- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. mkToForm :: PersistEntity v => v -> Q [Dec] mkToForm = diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index 50227baa..cbacbcbf 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -1,4 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Yesod.Form.Core ( FormResult (..) , GForm (..) @@ -18,6 +21,9 @@ module Yesod.Form.Core , askParams , askFiles , liftForm + , IsForm (..) + , RunForm (..) + , GFormMonad -- * Data types , FieldInfo (..) , FormFieldSettings (..) @@ -32,6 +38,7 @@ module Yesod.Form.Core import Control.Monad.Trans.State import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer import Control.Monad.Trans.Class (lift) import Yesod.Handler import Yesod.Widget @@ -90,14 +97,19 @@ incrInts (IntCons i is) = (i + 1) `IntCons` is -- | A generic form, allowing you to specifying the subsite datatype, master -- site datatype, a datatype for the form XML and the return type. -newtype GForm sub y xml a = GForm - { deform :: StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - (GHandler sub y) - ))) (FormResult a, xml, Enctype) +newtype GForm s m xml a = GForm + { deform :: FormInner s m (FormResult a, xml, Enctype) } +type GFormMonad s m a = WriterT Enctype (FormInner s m) a + +type FormInner s m = + StateT Ints ( + ReaderT Env ( + ReaderT FileEnv ( + GHandler s m + ))) + type Env = [(String, String)] type FileEnv = [(String, FileInfo)] @@ -134,10 +146,14 @@ instance Monoid xml => Applicative (GForm sub url xml) where return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) -- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'.ngs -requiredFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> Maybe a -> FormField sub y a -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do +-- 'FieldProfile'. +requiredFieldHelper + :: IsForm f + => FieldProfile (FormSub f) (FormMaster f) (FormType f) + -> FormFieldSettings + -> Maybe (FormType f) + -> f +requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs name <- maybe newFormIdent return name' @@ -153,7 +169,7 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do Left e -> (FormFailure [e], x) Right y -> (FormSuccess y, x) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val True @@ -162,13 +178,70 @@ requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + let res' = case res of + FormFailure [e] -> FormFailure [label ++ ": " ++ e] + _ -> res + return (res', fi, UrlEncoded) + +class IsForm f where + type FormSub f + type FormMaster f + type FormType f + toForm :: FormInner + (FormSub f) + (FormMaster f) + (FormResult (FormType f), + FieldInfo (FormSub f) (FormMaster f), + Enctype) -> f +instance IsForm (FormField s m a) where + type FormSub (FormField s m a) = s + type FormMaster (FormField s m a) = m + type FormType (FormField s m a) = a + toForm x = GForm $ do + (a, b, c) <- x + return (a, [b], c) +instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where + type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s + type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m + type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a + toForm x = do + (res, fi, enctype) <- lift x + tell enctype + return (res, fi) + +class RunForm f where + type RunFormSub f + type RunFormMaster f + type RunFormType f + runFormGeneric :: Env -> FileEnv -> f + -> GHandler (RunFormSub f) + (RunFormMaster f) + (RunFormType f) + +instance RunForm (GForm s m xml a) where + type RunFormSub (GForm s m xml a) = s + type RunFormMaster (GForm s m xml a) = m + type RunFormType (GForm s m xml a) = + (FormResult a, xml, Enctype) + runFormGeneric env fe (GForm f) = + runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe + +instance RunForm (GFormMonad s m a) where + type RunFormSub (GFormMonad s m a) = s + type RunFormMaster (GFormMonad s m a) = m + type RunFormType (GFormMonad s m a) = (a, Enctype) + runFormGeneric e fe f = + runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe -- | Create an optional field (ie, one that can be blank) from a -- 'FieldProfile'. -optionalFieldHelper :: FieldProfile sub y a -> FormFieldSettings - -> FormletField sub y (Maybe a) -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do +optionalFieldHelper + :: (IsForm f, Maybe b ~ FormType f) + => FieldProfile (FormSub f) (FormMaster f) b + -> FormFieldSettings + -> Maybe (Maybe b) + -> f +optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do env <- lift ask let (FormFieldSettings label tooltip theId' name') = ffs let orig = join orig' @@ -185,7 +258,7 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do Left e -> (FormFailure [e], x) Right y -> (FormSuccess $ Just y, x) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = mkWidget theId name val False @@ -194,7 +267,10 @@ optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = GForm $ do _ -> Nothing , fiRequired = False } - return (res, [fi], UrlEncoded) + let res' = case res of + FormFailure [e] -> FormFailure [label ++ ": " ++ e] + _ -> res + return (res', fi, UrlEncoded) fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] fieldsToInput = map fiInput @@ -218,13 +294,13 @@ data FieldInfo sub y = FieldInfo } data FormFieldSettings = FormFieldSettings - { ffsLabel :: Html + { ffsLabel :: String , ffsTooltip :: Html , ffsId :: Maybe String , ffsName :: Maybe String } instance IsString FormFieldSettings where - fromString s = FormFieldSettings (string s) mempty Nothing Nothing + fromString s = FormFieldSettings s mempty Nothing Nothing -- | A generic definition of a form field that can be used for generating both -- required and optional fields. See 'requiredFieldHelper and diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 00efc901..79fb0c65 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,4 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Form.Fields ( -- * Fields -- ** Required @@ -49,10 +51,12 @@ import Data.Monoid import Control.Monad (join) import Data.Maybe (fromMaybe) -stringField :: FormFieldSettings -> FormletField sub y String +stringField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f stringField = requiredFieldHelper stringFieldProfile -maybeStringField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeStringField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeStringField = optionalFieldHelper stringFieldProfile intInput :: Integral i => String -> FormInput sub master i @@ -65,32 +69,41 @@ maybeIntInput n = mapFormXml fieldsToInput $ optionalFieldHelper intFieldProfile (nameSettings n) Nothing -intField :: Integral i => FormFieldSettings -> FormletField sub y i +intField :: (Integral (FormType f), IsForm f) + => FormFieldSettings -> Maybe (FormType f) -> f intField = requiredFieldHelper intFieldProfile -maybeIntField :: Integral i => FormFieldSettings -> FormletField sub y (Maybe i) +maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) + => FormFieldSettings -> Maybe (FormType f) -> f maybeIntField = optionalFieldHelper intFieldProfile -doubleField :: FormFieldSettings -> FormletField sub y Double +doubleField :: (IsForm f, FormType f ~ Double) + => FormFieldSettings -> Maybe Double -> f doubleField = requiredFieldHelper doubleFieldProfile -maybeDoubleField :: FormFieldSettings -> FormletField sub y (Maybe Double) +maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) + => FormFieldSettings -> Maybe (Maybe Double) -> f maybeDoubleField = optionalFieldHelper doubleFieldProfile -dayField :: FormFieldSettings -> FormletField sub y Day +dayField :: (IsForm f, FormType f ~ Day) + => FormFieldSettings -> Maybe Day -> f dayField = requiredFieldHelper dayFieldProfile -maybeDayField :: FormFieldSettings -> FormletField sub y (Maybe Day) +maybeDayField :: (IsForm f, FormType f ~ Maybe Day) + => FormFieldSettings -> Maybe (Maybe Day) -> f maybeDayField = optionalFieldHelper dayFieldProfile -timeField :: FormFieldSettings -> FormletField sub y TimeOfDay +timeField :: (IsForm f, FormType f ~ TimeOfDay) + => FormFieldSettings -> Maybe TimeOfDay -> f timeField = requiredFieldHelper timeFieldProfile -maybeTimeField :: FormFieldSettings -> FormletField sub y (Maybe TimeOfDay) +maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) + => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f maybeTimeField = optionalFieldHelper timeFieldProfile -boolField :: FormFieldSettings -> Maybe Bool -> FormField sub y Bool -boolField ffs orig = GForm $ do +boolField :: (IsForm f, FormType f ~ Bool) + => FormFieldSettings -> Maybe Bool -> f +boolField ffs orig = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -105,7 +118,7 @@ boolField ffs orig = GForm $ do Just "false" -> (FormSuccess False, False) Just _ -> (FormSuccess True, True) let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody [$hamlet| @@ -116,18 +129,22 @@ boolField ffs orig = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) -htmlField :: FormFieldSettings -> FormletField sub y Html +htmlField :: (IsForm f, FormType f ~ Html) + => FormFieldSettings -> Maybe Html -> f htmlField = requiredFieldHelper htmlFieldProfile -maybeHtmlField :: FormFieldSettings -> FormletField sub y (Maybe Html) +maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) + => FormFieldSettings -> Maybe (Maybe Html) -> f maybeHtmlField = optionalFieldHelper htmlFieldProfile -selectField :: Eq x => [(x, String)] +selectField :: (Eq x, IsForm f, FormType f ~ x) + => [(x, String)] -> FormFieldSettings - -> Maybe x -> FormField sub master x -selectField pairs ffs initial = GForm $ do + -> Maybe x + -> f +selectField pairs ffs initial = toForm $ do env <- askParams let label = ffsLabel ffs tooltip = ffsTooltip ffs @@ -155,7 +172,7 @@ selectField pairs ffs initial = GForm $ do %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody input @@ -164,12 +181,14 @@ selectField pairs ffs initial = GForm $ do _ -> Nothing , fiRequired = True } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) -maybeSelectField :: Eq x => [(x, String)] +maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) + => [(x, String)] -> FormFieldSettings - -> FormletField sub master (Maybe x) -maybeSelectField pairs ffs initial' = GForm $ do + -> Maybe (FormType f) + -> f +maybeSelectField pairs ffs initial' = toForm $ do env <- askParams let initial = join initial' label = ffsLabel ffs @@ -198,7 +217,7 @@ maybeSelectField pairs ffs initial' = GForm $ do %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ |] let fi = FieldInfo - { fiLabel = label + { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId , fiInput = addBody input @@ -207,7 +226,7 @@ maybeSelectField pairs ffs initial' = GForm $ do _ -> Nothing , fiRequired = False } - return (res, [fi], UrlEncoded) + return (res, fi, UrlEncoded) stringInput :: String -> FormInput sub master String stringInput n = @@ -245,10 +264,12 @@ maybeDayInput n = nameSettings :: String -> FormFieldSettings nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) -urlField :: FormFieldSettings -> FormletField sub y String +urlField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f urlField = requiredFieldHelper urlFieldProfile -maybeUrlField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeUrlField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeUrlField = optionalFieldHelper urlFieldProfile urlInput :: String -> FormInput sub master String @@ -256,10 +277,12 @@ urlInput n = mapFormXml fieldsToInput $ requiredFieldHelper urlFieldProfile (nameSettings n) Nothing -emailField :: FormFieldSettings -> FormletField sub y String +emailField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f emailField = requiredFieldHelper emailFieldProfile -maybeEmailField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeEmailField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeEmailField = optionalFieldHelper emailFieldProfile emailInput :: String -> FormInput sub master String @@ -267,14 +290,17 @@ emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing -textareaField :: FormFieldSettings -> FormletField sub y Textarea +textareaField :: (IsForm f, FormType f ~ Textarea) + => FormFieldSettings -> Maybe Textarea -> f textareaField = requiredFieldHelper textareaFieldProfile maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) maybeTextareaField = optionalFieldHelper textareaFieldProfile -hiddenField :: FormFieldSettings -> FormletField sub y String +hiddenField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f hiddenField = requiredFieldHelper hiddenFieldProfile -maybeHiddenField :: FormFieldSettings -> FormletField sub y (Maybe String) +maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f maybeHiddenField = optionalFieldHelper hiddenFieldProfile diff --git a/freeform.hs b/freeform.hs new file mode 100644 index 00000000..3f8b263a --- /dev/null +++ b/freeform.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} +import Yesod +import Control.Applicative + +data FreeForm = FreeForm +mkYesod "FreeForm" [$parseRoutes| +/ RootR GET +|] +instance Yesod FreeForm where approot _ = "" + +data Person = Person String Int String + deriving Show + +getRootR = do + ((merr, mperson, form), enctype) <- runFormMonadGet $ do + (name, namef) <- stringField "Name" Nothing + (age, agef) <- intField "Age" $ Just 25 + (color, colorf) <- stringField "Color" Nothing + let (merr, mperson) = + case Person <$> name <*> age <*> color of + FormSuccess p -> (Nothing, Just p) + FormFailure e -> (Just e, Nothing) + FormMissing -> (Nothing, Nothing) + let form = [$hamlet| +Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^. +|] + return (merr, mperson, form) + defaultLayout [$hamlet| +$maybe merr err + %ul!style=color:red + $forall err e + %li $e$ +$maybe mperson person + %p Last person: $show.person$ +%form!method=get!action=@RootR@!enctype=$enctype$ + %p ^form^ + %input!type=submit!value=Submit +|] + +main = basicHandler 3000 FreeForm From 0b4de794e850466bebade84586d2b37643a1f7c2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 19 Oct 2010 13:39:27 +0200 Subject: [PATCH 479/624] Removed utf8-string dep --- CodeGen.hs | 8 +++++--- Yesod/Content.hs | 3 +-- Yesod/Dispatch.hs | 22 ++++++++++------------ Yesod/Form/Nic.hs | 5 +++-- Yesod/Form/Profiles.hs | 5 +++-- Yesod/Handler.hs | 6 ++---- Yesod/Internal.hs | 23 +++++++++++++++++++++++ Yesod/Yesod.hs | 3 +-- scaffold.hs | 5 ++++- yesod.cabal | 1 - 10 files changed, 52 insertions(+), 29 deletions(-) diff --git a/CodeGen.hs b/CodeGen.hs index 75f1e609..632c2a7c 100644 --- a/CodeGen.hs +++ b/CodeGen.hs @@ -5,14 +5,16 @@ module CodeGen (codegen) where import Language.Haskell.TH.Syntax import Text.ParserCombinators.Parsec -import qualified System.IO.UTF8 as U +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT data Token = VarToken String | LitToken String | EmptyToken codegen :: FilePath -> Q Exp codegen fp = do - s' <- qRunIO $ U.readFile $ "scaffold/" ++ fp ++ ".cg" - let s = init s' + s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg" + let s = init $ LT.unpack $ LT.decodeUtf8 s' case parse (many parseToken) s s of Left e -> error $ show e Right tokens' -> do diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 75e22d0f..f8af3092 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -63,7 +63,6 @@ import System.Locale import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding -import qualified Data.ByteString.Lazy.UTF8 #if TEST import Test.Framework (testGroup, Test) @@ -94,7 +93,7 @@ instance ToContent T.Text where instance ToContent Text where toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString + toContent = toContent . T.pack -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 70e514f5..a9105261 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -52,8 +52,6 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.UTF8 as S - import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -268,10 +266,10 @@ toWaiApp' y segments env = do (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName - (S.toString sessionVal) + (bsToChars sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", S.fromString ct) : hs'' + hs''' = ("Content-Type", charsToBs ct) : hs'' return $ W.Response s hs''' c httpAccept :: W.Request -> [ContentType] @@ -313,13 +311,13 @@ parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do - let gets' = map (S.toString *** S.toString) + let gets' = map (bsToChars *** bsToChars) $ parseQueryString $ W.queryString env let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env - cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map S.toString $ maybe [] parseHttpAccept acceptLang + langs = map bsToChars $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs @@ -334,9 +332,9 @@ parseWaiRequest env session' = do rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (S.toString *** S.toString) + fix1 = map (bsToChars *** bsToChars) fix2 (x, NWP.FileInfo a b c) = - (S.toString x, FileInfo (S.toString a) (S.toString b) c) + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) -- | 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 @@ -357,14 +355,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes - in ("Set-Cookie", S.fromString + in ("Set-Cookie", charsToBs $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) = - ("Set-Cookie", S.fromString $ + ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = - (fromString key, S.fromString value) + (fromString key, charsToBs value) encodeSession :: CS.Key -> UTCTime -- ^ expire time diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index fa83ffdd..e8a5bc91 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -9,9 +9,10 @@ import Yesod.Handler import Yesod.Form.Core import Yesod.Hamlet import Yesod.Widget -import qualified Data.ByteString.Lazy.UTF8 as U import Text.HTML.SanitizeXSS (sanitizeXSS) +import Yesod.Internal (lbsToChars) + class YesodNic a where -- | NIC Editor. urlNicEdit :: a -> Either (Route a) String @@ -26,7 +27,7 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS - , fpRender = U.toString . renderHtml + , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 7762ed35..029260bb 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -21,7 +21,6 @@ import Yesod.Form.Core import Yesod.Widget import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) -import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField) @@ -30,6 +29,8 @@ import Text.HTML.SanitizeXSS (sanitizeXSS) import Text.Blaze.Builder.Utf8 (writeChar) import Text.Blaze.Builder.Core (writeList, writeByteString) +import Yesod.Internal (lbsToChars) + intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI @@ -74,7 +75,7 @@ timeFieldProfile = FieldProfile htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS - , fpRender = U.toString . renderHtml + , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea.html#$theId$!name=$name$ $val$ |] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index cf15f133..08fa6341 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -98,8 +98,6 @@ import Control.Monad.Trans.Reader import System.IO import qualified Network.Wai as W import Control.Failure (Failure (failure)) -import Data.ByteString.UTF8 (toString) -import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet @@ -362,7 +360,7 @@ msgKey = "_MSG" -- -- See 'getMessage'. setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . L.toString . renderHtml +setMessage = setSession msgKey . lbsToChars . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. @@ -392,7 +390,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ toString $ W.requestMethod w + failure $ BadMethod $ bsToChars $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index ef66e3f5..97ddbfe3 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -19,12 +19,26 @@ module Yesod.Internal , locationToHamlet , runUniqueList , toUnique + -- * UTF8 helpers + , bsToChars + , lbsToChars + , charsToBs ) where import Text.Hamlet (Hamlet, hamlet, Html) import Data.Monoid (Monoid (..)) import Data.List (nub) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = @@ -71,3 +85,12 @@ newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid + +lbsToChars :: L.ByteString -> String +lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode + +bsToChars :: S.ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode + +charsToBs :: String -> S.ByteString +charsToBs = T.encodeUtf8 . T.pack diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5762e6d1..0170ea95 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -49,7 +49,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Failure (Failure) @@ -262,7 +261,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path' = BSU.toString $ pathInfo r + let path' = bsToChars $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $path'$ diff --git a/scaffold.hs b/scaffold.hs index a1d68b6a..36f6deed 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -6,6 +6,9 @@ import qualified Data.ByteString.Char8 as S import Language.Haskell.TH.Syntax import Data.Time (getCurrentTime, utctDay, toGregorian) import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT main :: IO () main = do @@ -44,7 +47,7 @@ main = do let writeFile' fp s = do putStrLn $ "Generating " ++ fp - writeFile (dir ++ '/' : fp) s + L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp mkDir "Handler" diff --git a/yesod.cabal b/yesod.cabal index 0f6f3228..7dec6e7a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -28,7 +28,6 @@ library , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.10 - , utf8-string >= 0.3.4 && < 0.4 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.6 From 6e43ea5fc362f110232550f9f7cca3c6fe79a4f2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 20 Oct 2010 21:12:29 +0200 Subject: [PATCH 480/624] Document caveat in setSession --- Yesod/Handler.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 08fa6341..3f9146c0 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -448,6 +448,9 @@ expiresAt = setHeader "Expires" . formatRFC1123 -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. +-- +-- Please note that the value you set here will not be available via +-- 'getSession' until the /next/ request. setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () From c35c935418c8d6bf061e24fb0743251a551231b8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 20 Oct 2010 22:41:32 +0200 Subject: [PATCH 481/624] Doc cleanup, especially forms --- Yesod.hs | 1 + Yesod/Form.hs | 4 ++-- Yesod/Form/Core.hs | 2 ++ Yesod/Form/Jquery.hs | 40 +++++++++++++++++++++++++++++----------- Yesod/Form/Nic.hs | 12 +++++++++--- yesod.cabal | 8 ++++---- 6 files changed, 47 insertions(+), 20 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 71d156ea..b1f16f4f 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +-- | This module simply re-exports from other modules for your convenience. module Yesod ( module Yesod.Request , module Yesod.Content diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4f85368e..3c4fe99c 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -30,11 +30,11 @@ module Yesod.Form , fieldsToDivs , fieldsToPlain , checkForm + -- * Type classes + , module Yesod.Form.Class -- * Template Haskell , mkToForm - -- * Re-exports , module Yesod.Form.Fields - , module Yesod.Form.Class ) where import Yesod.Form.Core diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs index cbacbcbf..be5fcbe0 100644 --- a/Yesod/Form/Core.hs +++ b/Yesod/Form/Core.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | Users of the forms library should not need to use this module in general. +-- It is intended only for writing custom forms and form fields. module Yesod.Form.Core ( FormResult (..) , GForm (..) diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index aee21f69..defb1754 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -1,4 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..) , jqueryDayField @@ -47,16 +50,19 @@ class YesodJquery a where urlJqueryUiDateTimePicker :: a -> Either (Route a) String urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -jqueryDayField :: YesodJquery y +jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) => JqueryDaySettings -> FormFieldSettings - -> FormletField sub y Day + -> Maybe (FormType f) + -> f jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile -maybeJqueryDayField :: YesodJquery y - => JqueryDaySettings - -> FormFieldSettings - -> FormletField sub y (Maybe Day) +maybeJqueryDayField + :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) + => JqueryDaySettings + -> FormFieldSettings + -> Maybe (FormType f) + -> f maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile jqueryDayFieldProfile :: YesodJquery y @@ -104,7 +110,11 @@ ifRight e f = case e of showLeadingZero :: (Show a) => a -> String showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t -jqueryDayTimeField :: YesodJquery y => FormFieldSettings -> FormletField sub y UTCTime +jqueryDayTimeField + :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) + => FormFieldSettings + -> Maybe (FormType f) + -> f jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile -- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) @@ -144,12 +154,20 @@ parseUTCTime s = ifRight (parseTime timeS) (UTCTime date . timeOfDayToTime) -jqueryAutocompleteField :: YesodJquery y => - Route y -> FormFieldSettings -> FormletField sub y String +jqueryAutocompleteField + :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f)) + => Route (FormMaster f) + -> FormFieldSettings + -> Maybe (FormType f) + -> f jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile -maybeJqueryAutocompleteField :: YesodJquery y => - Route y -> FormFieldSettings -> FormletField sub y (Maybe String) +maybeJqueryAutocompleteField + :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) + => Route (FormMaster f) + -> FormFieldSettings + -> Maybe (FormType f) + -> f maybeJqueryAutocompleteField src = optionalFieldHelper $ jqueryAutocompleteFieldProfile src diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index e8a5bc91..a3256d45 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -1,4 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Provide the user with a rich text editor. module Yesod.Form.Nic ( YesodNic (..) , nicHtmlField @@ -14,14 +17,17 @@ import Text.HTML.SanitizeXSS (sanitizeXSS) import Yesod.Internal (lbsToChars) class YesodNic a where - -- | NIC Editor. + -- | NIC Editor Javascript file. urlNicEdit :: a -> Either (Route a) String urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y Html +nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) + => FormFieldSettings -> Maybe Html -> f nicHtmlField = requiredFieldHelper nicHtmlFieldProfile -maybeNicHtmlField :: YesodNic y => FormFieldSettings -> FormletField sub y (Maybe Html) +maybeNicHtmlField + :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) + => FormFieldSettings -> Maybe (FormType f) -> f maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html diff --git a/yesod.cabal b/yesod.cabal index 7dec6e7a..02a0e416 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -52,15 +52,11 @@ library Yesod.Content Yesod.Dispatch Yesod.Form - Yesod.Form.Class Yesod.Form.Core - Yesod.Form.Fields - Yesod.Form.Profiles Yesod.Form.Jquery Yesod.Form.Nic Yesod.Hamlet Yesod.Handler - Yesod.Internal Yesod.Json Yesod.Request Yesod.Widget @@ -70,6 +66,10 @@ library Yesod.Helpers.Sitemap Yesod.Helpers.Static Yesod.WebRoutes + other-modules: Yesod.Form.Class + Yesod.Internal + Yesod.Form.Fields + Yesod.Form.Profiles ghc-options: -Wall executable yesod From 07a5350e5bd0b99750706380be212dbc66e0c1ca Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 20 Oct 2010 22:45:35 +0200 Subject: [PATCH 482/624] Removed Yesod.WebRoutes --- Yesod/Dispatch.hs | 2 +- Yesod/Helpers/Static.hs | 2 +- Yesod/WebRoutes.hs | 8 -------- Yesod/Yesod.hs | 2 +- yesod.cabal | 1 - 5 files changed, 3 insertions(+), 12 deletions(-) delete mode 100644 Yesod/WebRoutes.hs diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index a9105261..e9b46d72 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -39,7 +39,6 @@ import Web.Routes.Quasi import Web.Routes.Quasi.Parse import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax -import Yesod.WebRoutes import qualified Network.Wai as W import Network.Wai.Middleware.CleanPath (cleanPathFunc) @@ -68,6 +67,7 @@ import qualified Data.Serialize as Ser import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP import Data.String (fromString) +import Web.Routes #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index c739001f..20bd19db 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -45,13 +45,13 @@ import Data.Maybe (fromMaybe) import Yesod hiding (lift) import Data.List (intercalate) import Language.Haskell.TH.Syntax +import Web.Routes import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 import qualified Codec.Binary.Base64Url import qualified Data.ByteString as S import qualified Data.Serialize -import Yesod.WebRoutes #if TEST import Test.Framework (testGroup, Test) diff --git a/Yesod/WebRoutes.hs b/Yesod/WebRoutes.hs deleted file mode 100644 index dcf7855e..00000000 --- a/Yesod/WebRoutes.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | This module should be removed when web-routes incorporates necessary support. -module Yesod.WebRoutes - ( encodePathInfo - , Site (..) - ) where - -import Web.Routes.Base (encodePathInfo) -import Web.Routes.Site (Site (..)) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 0170ea95..4d848de1 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -55,13 +55,13 @@ import Control.Failure (Failure) import qualified Data.ByteString as S import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L -import Yesod.WebRoutes import Data.Monoid import Control.Monad.Trans.Writer import Control.Monad.Trans.State hiding (get) import Text.Hamlet import Text.Cassius import Text.Julius +import Web.Routes #if TEST import Test.Framework (testGroup, Test) diff --git a/yesod.cabal b/yesod.cabal index 02a0e416..ce225f07 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -65,7 +65,6 @@ library Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - Yesod.WebRoutes other-modules: Yesod.Form.Class Yesod.Internal Yesod.Form.Fields From fd10f42db7c521317df8c92ee6c89ec83764632f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 22 Oct 2010 00:02:49 +0200 Subject: [PATCH 483/624] generateForm --- Yesod/Form.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 3c4fe99c..c34d55e9 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -19,6 +19,7 @@ module Yesod.Form , FormletField , FormInput -- * Unwrapping functions + , generateForm , runFormGet , runFormMonadGet , runFormPost @@ -119,6 +120,12 @@ helper (FormSuccess a, _, _) = return a helper (FormFailure e, _, _) = invalidArgs e helper (FormMissing, _, _) = invalidArgs ["No input found"] +-- | Generate a form, feeding it no data. +generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype) +generateForm f = do + (_, b, c) <- runFormGeneric [] [] f + return (b, c) + -- | Run a form against GET parameters. runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) runFormGet f = do From b5622c4a715a73b5d68d78ac859204905814f8ad Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 22 Oct 2010 13:49:25 +0200 Subject: [PATCH 484/624] text 0.10 --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index ce225f07..3cf19cb4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -27,7 +27,7 @@ library , wai-extra >= 0.2.4 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.10 + , text >= 0.5 && < 0.11 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.6 From 17cb10c31290ebd4677440dd877500976c01fccd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 24 Oct 2010 18:51:32 +0200 Subject: [PATCH 485/624] Major renaming of widget functions --- Yesod/Form/Fields.hs | 11 +++---- Yesod/Form/Jquery.hs | 12 ++++---- Yesod/Form/Nic.hs | 4 +-- Yesod/Form/Profiles.hs | 20 ++++++------- Yesod/Helpers/Crud.hs | 8 ++--- Yesod/Widget.hs | 67 ++++++++++++++++++++++++------------------ Yesod/Yesod.hs | 2 +- 7 files changed, 64 insertions(+), 60 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 79fb0c65..b59898b5 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -44,7 +44,6 @@ module Yesod.Form.Fields import Yesod.Form.Core import Yesod.Form.Profiles -import Yesod.Widget import Data.Time (Day, TimeOfDay) import Text.Hamlet import Data.Monoid @@ -121,7 +120,7 @@ boolField ffs orig = toForm $ do { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId - , fiInput = addBody [$hamlet| + , fiInput = [$hamlet| %input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of @@ -175,7 +174,7 @@ selectField pairs ffs initial = toForm $ do { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId - , fiInput = addBody input + , fiInput = input , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -220,7 +219,7 @@ maybeSelectField pairs ffs initial' = toForm $ do { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId - , fiInput = addBody input + , fiInput = input , fiErrors = case res of FormFailure [x] -> Just $ string x _ -> Nothing @@ -246,9 +245,7 @@ boolInput n = GForm $ do Just "" -> FormSuccess False Just "false" -> FormSuccess False Just _ -> FormSuccess True - let xml = addBody [$hamlet| -%input#$n$!type=checkbox!name=$n$ -|] + let xml = [$hamlet|%input#$n$!type=checkbox!name=$n$|] return (res, [xml], UrlEncoded) dayInput :: String -> FormInput sub master Day diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index defb1754..90bbd7aa 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -74,13 +74,13 @@ jqueryDayFieldProfile jds = FieldProfile . readMay , fpRender = show , fpWidget = \theId name val isReq -> do - addBody [$hamlet| + addHtml [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavascript [$julius| + addJulius [$julius| $(function(){$("#%theId%").datepicker({ dateFormat:'yy-mm-dd', changeMonth:%jsBool.jdsChangeMonth.jds%, @@ -132,14 +132,14 @@ jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do - addBody [$hamlet| + addHtml [$hamlet| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJavascript [$julius| + addJulius [$julius| $(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -176,13 +176,13 @@ jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> do - addBody [$hamlet| + addHtml [$hamlet| %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJavascript [$julius| + addJulius [$julius| $(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index a3256d45..328d36d2 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -35,9 +35,9 @@ nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do - addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] + addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit - addJavascript [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|] + addJulius [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 029260bb..ba9d3eec 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -35,7 +35,7 @@ intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] } @@ -49,7 +49,7 @@ doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -58,7 +58,7 @@ dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] } @@ -67,7 +67,7 @@ timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] } @@ -76,7 +76,7 @@ htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> addBody [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %textarea.html#$theId$!name=$name$ $val$ |] } @@ -102,7 +102,7 @@ textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addBody [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %textarea#$theId$!name=$name$ $val$ |] } @@ -111,7 +111,7 @@ hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpWidget = \theId name val _isReq -> addBody [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %input!type=hidden#$theId$!name=$name$!value=$val$ |] } @@ -120,7 +120,7 @@ stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -169,7 +169,7 @@ emailFieldProfile = FieldProfile then Right s else Left "Invalid e-mail address" , fpRender = id - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] } @@ -180,7 +180,7 @@ urlFieldProfile = FieldProfile Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id - , fpWidget = \theId name val isReq -> addBody [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet [$hamlet| %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] } diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index d08d1231..e04afc32 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -55,7 +55,7 @@ getCrudListR = do toMaster <- getRouteToMaster defaultLayout $ do setTitle "Items" - addBody [$hamlet| + addWidget [$hamlet| %h1 Items %ul $forall items item @@ -115,7 +115,7 @@ getCrudDeleteR s = do toMaster <- getRouteToMaster defaultLayout $ do setTitle "Confirm delete" - addBody [$hamlet| + addWidget [$hamlet| %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$? @@ -156,10 +156,8 @@ crudHelper title me isPost = do $ toSinglePiece eid _ -> return () defaultLayout $ do - wrapWidget form (wrapForm toMaster enctype) setTitle $ string title - where - wrapForm toMaster enctype form = [$hamlet| + addWidget [$hamlet| %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$ diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index d89b2640..b9cbc69f 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -10,21 +10,27 @@ module Yesod.Widget GWidget (..) , liftHandler -- * Creating - , newIdent + -- ** Head of page , setTitle - , addStyle + , addHamletHead + , addHtmlHead + -- ** Body + , addHamlet + , addHtml + , addWidget + -- ** CSS + , addCassius , addStylesheet , addStylesheetRemote , addStylesheetEither + -- ** Javascript + , addJulius , addScript , addScriptRemote , addScriptEither - , addHead - , addBody - , addJavascript - -- * Manipulating - , wrapWidget + -- * Utilities , extractBody + , newIdent ) where import Data.Monoid @@ -76,9 +82,9 @@ instance HamletValue (GWidget s m ()) where GWidget' { runGWidget' :: GWidget s m a } type HamletUrl (GWidget s m ()) = Route m toHamletValue = runGWidget' - htmlToHamletMonad = GWidget' . addBody . const + htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $ - addBody $ \r -> preEscapedString (r url params) + addHamlet $ \r -> preEscapedString (r url params) fromHamletValue = GWidget' instance Monad (HamletMonad (GWidget s m ())) where return = GWidget' . return @@ -94,13 +100,26 @@ liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift setTitle :: Html -> GWidget sub master () setTitle = GWidget . lift . tell . Last . Just . Title --- | Add some raw HTML to the head tag. -addHead :: Hamlet (Route master) -> GWidget sub master () -addHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head +-- | Add a 'Hamlet' to the head tag. +addHamletHead :: Hamlet (Route master) -> GWidget sub master () +addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head --- | Add some raw HTML to the body tag. -addBody :: Hamlet (Route master) -> GWidget sub master () -addBody = GWidget . tell . Body +-- | Add a 'Html' to the head tag. +addHtmlHead :: Html -> GWidget sub master () +addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const + +-- | Add a 'Hamlet' to the body tag. +addHamlet :: Hamlet (Route master) -> GWidget sub master () +addHamlet = GWidget . tell . Body + +-- | Add a 'Html' to the body tag. +addHtml :: Html -> GWidget sub master () +addHtml = GWidget . tell . Body . const + +-- | Add another widget. This is defined as 'id', by can help with types, and +-- makes widget blocks look more consistent. +addWidget :: GWidget s m () -> GWidget s m () +addWidget = id -- | Get a unique identifier. newIdent :: GWidget sub master String @@ -111,8 +130,8 @@ newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do return $ "w" ++ show i' -- | Add some raw CSS to the style tag. -addStyle :: Cassius (Route master) -> GWidget sub master () -addStyle = GWidget . lift . lift . lift . lift . tell . Just +addCassius :: Cassius (Route master) -> GWidget sub master () +addCassius = GWidget . lift . lift . lift . lift . tell . Just -- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master () @@ -139,18 +158,8 @@ addScriptRemote = GWidget . lift . lift . tell . toUnique . Script . Remote -- | Include raw Javascript in the page's script tag. -addJavascript :: Julius (Route master) -> GWidget sub master () -addJavascript = GWidget . lift . lift . lift . lift . lift. tell . Just - --- | Modify the given 'GWidget' by wrapping the body tag HTML code with the --- given function. You might also consider using 'extractBody'. -wrapWidget :: GWidget s m a - -> (Hamlet (Route m) -> Hamlet (Route m)) - -> GWidget s m a -wrapWidget (GWidget w) wrap = - GWidget $ mapWriterT (fmap go) w - where - go (a, Body h) = (a, Body $ wrap h) +addJulius :: Julius (Route master) -> GWidget sub master () +addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just -- | Pull out the HTML tag contents and return it. Useful for performing some -- manipulations. It can be easier to use this sometimes than 'wrapWidget'. diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 4d848de1..c252c297 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -255,7 +255,7 @@ applyLayout' :: Yesod master -> GHandler sub master ChooseRep applyLayout' title body = fmap chooseRep $ defaultLayout $ do setTitle title - addBody body + addHamlet body -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep From 2fef1766f4497f7b623bfb9b38058788ad58576d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 24 Oct 2010 21:33:36 +0200 Subject: [PATCH 486/624] staticFiles ignores tmp --- Yesod/Helpers/Static.hs | 1 + Yesod/Yesod.hs | 1 + test/tmp/ignored | 0 3 files changed, 2 insertions(+) create mode 100644 test/tmp/ignored diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 20bd19db..acd2a70b 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -127,6 +127,7 @@ getStaticRoute fp' = do notHidden :: FilePath -> Bool notHidden ('.':_) = False +notHidden "tmp" = False notHidden _ = True getFileList :: FilePath -> IO [[String]] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c252c297..32b72431 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -36,6 +36,7 @@ module Yesod.Yesod import Yesod.Content hiding (testSuite) import Yesod.Json hiding (testSuite) import Yesod.Handler hiding (testSuite) +import qualified Data.ByteString.UTF8 as BSU #else import Yesod.Content import Yesod.Json diff --git a/test/tmp/ignored b/test/tmp/ignored new file mode 100644 index 00000000..e69de29b From 1a752d4343a74d33ecd22f86141e2be88a7c733e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 24 Oct 2010 22:26:33 +0200 Subject: [PATCH 487/624] Nonce for CSRF protection --- Yesod/Dispatch.hs | 28 ++++++++++++++++++++++++++-- Yesod/Form.hs | 38 +++++++++++++++++++++++++++++++++----- Yesod/Helpers/Crud.hs | 3 ++- Yesod/Request.hs | 2 ++ hellowidget.hs | 7 ++++++- 5 files changed, 69 insertions(+), 9 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index e9b46d72..73aaece9 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -68,6 +68,8 @@ import Network.Wai.Parse hiding (FileInfo) import qualified Network.Wai.Parse as NWP import Data.String (fromString) import Web.Routes +import Control.Arrow (first) +import System.Random (randomR, newStdGen) #if TEST import Test.Framework (testGroup, Test) @@ -264,7 +266,9 @@ toWaiApp' y segments env = do let eh er = runHandler (errorHandler' er) render eurl' id y id let ya = runHandler h render eurl' id y id (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types - let sessionVal = encodeSession key' exp' host sessionFinal + let sessionVal = encodeSession key' exp' host + $ (nonceKey, reqNonce rr) + : sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName (bsToChars sessionVal) : hs @@ -328,7 +332,27 @@ parseWaiRequest env session' = do Nothing -> langs'' Just x -> x : langs'' rbthunk <- iothunk $ rbHelper env - return $ Request gets' cookies' session' rbthunk env langs''' + nonce <- case lookup nonceKey session' of + Just x -> return x + Nothing -> do + g <- newStdGen + return $ fst $ randomString 10 g + return $ Request gets' cookies' session' rbthunk env langs''' nonce + where + randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + +nonceKey :: String +nonceKey = "_NONCE" rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where diff --git a/Yesod/Form.hs b/Yesod/Form.hs index c34d55e9..1a762dce 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -12,6 +12,8 @@ module Yesod.Form , FormFieldSettings (..) , Textarea (..) , FieldInfo (..) + -- ** Utilities + , formFailures -- * Type synonyms , Form , Formlet @@ -92,13 +94,30 @@ fieldsToDivs = mapFormXml $ mapM_ go clazz fi = if fiRequired fi then "required" else "optional" -- | Run a form against POST parameters. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +-- +-- This function includes CSRF protection by checking a nonce value. You must +-- therefore embed this nonce in the form as a hidden field; that is the +-- meaning of the fourth element in the tuple. +runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) runFormPost f = do rr <- getRequest (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f + nonce <- fmap reqNonce getRequest + (res, xml, enctype) <- runFormGeneric pp files f + let res' = + case res of + FormSuccess x -> + if lookup nonceName pp == Just nonce + then FormSuccess x + else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] + _ -> res + return (res', xml, enctype, hidden nonce) + where + nonceName = "_nonce" + hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|] --- | Run a form against POST parameters. +-- | Run a form against POST parameters. Please note that this does not provide +-- CSRF protection. runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) runFormMonadPost f = do rr <- getRequest @@ -106,9 +125,14 @@ runFormMonadPost f = do runFormGeneric pp files f -- | Run a form against POST parameters, disregarding the resulting HTML and --- returning an error response on invalid input. +-- returning an error response on invalid input. Note: this does /not/ perform +-- CSRF protection. runFormPost' :: GForm sub y xml a -> GHandler sub y a -runFormPost' = helper <=< runFormPost +runFormPost' f = do + rr <- getRequest + (pp, files) <- liftIO $ reqRequestBody rr + x <- runFormGeneric pp files f + helper x -- | Run a form against GET parameters, disregarding the resulting HTML and -- returning an error response on invalid input. @@ -225,3 +249,7 @@ toLabel (x:rest) = toUpper x : go rest go (c:cs) | isUpper c = ' ' : c : go cs | otherwise = c : go cs + +formFailures :: FormResult a -> Maybe [String] +formFailures (FormFailure x) = Just x +formFailures _ = Nothing diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index e04afc32..5aebcae9 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -143,7 +143,7 @@ crudHelper -> GHandler (Crud master a) master RepHtml crudHelper title me isPost = do crud <- getYesodSub - (errs, form, enctype) <- runFormPost $ toForm $ fmap snd me + (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me toMaster <- getRouteToMaster case (isPost, errs) of (True, FormSuccess a) -> do @@ -166,6 +166,7 @@ crudHelper title me isPost = do ^form^ %tr %td!colspan=2 + $hidden$ %input!type=submit $maybe me e \ $ diff --git a/Yesod/Request.hs b/Yesod/Request.hs index f89bc67b..f90973c7 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -108,6 +108,8 @@ data Request = Request , reqWaiRequest :: W.Request -- | Languages which the client supports. , reqLangs :: [String] + -- | A random, session-specific nonce used to prevent CSRF attacks. + , reqNonce :: String } lookup' :: Eq a => a -> [(a, b)] -> [b] diff --git a/hellowidget.hs b/hellowidget.hs index c8951dc4..fb408f13 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -61,7 +61,7 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do addHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) + (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -103,7 +103,12 @@ textarea.html height: 150px |] wrapWidget form $ \h -> [$hamlet| +$maybe formFailures.res failures + %ul.errors + $forall failures f + %li $f$ %form!method=post!enctype=$enctype$ + $hidden$ %table ^h^ %tr From 0fc2cccfef9e0365cb7bf6bb29525685b1d0aba6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 24 Oct 2010 22:38:16 +0200 Subject: [PATCH 488/624] generateForm produces nonce hidden field --- Yesod/Form.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 1a762dce..042f4b39 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -113,9 +113,11 @@ runFormPost f = do _ -> res return (res', xml, enctype, hidden nonce) where - nonceName = "_nonce" hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|] +nonceName :: String +nonceName = "_nonce" + -- | Run a form against POST parameters. Please note that this does not provide -- CSRF protection. runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) @@ -144,11 +146,13 @@ helper (FormSuccess a, _, _) = return a helper (FormFailure e, _, _) = invalidArgs e helper (FormMissing, _, _) = invalidArgs ["No input found"] --- | Generate a form, feeding it no data. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype) +-- | Generate a form, feeding it no data. The third element in the result tuple +-- is a nonce hidden field. +generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) generateForm f = do (_, b, c) <- runFormGeneric [] [] f - return (b, c) + nonce <- fmap reqNonce getRequest + return (b, c, [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]) -- | Run a form against GET parameters. runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) From 51943f9a113dc175448acd423ab30c6edb14a65a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 25 Oct 2010 12:04:39 +0200 Subject: [PATCH 489/624] runFormPostNoNonce --- Yesod/Form.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 042f4b39..bf807f29 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -25,6 +25,7 @@ module Yesod.Form , runFormGet , runFormMonadGet , runFormPost + , runFormPostNoNonce , runFormMonadPost , runFormGet' , runFormPost' @@ -93,6 +94,13 @@ fieldsToDivs = mapFormXml $ mapM_ go |] clazz fi = if fiRequired fi then "required" else "optional" +-- | Run a form against POST parameters, without CSRF protection. +runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) +runFormPostNoNonce f = do + rr <- getRequest + (pp, files) <- liftIO $ reqRequestBody rr + runFormGeneric pp files f + -- | Run a form against POST parameters. -- -- This function includes CSRF protection by checking a nonce value. You must From 05b4d3e9ce3cec9eb8595ae6328a79cf36602c80 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 25 Oct 2010 12:49:26 +0200 Subject: [PATCH 490/624] sessionIpAddress --- Yesod/Dispatch.hs | 2 +- Yesod/Yesod.hs | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 73aaece9..5ffe1ab9 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -225,7 +225,7 @@ toWaiApp' y segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y - let host = W.remoteHost env + let host = if sessionIpAddress y then W.remoteHost env else "" let session' = fromMaybe [] $ do raw <- lookup "Cookie" $ W.requestHeaders env val <- lookup (B.pack sessionName) $ parseCookies raw diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 32b72431..121177e7 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -209,6 +209,11 @@ class Eq (Route a) => Yesod a where -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) addStaticContent _ _ _ = return Nothing + -- | Whether or not to tie a session to a specific IP address. Defaults to + -- 'True'. + sessionIpAddress :: a -> Bool + sessionIpAddress _ = True + data AuthResult = Authorized | AuthenticationRequired | Unauthorized String deriving (Eq, Show, Read) From 1069df2665fce6e95c1c11217f4047192e9a8255 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 08:38:45 +0200 Subject: [PATCH 491/624] State for session --- Yesod/Dispatch.hs | 12 ++++++--- Yesod/Handler.hs | 63 ++++++++++++++++++++++------------------------- Yesod/Request.hs | 14 ----------- Yesod/Widget.hs | 3 ++- hellowidget.hs | 27 ++++++++++---------- yesod.cabal | 1 + 6 files changed, 54 insertions(+), 66 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5ffe1ab9..ff79c15b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -71,6 +71,8 @@ import Web.Routes import Control.Arrow (first) import System.Random (randomR, newStdGen) +import qualified Data.Map as Map + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -265,10 +267,12 @@ toWaiApp' y segments env = do let eurl' = either (const Nothing) Just eurl let eh er = runHandler (errorHandler' er) render eurl' id y id let ya = runHandler h render eurl' id y id - (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types + let sessionMap = Map.fromList + $ filter (\(x, _) -> x /= nonceKey) session' + (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap let sessionVal = encodeSession key' exp' host - $ (nonceKey, reqNonce rr) - : sessionFinal + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName (bsToChars sessionVal) : hs @@ -337,7 +341,7 @@ parseWaiRequest env session' = do Nothing -> do g <- newStdGen return $ fst $ randomString 10 g - return $ Request gets' cookies' session' rbthunk env langs''' nonce + return $ Request gets' cookies' rbthunk env langs''' nonce where randomString len = first (map toChar) . sequence' (replicate len (randomR (0, 61))) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 3f9146c0..b0e30e34 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -58,6 +58,7 @@ module Yesod.Handler , alreadyExpired , expiresAt -- * Session + , lookupSession , setSession , deleteSession -- ** Ultimate destination @@ -82,7 +83,6 @@ module Yesod.Handler import Prelude hiding (catch) import Yesod.Request import Yesod.Internal -import Data.List (foldl') import Data.Neither import Data.Time (UTCTime) @@ -94,6 +94,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader +import Control.Monad.Trans.State import System.IO import qualified Network.Wai as W @@ -103,6 +104,7 @@ import Text.Hamlet import Control.Monad.Invert (MonadInvertIO (..)) import Control.Monad (liftM) +import qualified Data.Map as Map #if TEST import Test.Framework (testGroup, Test) @@ -162,16 +164,18 @@ type GHInner s m = ReaderT (HandlerData s m) ( MEitherT HandlerContents ( WriterT (Endo [Header]) ( - WriterT (Endo [(String, Maybe String)]) ( + StateT SessionMap ( -- session IO )))) +type SessionMap = Map.Map String String + instance MonadInvertIO (GHandler s m) where newtype InvertedIO (GHandler s m) a = InvGHandlerIO { runInvGHandlerIO :: InvertedIO (GHInner s m) a } - type InvertedArg (GHandler s m) = (HandlerData s m, ()) + type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ())) invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f @@ -185,7 +189,8 @@ newtype YesodApp = YesodApp :: (ErrorResponse -> YesodApp) -> Request -> [ContentType] - -> IO (W.Status, [Header], ContentType, Content, [(String, String)]) + -> SessionMap + -> IO (W.Status, [Header], ContentType, Content, SessionMap) } data HandlerContents = @@ -227,16 +232,6 @@ getCurrentRoute = handlerRoute <$> GHandler ask getRouteToMaster :: GHandler sub master (Route sub -> Route master) getRouteToMaster = handlerToMaster <$> GHandler ask -modifySession :: [(String, String)] -> (String, Maybe String) - -> [(String, String)] -modifySession orig (k, v) = - case v of - Nothing -> dropKeys k orig - Just v' -> (k, v') : dropKeys k orig - -dropKeys :: String -> [(String, x)] -> [(String, x)] -dropKeys k = filter $ \(x, _) -> x /= k - -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c @@ -247,7 +242,8 @@ runHandler :: HasReps c -> master -> (master -> sub) -> YesodApp -runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do +runHandler handler mrender sroute tomr ma tosa = + YesodApp $ \eh rr cts initSession -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) @@ -259,17 +255,16 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do , handlerRender = mrender , handlerToMaster = tomr } - ((contents', headers), session') <- E.catch ( - runWriterT + ((contents', headers), finalSession) <- E.catch ( + flip runStateT initSession $ runWriterT $ runMEitherT $ flip runReaderT hd $ unGHandler handler - ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id)) + ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) let contents = meither id (HCContent . chooseRep) contents' - let finalSession = foldl' modifySession (reqSession rr) $ session' [] let handleError e = do - (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts + (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = @@ -288,9 +283,10 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do (handleError . toErrorHandler) safeEh :: ErrorResponse -> YesodApp -safeEh er = YesodApp $ \_ _ _ -> do +safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.status500, [], typePlain, toContent "Internal Server Error", []) + return (W.status500, [], typePlain, toContent "Internal Server Error", + session) -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -334,9 +330,9 @@ setUltDest' = do Nothing -> return () Just r -> do tm <- getRouteToMaster - gets <- reqGetParams <$> getRequest + gets' <- reqGetParams <$> getRequest render <- getUrlRenderParams - setUltDestString $ render (tm r) gets + setUltDestString $ render (tm r) gets' -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. @@ -355,9 +351,6 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- --- The message set here will not be visible within the current request; --- instead, it will only appear in the next request. --- -- See 'getMessage'. setMessage :: Html -> GHandler sub master () setMessage = setSession msgKey . lbsToChars . renderHtml @@ -412,7 +405,8 @@ setCookie a b = addHeader . AddCookie a b deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie --- | Set the language in the user session. Will show up in 'languages'. +-- | Set the language in the user session. Will show up in 'languages' on the +-- next request. setLanguage :: String -> GHandler sub master () setLanguage = setSession langKey @@ -448,17 +442,14 @@ expiresAt = setHeader "Expires" . formatRFC1123 -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. --- --- Please note that the value you set here will not be available via --- 'getSession' until the /next/ request. setSession :: String -- ^ key -> String -- ^ value -> GHandler sub master () -setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v) +setSession k = GHandler . lift . lift . lift . modify . Map.insert k -- | Unsets a session variable. See 'setSession'. deleteSession :: String -> GHandler sub master () -deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing) +deleteSession = GHandler . lift . lift . lift . modify . Map.delete -- | Internal use only, not to be confused with 'setHeader'. addHeader :: Header -> GHandler sub master () @@ -486,6 +477,12 @@ localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler +-- | Lookup for session data. +lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) +lookupSession n = GHandler $ do + m <- lift $ lift $ lift get + return $ Map.lookup n m + #if TEST testSuite :: Test diff --git a/Yesod/Request.hs b/Yesod/Request.hs index f90973c7..d526ff65 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -28,13 +28,11 @@ module Yesod.Request , lookupGetParam , lookupPostParam , lookupCookie - , lookupSession , lookupFile -- ** Multi-lookup , lookupGetParams , lookupPostParams , lookupCookies - , lookupSessions , lookupFiles -- * Parameter type synonyms , ParamName @@ -98,8 +96,6 @@ data FileInfo = FileInfo data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - -- | Session data stored in a cookie via the clientsession package. - , reqSession :: [(ParamName, ParamValue)] -- | The POST parameters and submitted files. This is stored in an IO -- thunk, which essentially means it will be computed once at most, but -- only if requested. This allows avoidance of the potentially costly @@ -163,13 +159,3 @@ lookupCookies :: RequestReader m => ParamName -> m [ParamValue] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr - --- | Lookup for session data. -lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupSession = liftM listToMaybe . lookupSessions - --- | Lookup for session data. -lookupSessions :: RequestReader m => ParamName -> m [ParamValue] -lookupSessions pn = do - rr <- getRequest - return $ lookup' pn $ reqSession rr diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index b9cbc69f..037787f5 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -47,6 +47,7 @@ import Yesod.Internal import Control.Monad.Invert (MonadInvertIO (..)) import Control.Monad (liftM) +import qualified Data.Map as Map -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of @@ -73,7 +74,7 @@ instance MonadInvertIO (GWidget s m) where { runInvGWidgetIO :: InvertedIO (GWInner s m) a } type InvertedArg (GWidget s m) = - (Int, (HandlerData s m, ())) + (Int, (HandlerData s m, (Map.Map String String, ()))) invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f diff --git a/hellowidget.hs b/hellowidget.hs index fb408f13..b70e6603 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -37,10 +37,10 @@ wrapper h = [$hamlet| #wrapper ^h^ %footer Brought to you by Yesod Widgets™ |] -getRootR = defaultLayout $ flip wrapWidget wrapper $ do +getRootR = defaultLayout $ wrapper $ do i <- newIdent setTitle $ string "Hello Widgets" - addStyle [$cassius| + addCassius [$cassius| #$i$ color: red |] @@ -48,7 +48,7 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do addStylesheetRemote "http://localhost:3000/static/style2.css" addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" addScript $ StaticR $ StaticRoute ["script.js"] [] - addBody [$hamlet| + addHamlet [$hamlet| %h1#$i$ Welcome to my first widget!!! %p %a!href=@RootR@ Recursive link. @@ -58,10 +58,10 @@ getRootR = defaultLayout $ flip wrapWidget wrapper $ do %a!href=@CustomFormR@ Custom form arrangement. %p.noscript Your script did not load. :( |] - addHead [$hamlet|%meta!keywords=haskell|] + addHtmlHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) + (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -72,7 +72,6 @@ handleFormR = do , jdsNumberOfMonths = Right (2, 3) } ("A day field") Nothing <*> timeField ("A time field") Nothing - <*> jqueryDayTimeField ("A day/time field") Nothing <*> boolField FormFieldSettings { ffsLabel = "A checkbox" , ffsTooltip = "" @@ -86,23 +85,23 @@ handleFormR = do <*> maybeEmailField ("An e-mail addres") Nothing <*> maybeTextareaField "A text area" Nothing let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, _, x, _, _) -> Just x + FormSuccess (_, _, _, _, _, _, _, x, _, _) -> Just x _ -> Nothing let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, _, Just x) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, _, Just x) -> Just x _ -> Nothing defaultLayout $ do - addStyle [$cassius| + addCassius [$cassius| .tooltip color: #666 font-style: italic |] - addStyle [$cassius| + addCassius [$cassius| textarea.html width: 300px height: 150px |] - wrapWidget form $ \h -> [$hamlet| + addWidget [$hamlet| $maybe formFailures.res failures %ul.errors $forall failures f @@ -110,7 +109,7 @@ $maybe formFailures.res failures %form!method=post!enctype=$enctype$ $hidden$ %table - ^h^ + ^form^ %tr %td!colspan=2 %input!type=submit @@ -140,7 +139,7 @@ getCustomFormR = do let b = do b1' <- extractBody b1 b2' <- extractBody b2 - addBody [$hamlet| + addHamlet [$hamlet| %p This is a custom layout. %h1 Name Follows! %p ^b1'^ @@ -150,7 +149,7 @@ getCustomFormR = do (_, wform, enctype) <- runFormGet customForm defaultLayout $ do form <- extractBody wform - addBody [$hamlet| + addHamlet [$hamlet| %form ^form^ %div diff --git a/yesod.cabal b/yesod.cabal index 3cf19cb4..228f7a02 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -48,6 +48,7 @@ library , xss-sanitize >= 0.2 && < 0.3 , data-default >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 + , containers >= 0.2 && < 0.5 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From 300f0a4f4d4a0ab8d6adf1ceac78ea882dd7a3bb Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 09:28:07 +0200 Subject: [PATCH 492/624] dataenc -> base64-bytestring --- Yesod/Helpers/Static.hs | 15 ++++++++++----- yesod.cabal | 2 +- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index acd2a70b..744de2ad 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -49,8 +49,8 @@ import Web.Routes import qualified Data.ByteString.Lazy as L import Data.Digest.Pure.MD5 -import qualified Codec.Binary.Base64Url -import qualified Data.ByteString as S +import qualified Data.ByteString.Base64 +import qualified Data.ByteString.Char8 as S8 import qualified Data.Serialize #if TEST @@ -188,8 +188,13 @@ caseGetFileList = do -- -- This function returns the first 8 characters of the hash. base64md5 :: L.ByteString -> String -base64md5 = take 8 - . Codec.Binary.Base64Url.encode - . S.unpack +base64md5 = map go + . take 8 + . S8.unpack + . Data.ByteString.Base64.encode . Data.Serialize.encode . md5 + where + go '+' = '-' + go '/' = '_' + go c = c diff --git a/yesod.cabal b/yesod.cabal index 228f7a02..a731b98d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -37,7 +37,7 @@ library , pureMD5 >= 1.1.0.0 && < 2.2 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.2 && < 0.4 - , dataenc >= 0.13.0.2 && < 0.14 + , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 , persistent >= 0.3.0 && < 0.4 , neither >= 0.1.0 && < 0.2 From ad8eeab03912b7bedc6780c279ab8be6874cde9c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 09:59:58 +0200 Subject: [PATCH 493/624] Scaffolded site works with 0.6 (no email login) --- scaffold/Root_hs.cg | 6 +++--- scaffold/Settings_hs.cg | 14 +++++++------- scaffold/cabal.cg | 23 +++++++++++++---------- scaffold/site-arg.cg | 4 ++-- scaffold/sitearg_hs.cg | 28 ++++++++++++++++++---------- 5 files changed, 43 insertions(+), 32 deletions(-) diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index d442d350..c05d8e37 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -16,7 +16,7 @@ getRootR = do defaultLayout $ do h2id <- newIdent setTitle "~project~ homepage" - addBody $(hamletFile "homepage") - addStyle $(cassiusFile "homepage") - addJavascript $(juliusFile "homepage") + addCassius $(cassiusFile "homepage") + addJulius $(juliusFile "homepage") + addWidget $(hamletFile "homepage") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 64cce2cf..e1ba8c7f 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -22,7 +22,7 @@ import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~ -import Yesod (MonadCatchIO) +import Yesod (MonadInvertIO) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you, @@ -93,13 +93,13 @@ connectionCount = 10 -- is used for increased performance. -- -- You can see an example of how to call these functions in Handler/Root.hs +-- +-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer +-- used; to get the same auto-loading effect, it is recommended that you +-- use the devel server. hamletFile :: FilePath -> Q Exp -#ifdef PRODUCTION hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" -#else -hamletFile x = H.hamletFileDebug $ "hamlet/" ++ x ++ ".hamlet" -#endif cassiusFile :: FilePath -> Q Exp #ifdef PRODUCTION @@ -119,9 +119,9 @@ juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself. -withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a +withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index b9ee9e41..0cbf05fc 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -20,15 +20,18 @@ executable simple-server if flag(production) Buildable: False main-is: simple-server.hs - build-depends: base >= 4 && < 5, - yesod >= 0.5 && < 0.6, - wai-extra, - directory, - bytestring, - persistent, - persistent-~lower~, - template-haskell, - hamlet + build-depends: base >= 4 && < 5 + , yesod >= 0.6 && < 0.7 + , yesod-auth >= 0.2 && < 0.3 + , mime-mail >= 0.0 && < 0.1 + , wai-extra + , directory + , bytestring + , persistent + , persistent-~lower~ + , template-haskell + , hamlet + , web-routes ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies @@ -47,7 +50,7 @@ executable fastcgi Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs - build-depends: wai-handler-fastcgi + build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies diff --git a/scaffold/site-arg.cg b/scaffold/site-arg.cg index 28e7e31a..f49604c5 100644 --- a/scaffold/site-arg.cg +++ b/scaffold/site-arg.cg @@ -1,5 +1,5 @@ Great, we'll be creating ~project~ today, and placing it in ~dir~. -What's going to be the name of your site argument datatype? This name must +What's going to be the name of your foundation datatype? This name must start with a capital letter. -Site argument: +Foundation: diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 47cb0dc8..60b5a1fd 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -14,18 +14,16 @@ module ~sitearg~ ) where import Yesod -import Yesod.Mail import Yesod.Helpers.Static import Yesod.Helpers.Auth +import Yesod.Helpers.Auth.OpenId import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L -import Yesod.WebRoutes +import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile) import Model -import Control.Monad (join) -import Data.Maybe (isJust) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -82,7 +80,7 @@ instance Yesod ~sitearg~ where mmsg <- getMessage pc <- widgetToPageContent $ do widget - addStyle $(Settings.cassiusFile "default-layout") + addCassius $(Settings.cassiusFile "default-layout") hamletToRepHtml $(Settings.hamletFile "default-layout") -- This is done to provide an optimization for serving static files from @@ -115,20 +113,29 @@ instance YesodPersist ~sitearg~ where runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db instance YesodAuth ~sitearg~ where - type AuthEntity ~sitearg~ = User - type AuthEmailEntity ~sitearg~ = Email + type AuthId ~sitearg~ = UserId - defaultDest _ = RootR + -- Where to send a user after successful login + loginDest _ = RootR + -- Where to send a user after logout + logoutDest _ = RootR - getAuthId creds _extra = runDB $ do + getAuthId creds = runDB $ do x <- getBy $ UniqueUser $ credsIdent creds case x of Just (uid, _) -> return $ Just uid Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - openIdEnabled _ = True + showAuthId _ x = show (fromIntegral x :: Integer) + readAuthId _ s = case reads s of + (i, _):_ -> Just $ fromInteger i + [] -> Nothing + authPlugins = [ authOpenId + ] + +{- FIXME emailSettings _ = Just EmailSettings { addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey) @@ -183,4 +190,5 @@ sendVerifyEmail' email _ verurl = |~~] } } +-} From de07376200901d42dc94dc1a1a6be751880afa45 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 10:00:59 +0200 Subject: [PATCH 494/624] Removed data-object dependency --- yesod.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index a731b98d..feaa78c3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -41,7 +41,6 @@ library , old-locale >= 1.0.0.2 && < 1.1 , persistent >= 0.3.0 && < 0.4 , neither >= 0.1.0 && < 0.2 - , data-object >= 0.3.1 && < 0.4 , network >= 2.2.1.5 && < 2.3 , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 From 7dd1b4cba8731da40b2df98fd0ec1e899fe5a9d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 10:19:06 +0200 Subject: [PATCH 495/624] Email authentication in scaffolded site --- Yesod.hs | 11 ++++ scaffold/cabal.cg | 1 + scaffold/sitearg_hs.cg | 123 +++++++++++++++++++++++------------------ 3 files changed, 82 insertions(+), 53 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index b1f16f4f..948e1b01 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,6 +15,8 @@ module Yesod , liftIO , MonadInvertIO , mempty + , showIntegral + , readIntegral ) where #if TEST @@ -40,3 +42,12 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty) import Control.Monad.Invert (MonadInvertIO) + +showIntegral :: Integral a => a -> String +showIntegral x = show (fromIntegral x :: Integer) + +readIntegral :: Num a => String -> Maybe a +readIntegral s = + case reads s of + (i, _):_ -> Just $ fromInteger i + [] -> Nothing diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 0cbf05fc..c09e4b61 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -27,6 +27,7 @@ executable simple-server , wai-extra , directory , bytestring + , text , persistent , persistent-~lower~ , template-haskell diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 60b5a1fd..59d87a70 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -17,6 +17,7 @@ import Yesod import Yesod.Helpers.Static import Yesod.Helpers.Auth import Yesod.Helpers.Auth.OpenId +import Yesod.Helpers.Auth.Email import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L @@ -24,6 +25,11 @@ import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile) import Model +import Data.Maybe (isJust) +import Control.Monad (join) +import Network.Mail.Mime +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Encoding -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -127,68 +133,79 @@ instance YesodAuth ~sitearg~ where Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - showAuthId _ x = show (fromIntegral x :: Integer) - readAuthId _ s = case reads s of - (i, _):_ -> Just $ fromInteger i - [] -> Nothing + showAuthId _ = showIntegral + readAuthId _ = readIntegral authPlugins = [ authOpenId + , authEmail ] -{- FIXME - emailSettings _ = Just EmailSettings - { addUnverified = \email verkey -> - runDB $ insert $ Email email Nothing (Just verkey) - , sendVerifyEmail = sendVerifyEmail' - , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get - , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key] - , verifyAccount = \eid -> runDB $ do - me <- get eid - case me of - Nothing -> return Nothing - Just e -> do - let email = emailEmail e - case emailUser e of - Just uid -> return $ Just uid - Nothing -> do - uid <- insert $ User email Nothing - update eid [EmailUser $ Just uid] - return $ Just uid - , getPassword = runDB . fmap (join . fmap userPassword) . get - , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass] - , getEmailCreds = \email -> runDB $ do - me <- getBy $ UniqueEmail email - case me of - Nothing -> return Nothing - Just (eid, e) -> return $ Just EmailCreds - { emailCredsId = eid - , emailCredsAuthId = emailUser e - , emailCredsStatus = isJust $ emailUser e - , emailCredsVerkey = emailVerkey e - } - , getEmail = runDB . fmap (fmap emailEmail) . get - } +instance YesodAuthEmail ~sitearg~ where + type AuthEmailId ~sitearg~ = EmailId -sendVerifyEmail' :: String -> String -> String -> GHandler Auth m () -sendVerifyEmail' email _ verurl = - liftIO $ renderSendMail Mail - { mailHeaders = - [ ("From", "noreply") - , ("To", email) - , ("Subject", "Verify your email address") + showAuthEmailId _ = showIntegral + readAuthEmailId _ = readIntegral + + addUnverified email verkey = + runDB $ insert $ Email email Nothing $ Just verkey + sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail + { mailHeaders = + [ ("From", "noreply") + , ("To", email) + , ("Subject", "Verify your email address") + ] + , mailParts = [[textPart, htmlPart]] + } + where + textPart = Part + { partType = "text/plain; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = Data.Text.Lazy.Encoding.encodeUtf8 + $ Data.Text.Lazy.pack $ unlines + [ "Please confirm your email address by clicking on the link below." + , "" + , verurl + , "" + , "Thank you" ] - , mailPlain = verurl - , mailParts = return Part - { partType = "text/html; charset=utf-8" - , partEncoding = None - , partDisposition = Inline - , partContent = renderHamlet id [$hamlet| + } + htmlPart = Part + { partType = "text/html; charset=utf-8" + , partEncoding = None + , partFilename = Nothing + , partContent = renderHtml [$hamlet| %p Please confirm your email address by clicking on the link below. %p %a!href=$verurl$ $verurl$ %p Thank you -|~~] - } +|] } --} + getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get + setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] + verifyAccount eid = runDB $ do + me <- get eid + case me of + Nothing -> return Nothing + Just e -> do + let email = emailEmail e + case emailUser e of + Just uid -> return $ Just uid + Nothing -> do + uid <- insert $ User email Nothing + update eid [EmailUser $ Just uid, EmailVerkey Nothing] + return $ Just uid + getPassword = runDB . fmap (join . fmap userPassword) . get + setPassword uid pass = runDB $ update uid [UserPassword $ Just pass] + getEmailCreds email = runDB $ do + me <- getBy $ UniqueEmail email + case me of + Nothing -> return Nothing + Just (eid, e) -> return $ Just EmailCreds + { emailCredsId = eid + , emailCredsAuthId = emailUser e + , emailCredsStatus = isJust $ emailUser e + , emailCredsVerkey = emailVerkey e + } + getEmail = runDB . fmap (fmap emailEmail) . get From d3a9201b27b4414df127a59a6a676c1af5f59f9b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 10:31:07 +0200 Subject: [PATCH 496/624] getSession --- Yesod/Handler.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b0e30e34..0054da91 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -58,7 +58,9 @@ module Yesod.Handler , alreadyExpired , expiresAt -- * Session + , SessionMap , lookupSession + , getSession , setSession , deleteSession -- ** Ultimate destination @@ -483,6 +485,10 @@ lookupSession n = GHandler $ do m <- lift $ lift $ lift get return $ Map.lookup n m +-- | Get all session variables. +getSession :: GHandler s m SessionMap +getSession = GHandler $ lift $ lift $ lift get + #if TEST testSuite :: Test From f0ba72d536335a2c54fe44d5702362afd6c9a216 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 11:01:56 +0200 Subject: [PATCH 497/624] Using mkMigrate in scaffolding --- Yesod/Form.hs | 2 +- Yesod/Form/Jquery.hs | 1 + scaffold/Controller_hs.cg | 4 +--- scaffold/Model_hs.cg | 4 +++- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index bf807f29..cb28907c 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -243,7 +243,7 @@ mkToForm = let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a in ftt `AppE` x go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = - let label' = string' `AppE` LitE (StringL label) + let label' = LitE $ StringL label tooltip' = string' `AppE` LitE (StringL tooltip) ffs = ffs' `AppE` label' `AppE` diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 90bbd7aa..7158be4a 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -13,6 +13,7 @@ module Yesod.Form.Jquery , jqueryDayFieldProfile , googleHostedJqueryUiCss , JqueryDaySettings (..) + , Default (..) ) where import Yesod.Handler diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 35ff7506..96885c3d 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -32,9 +32,7 @@ getRobotsR = return $ RepPlain $ toContent "User-agent: *" -- migrations handled by Yesod. with~sitearg~ :: (Application -> IO a) -> IO a with~sitearg~ f = Settings.withConnectionPool $ \p -> do - flip runConnectionPool p $ runMigration $ do - migrate (undefined :: User) - migrate (undefined :: Email) + runConnectionPool (runMigration migrateAll) p let h = ~sitearg~ s p toWaiApp h >>= f where diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 3602e7ce..7ad3062d 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -2,11 +2,13 @@ module Model where import Yesod +import Database.Persist.TH (share2) +import Database.Persist.GenericSql (mkMigrate) -- You can define all of your database entities here. You can find more -- information on persistent and how to declare entities at: -- http://docs.yesodweb.com/book/persistent/ -mkPersist [$persist| +share2 mkPersist (mkMigrate "migrateAll") [$persist| User ident String password String null update From 986226d6480f025b1724e227082975c9c8c317c8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 26 Oct 2010 15:47:43 +0200 Subject: [PATCH 498/624] Scaffolded site exports Widget --- scaffold/sitearg_hs.cg | 1 + 1 file changed, 1 insertion(+) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 59d87a70..2c693f05 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -4,6 +4,7 @@ module ~sitearg~ , ~sitearg~Route (..) , resources~sitearg~ , Handler + , Widget , maybeAuth , requireAuth , module Yesod From 3581fa957c0ce6397e00d82c5e3cf65149a17040 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 27 Oct 2010 18:05:06 +0200 Subject: [PATCH 499/624] Fix getMessage --- Yesod/Handler.hs | 3 ++- yesod.cabal | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0054da91..a4095cbf 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -363,8 +363,9 @@ setMessage = setSession msgKey . lbsToChars . renderHtml -- See 'setMessage'. getMessage :: GHandler sub master (Maybe Html) getMessage = do + mmsg <- fmap (fmap preEscapedString) $ lookupSession msgKey deleteSession msgKey - fmap (fmap preEscapedString) $ lookupSession msgKey + return mmsg -- | Bypass remaining handler code and output the given file. -- diff --git a/yesod.cabal b/yesod.cabal index feaa78c3..1f78c41a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.0 +version: 0.6.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From a03e831e8466c67a0424d9700a8963df940ed484 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 28 Oct 2010 11:32:22 +0200 Subject: [PATCH 500/624] Fix fastcgi dep in scaffolded cabal file --- scaffold/cabal.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index c09e4b61..63e2f5b2 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -47,11 +47,11 @@ executable devel-server executable fastcgi if flag(production) Buildable: True + build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 else Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs - build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies From b1a9832907b57e7551004b37b6767440e03248cf Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 28 Oct 2010 12:54:18 +0200 Subject: [PATCH 501/624] Exposing ErrorResponse --- Yesod/Handler.hs | 1 + yesod.cabal | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a4095cbf..2dc69418 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -77,6 +77,7 @@ module Yesod.Handler , toMasterHandler , localNoCurrent , HandlerData + , ErrorResponse (..) #if TEST , testSuite #endif diff --git a/yesod.cabal b/yesod.cabal index 1f78c41a..bfcbfd0f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.0.1 +version: 0.6.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 1c394b57237b56eef567e7c4529bb23ef5c6cf10 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 28 Oct 2010 12:54:30 +0200 Subject: [PATCH 502/624] hamlet version bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index bfcbfd0f..fe56e8ca 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,7 +30,7 @@ library , text >= 0.5 && < 0.11 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 - , hamlet >= 0.5.1 && < 0.6 + , hamlet >= 0.5.1 && < 0.7 , blaze-builder >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 From 5978b71559e5a5ac01e2c75684db35afcc142cd0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 30 Oct 2010 19:37:50 +0200 Subject: [PATCH 503/624] develserver in scaffold only reloads for hamlet --- scaffold/devel-server_hs.cg | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg index 8c32765b..9235a5c6 100644 --- a/scaffold/devel-server_hs.cg +++ b/scaffold/devel-server_hs.cg @@ -9,11 +9,7 @@ main = do , "You can view your app at http://localhost:3000/" , "" ] - _ <- forkIO $ run 3000 "Controller" "with~sitearg~" - [ "hamlet" - , "cassius" - , "julius" - ] + _ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"] go where go = do From 97819f0ad7bb3f46bf54fec88bb2ffd8f3fbf942 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 2 Nov 2010 13:17:11 +0200 Subject: [PATCH 504/624] atomLink and sanitizeBalance --- Yesod/Form/Nic.hs | 4 ++-- Yesod/Form/Profiles.hs | 4 ++-- Yesod/Helpers/AtomFeed.hs | 9 +++++++++ yesod.cabal | 4 ++-- 4 files changed, 15 insertions(+), 6 deletions(-) diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 328d36d2..30622b12 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -12,7 +12,7 @@ import Yesod.Handler import Yesod.Form.Core import Yesod.Hamlet import Yesod.Widget -import Text.HTML.SanitizeXSS (sanitizeXSS) +import Text.HTML.SanitizeXSS (sanitizeBalance) import Yesod.Internal (lbsToChars) @@ -32,7 +32,7 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeXSS + { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index ba9d3eec..26442d6f 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -24,7 +24,7 @@ import Data.Time (Day, TimeOfDay(..)) import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField) -import Text.HTML.SanitizeXSS (sanitizeXSS) +import Text.HTML.SanitizeXSS (sanitizeBalance) import Text.Blaze.Builder.Utf8 (writeChar) import Text.Blaze.Builder.Core (writeList, writeByteString) @@ -74,7 +74,7 @@ timeFieldProfile = FieldProfile htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeXSS + { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| %textarea.html#$theId$!name=$name$ $val$ diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 3e44c959..0e6a5160 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -19,6 +19,7 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) , atomFeed + , atomLink , RepAtom (..) ) where @@ -69,3 +70,11 @@ entryTemplate arg = [$xhamlet| %title $atomEntryTitle.arg$ %content!type=html $cdata.atomEntryContent.arg$ |] + +-- | Generates a link tag in the head of a widget. +atomLink :: Route m + -> String -- ^ title + -> GWidget s m () +atomLink u title = addHamletHead [$hamlet| +%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ +|] diff --git a/yesod.cabal b/yesod.cabal index fe56e8ca..4d8dd34a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.0.2 +version: 0.6.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -44,7 +44,7 @@ library , network >= 2.2.1.5 && < 2.3 , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.2 && < 0.3 + , xss-sanitize >= 0.2.3 && < 0.3 , data-default >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 From 82bab0c08498b29b8b26548b670b81c23a7a62f5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 5 Nov 2010 09:25:59 +0200 Subject: [PATCH 505/624] fileField and maybeFileField --- Yesod/Form/Fields.hs | 58 ++++++++++++++++++++++++++++++++++++++++++++ hellowidget.hs | 13 ++++++---- 2 files changed, 66 insertions(+), 5 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index b59898b5..82e0a9ba 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -16,6 +16,7 @@ module Yesod.Form.Fields , boolField , emailField , urlField + , fileField -- ** Optional , maybeStringField , maybeTextareaField @@ -28,6 +29,7 @@ module Yesod.Form.Fields , maybeSelectField , maybeEmailField , maybeUrlField + , maybeFileField -- * Inputs -- ** Required , stringInput @@ -44,6 +46,10 @@ module Yesod.Form.Fields import Yesod.Form.Core import Yesod.Form.Profiles +import Yesod.Request (FileInfo) +import Yesod.Widget (GWidget) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ask) import Data.Time (Day, TimeOfDay) import Text.Hamlet import Data.Monoid @@ -301,3 +307,55 @@ hiddenField = requiredFieldHelper hiddenFieldProfile maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) => FormFieldSettings -> Maybe (Maybe String) -> f maybeHiddenField = optionalFieldHelper hiddenFieldProfile + +fileField :: (IsForm f, FormType f ~ FileInfo) + => FormFieldSettings -> f +fileField ffs = toForm $ do + env <- lift ask + fenv <- lift $ lift ask + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let res = + if null env && null fenv + then FormMissing + else case lookup name fenv of + Nothing -> FormFailure ["File is required"] + Just x -> FormSuccess x + let fi = FieldInfo + { fiLabel = string label + , fiTooltip = tooltip + , fiIdent = theId + , fiInput = fileWidget theId name True + , fiErrors = case res of + FormFailure [x] -> Just $ string x + _ -> Nothing + , fiRequired = True + } + let res' = case res of + FormFailure [e] -> FormFailure [label ++ ": " ++ e] + _ -> res + return (res', fi, Multipart) + +maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) + => FormFieldSettings -> f +maybeFileField ffs = toForm $ do + fenv <- lift $ lift ask + let (FormFieldSettings label tooltip theId' name') = ffs + name <- maybe newFormIdent return name' + theId <- maybe newFormIdent return theId' + let res = FormSuccess $ lookup name fenv + let fi = FieldInfo + { fiLabel = string label + , fiTooltip = tooltip + , fiIdent = theId + , fiInput = fileWidget theId name False + , fiErrors = Nothing + , fiRequired = True + } + return (res, fi, Multipart) + +fileWidget :: String -> String -> Bool -> GWidget s m () +fileWidget theId name isReq = [$hamlet| +%input#$theId$!type=file!name=$name$!:isReq:required +|] diff --git a/hellowidget.hs b/hellowidget.hs index b70e6603..038768f0 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -61,7 +61,7 @@ getRootR = defaultLayout $ wrapper $ do addHtmlHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,) + (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -84,11 +84,12 @@ handleFormR = do (Just $ string "You can put rich text here") <*> maybeEmailField ("An e-mail addres") Nothing <*> maybeTextareaField "A text area" Nothing - let mhtml = case res of - FormSuccess (_, _, _, _, _, _, _, x, _, _) -> Just x - _ -> Nothing + <*> maybeFileField "Any file" + let (mhtml, mfile) = case res of + FormSuccess (_, _, _, _, _, _, _, x, _, _, y) -> (Just x, y) + _ -> (Nothing, Nothing) let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, Just x) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _) -> Just x _ -> Nothing defaultLayout $ do addCassius [$cassius| @@ -117,6 +118,8 @@ $maybe formFailures.res failures $html$ $maybe txt t $t$ + $maybe mfile f + $show.f$ |] setTitle $ string "Form" From 125090aebbacfb139b9c1e8f75873422340a2da2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 10 Nov 2010 09:41:42 +0200 Subject: [PATCH 506/624] blaze-builder 0.2 --- Yesod/Form/Profiles.hs | 6 +++--- Yesod/Json.hs | 6 +++--- yesod.cabal | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 26442d6f..fb436f92 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -26,8 +26,8 @@ import Network.URI (parseURI) import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) -import Text.Blaze.Builder.Utf8 (writeChar) -import Text.Blaze.Builder.Core (writeList, writeByteString) +import Blaze.ByteString.Builder.Char.Utf8 (writeChar) +import Blaze.ByteString.Builder (fromWrite4List, writeByteString) import Yesod.Internal (lbsToChars) @@ -87,7 +87,7 @@ newtype Textarea = Textarea { unTextarea :: String } deriving (Show, Read, Eq, PersistField) instance ToHtml Textarea where toHtml = - Html . writeList writeHtmlEscapedChar . unTextarea + Html . fromWrite4List writeHtmlEscapedChar . unTextarea where -- Taken from blaze-builder and modified with newline handling. writeHtmlEscapedChar '<' = writeByteString "<" diff --git a/Yesod/Json.hs b/Yesod/Json.hs index fe96cfbd..797ad44e 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -23,8 +23,8 @@ import Data.Char (isControl) import Yesod.Handler (GHandler) import Numeric (showHex) import Data.Monoid (Monoid (..)) -import Text.Blaze.Builder.Core -import Text.Blaze.Builder.Utf8 (writeChar) +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 (writeChar) #if TEST import Test.Framework (testGroup, Test) @@ -63,7 +63,7 @@ jsonToRepJson = fmap RepJson . jsonToContent jsonScalar :: String -> Json jsonScalar s = Json $ mconcat [ fromByteString "\"" - , writeList writeJsonChar s + , fromWrite4List writeJsonChar s , fromByteString "\"" ] where diff --git a/yesod.cabal b/yesod.cabal index 4d8dd34a..2501617b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.1 +version: 0.6.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -31,7 +31,7 @@ library , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.7 - , blaze-builder >= 0.1 && < 0.2 + , blaze-builder >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 , pureMD5 >= 1.1.0.0 && < 2.2 From 09f1a03be2009b3a6bd5e18f20ed8eb38199a0b2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 11 Nov 2010 20:14:09 +0200 Subject: [PATCH 507/624] network 2.3 --- yesod.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 2501617b..3fd7ef4d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.1.1 +version: 0.6.1.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -41,7 +41,7 @@ library , old-locale >= 1.0.0.2 && < 1.1 , persistent >= 0.3.0 && < 0.4 , neither >= 0.1.0 && < 0.2 - , network >= 2.2.1.5 && < 2.3 + , network >= 2.2.1.5 && < 2.4 , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 , xss-sanitize >= 0.2.3 && < 0.3 From f80cfab5d7c2641822c45f3ebe04d900c1c3ac5e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 14 Nov 2010 16:28:30 +0200 Subject: [PATCH 508/624] Cookie expire dates fixed --- Yesod/Content.hs | 7 ++++++- Yesod/Dispatch.hs | 2 +- yesod.cabal | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index f8af3092..7d4d5683 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -45,6 +45,7 @@ module Yesod.Content -- * Utilities , formatW3 , formatRFC1123 + , formatCookieExpires #if TEST , testSuite #endif @@ -249,10 +250,14 @@ caseTypeByExt = do Just typeHtml @=? lookup (ext "foo.html") typeByExt #endif --- | Format a 'UTCTime' in W3 format; useful for setting cookies. +-- | Format a 'UTCTime' in W3 format. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> String formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" + +-- | Format a 'UTCTime' for a cookie. +formatCookieExpires :: UTCTime -> String +formatCookieExpires = formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index ff79c15b..a3021503 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -385,7 +385,7 @@ headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes in ("Set-Cookie", charsToBs $ key ++ "=" ++ value ++"; path=/; expires=" - ++ formatW3 expires) + ++ formatCookieExpires expires) headerToPair _ (DeleteCookie key) = ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") diff --git a/yesod.cabal b/yesod.cabal index 3fd7ef4d..33bf98e9 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.1.2 +version: 0.6.1.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 0b5b132fa354fa6d51bff9b1043c5f720b07c346 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 15 Nov 2010 22:36:37 +0200 Subject: [PATCH 509/624] runFormPostTable and runFormPostDivs --- Yesod/Form.hs | 39 +++++++++++++++++++++++++++++++++++++++ yesod.cabal | 2 +- 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index cb28907c..5d0aeabb 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -29,6 +29,9 @@ module Yesod.Form , runFormMonadPost , runFormGet' , runFormPost' + -- ** High-level form post unwrappers + , runFormPostTable + , runFormPostDivs -- * Field/form helpers , fieldsToTable , fieldsToDivs @@ -45,6 +48,7 @@ import Yesod.Form.Core import Yesod.Form.Fields import Yesod.Form.Class import Yesod.Form.Profiles (Textarea (..)) +import Yesod.Widget (GWidget) import Text.Hamlet import Yesod.Request @@ -144,6 +148,41 @@ runFormPost' f = do x <- runFormGeneric pp files f helper x +-- | Create a table-styled form. +-- +-- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of +-- some of the boiler-plate in creating forms. In particular, is automatically +-- creates the form element, sets the method, action and enctype attributes, +-- adds the CSRF-protection nonce hidden field and inserts a submit button. +runFormPostTable :: Route m -> String -> FormField s m a + -> GHandler s m (FormResult a, GWidget s m ()) +runFormPostTable dest inputLabel form = do + (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form + let widget' = [$hamlet| +%form!method=post!action=@dest@!enctype=$enctype$ + %table + ^widget^ + %tr + %td!colspan=2 + $nonce$ + %input!type=submit!value=$inputLabel$ +|] + return (res, widget') + +-- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. +runFormPostDivs :: Route m -> String -> FormField s m a + -> GHandler s m (FormResult a, GWidget s m ()) +runFormPostDivs dest inputLabel form = do + (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form + let widget' = [$hamlet| +%form!method=post!action=@dest@!enctype=$enctype$ + ^widget^ + %div + $nonce$ + %input!type=submit!value=$inputLabel$ +|] + return (res, widget') + -- | Run a form against GET parameters, disregarding the resulting HTML and -- returning an error response on invalid input. runFormGet' :: GForm sub y xml a -> GHandler sub y a diff --git a/yesod.cabal b/yesod.cabal index 33bf98e9..0b8deb1d 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.1.3 +version: 0.6.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From ae69262ab3c89fc216316577e8c157129f28e04a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 16 Nov 2010 10:33:23 +0200 Subject: [PATCH 510/624] runFormPostTable -> runFormTable --- Yesod/Form.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 5d0aeabb..0fd42b43 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -30,8 +30,8 @@ module Yesod.Form , runFormGet' , runFormPost' -- ** High-level form post unwrappers - , runFormPostTable - , runFormPostDivs + , runFormTable + , runFormDivs -- * Field/form helpers , fieldsToTable , fieldsToDivs @@ -154,9 +154,9 @@ runFormPost' f = do -- some of the boiler-plate in creating forms. In particular, is automatically -- creates the form element, sets the method, action and enctype attributes, -- adds the CSRF-protection nonce hidden field and inserts a submit button. -runFormPostTable :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormPostTable dest inputLabel form = do +runFormTable :: Route m -> String -> FormField s m a + -> GHandler s m (FormResult a, GWidget s m ()) +runFormTable dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form let widget' = [$hamlet| %form!method=post!action=@dest@!enctype=$enctype$ @@ -170,9 +170,9 @@ runFormPostTable dest inputLabel form = do return (res, widget') -- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. -runFormPostDivs :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormPostDivs dest inputLabel form = do +runFormDivs :: Route m -> String -> FormField s m a + -> GHandler s m (FormResult a, GWidget s m ()) +runFormDivs dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form let widget' = [$hamlet| %form!method=post!action=@dest@!enctype=$enctype$ From 5e4c0d01708f261eb703a2a137e80edce372f8c5 Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Thu, 11 Nov 2010 20:35:14 -0800 Subject: [PATCH 511/624] moved YesodSubRoute to Yesod.Handler; added runSubHandler, addSubWidget --- Yesod/Handler.hs | 28 ++++++++++++++++++++++++++++ Yesod/Widget.hs | 31 ++++++++++++++++++++++++++++++- 2 files changed, 58 insertions(+), 1 deletion(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 2dc69418..ae9e98bd 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -24,6 +24,7 @@ module Yesod.Handler ( -- * Type families Route + , YesodSubRoute (..) -- * Handler monad , GHandler -- ** Read information from handler @@ -47,6 +48,8 @@ module Yesod.Handler -- ** Short-circuit responses. , sendFile , sendResponse + -- ** Calling foreign subsite handlers + , runSubHandler -- * Setting headers , setCookie , deleteCookie @@ -122,6 +125,9 @@ import Yesod.Content -- | The type-safe URLs associated with a site argument. type family Route a +class YesodSubRoute s y where + fromSubRoute :: s -> y -> Route s -> Route y + data HandlerData sub master = HandlerData { handlerRequest :: Request , handlerSub :: sub @@ -211,6 +217,28 @@ instance RequestReader (GHandler sub master) where getYesodSub :: GHandler sub master sub getYesodSub = handlerSub <$> GHandler ask +-- | Set the subsite in HandlerData +setHandlerSub :: YesodSubRoute sub' master => sub' -> HandlerData sub master -> HandlerData sub' master +setHandlerSub s (HandlerData r _ m _ rn _) = HandlerData r s m Nothing rn $ fromSubRoute s m + +-- | Run a handler from another subsite +runSubHandler :: YesodSubRoute sub' master => sub' -> GHandler sub' master a -> GHandler sub master a +runSubHandler sub handler = do + hd <- setHandlerSub sub <$> GHandler ask + session <- getSession + GHandler $ do + let toErrorHandler = + InternalError + . (show :: Control.Exception.SomeException -> String) + ((contents, headers), finalSession) <- liftIO $ flip runStateT session + $ runWriterT + $ runMEitherT + $ flip runReaderT hd + $ unGHandler handler + lift $ lift $ lift $ put finalSession + lift $ MEitherT $ return contents + + -- | Get the master site appliation argument. getYesod :: GHandler sub master master getYesod = handlerMaster <$> GHandler ask diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 037787f5..0519f35f 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -18,6 +18,7 @@ module Yesod.Widget , addHamlet , addHtml , addWidget + , addSubWidget -- ** CSS , addCassius , addStylesheet @@ -39,7 +40,7 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData) +import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute, runSubHandler) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -96,6 +97,34 @@ instance Monad (HamletMonad (GWidget s m ())) where liftHandler :: GHandler sub master a -> GWidget sub master a liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift +addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a +addSubWidget sub w = do + i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get + w' <- liftHandler $ runSubHandler sub $ flip runStateT i + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w + let ((((((((a, + body), + title), + scripts), + stylesheets), + style), + jscript), + h), + i') = w' + GWidget $ do + tell body + lift $ tell title + lift $ lift $ tell scripts + lift $ lift $ lift $ tell stylesheets + lift $ lift $ lift $ lift $ tell style + lift $ lift $ lift $ lift $ lift $ tell jscript + lift $ lift $ lift $ lift $ lift $ lift $ tell h + lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' + return a + + -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. setTitle :: Html -> GWidget sub master () From 99fed5a53c05ec9b74ff02246e77a562b3187a2d Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Mon, 15 Nov 2010 15:58:29 -0800 Subject: [PATCH 512/624] remove runSubHandler, using modified version of toMasterHandler instead --- Yesod/Handler.hs | 46 +++++++++++++++++------------------------ Yesod/Widget.hs | 54 ++++++++++++++++++++++++------------------------ 2 files changed, 46 insertions(+), 54 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ae9e98bd..72d208a8 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -48,8 +48,6 @@ module Yesod.Handler -- ** Short-circuit responses. , sendFile , sendResponse - -- ** Calling foreign subsite handlers - , runSubHandler -- * Setting headers , setCookie , deleteCookie @@ -78,6 +76,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , toMasterHandler + , toMasterHandlerMaybe , localNoCurrent , HandlerData , ErrorResponse (..) @@ -142,10 +141,17 @@ handlerSubData :: (Route sub -> Route master) -> Route sub -> HandlerData oldSub master -> HandlerData sub master -handlerSubData tm ts route hd = hd +handlerSubData tm ts = handlerSubDataMaybe tm ts . Just + +handlerSubDataMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubDataMaybe tm ts route hd = hd { handlerSub = ts $ handlerMaster hd , handlerToMaster = tm - , handlerRoute = Just route + , handlerRoute = route } -- | Used internally for promoting subsite handler functions to master site @@ -154,10 +160,18 @@ toMasterHandler :: (Route sub -> Route master) -> (master -> sub) -> Route sub -> GHandler sub master a - -> GHandler master master a + -> GHandler sub' master a toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandlerMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerMaybe tm ts route (GHandler h) = + GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h + -- | A generic handler monad, which can have a different subsite and master -- site. This monad is a combination of 'ReaderT' for basic arguments, a -- 'WriterT' for headers and session, and an 'MEitherT' monad for handling @@ -217,28 +231,6 @@ instance RequestReader (GHandler sub master) where getYesodSub :: GHandler sub master sub getYesodSub = handlerSub <$> GHandler ask --- | Set the subsite in HandlerData -setHandlerSub :: YesodSubRoute sub' master => sub' -> HandlerData sub master -> HandlerData sub' master -setHandlerSub s (HandlerData r _ m _ rn _) = HandlerData r s m Nothing rn $ fromSubRoute s m - --- | Run a handler from another subsite -runSubHandler :: YesodSubRoute sub' master => sub' -> GHandler sub' master a -> GHandler sub master a -runSubHandler sub handler = do - hd <- setHandlerSub sub <$> GHandler ask - session <- getSession - GHandler $ do - let toErrorHandler = - InternalError - . (show :: Control.Exception.SomeException -> String) - ((contents, headers), finalSession) <- liftIO $ flip runStateT session - $ runWriterT - $ runMEitherT - $ flip runReaderT hd - $ unGHandler handler - lift $ lift $ lift $ put finalSession - lift $ MEitherT $ return contents - - -- | Get the master site appliation argument. getYesod :: GHandler sub master master getYesod = handlerMaster <$> GHandler ask diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 0519f35f..efff5338 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -40,7 +40,7 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute, runSubHandler) +import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) @@ -98,32 +98,32 @@ liftHandler :: GHandler sub master a -> GWidget sub master a liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do - i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- liftHandler $ runSubHandler sub $ flip runStateT i - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT - $ unGWidget w - let ((((((((a, - body), - title), - scripts), - stylesheets), - style), - jscript), - h), - i') = w' - GWidget $ do - tell body - lift $ tell title - lift $ lift $ tell scripts - lift $ lift $ lift $ tell stylesheets - lift $ lift $ lift $ lift $ tell style - lift $ lift $ lift $ lift $ lift $ tell jscript - lift $ lift $ lift $ lift $ lift $ lift $ tell h - lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' - return a - +addSubWidget sub w = do master <- liftHandler getYesod + let sr = fromSubRoute sub master + i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get + w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i + $ runWriterT $ runWriterT $ runWriterT $ runWriterT + $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w + let ((((((((a, + body), + title), + scripts), + stylesheets), + style), + jscript), + h), + i') = w' + GWidget $ do + tell body + lift $ tell title + lift $ lift $ tell scripts + lift $ lift $ lift $ tell stylesheets + lift $ lift $ lift $ lift $ tell style + lift $ lift $ lift $ lift $ lift $ tell jscript + lift $ lift $ lift $ lift $ lift $ lift $ tell h + lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' + return a -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values. From aaed6875c2ca6370104f6131114159edcc51eaba Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 08:31:30 +0200 Subject: [PATCH 513/624] Fix mismatch between joinPath and splitPath --- Yesod/Yesod.hs | 60 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 58 insertions(+), 2 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 121177e7..dce31ef6 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -54,6 +54,7 @@ import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Failure (Failure) import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L import Data.Monoid @@ -63,6 +64,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes +import Network.URI (unEscapeString) #if TEST import Test.Framework (testGroup, Test) @@ -179,7 +181,46 @@ class Eq (Route a) => Yesod a where -- -- * Otherwise, ensures there /is/ a trailing slash. splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ = Network.Wai.Middleware.CleanPath.splitPath + splitPath _ s = + if corrected == s + then Right $ filter (not . null) + $ decodePathInfo + $ S8.unpack s + else Left corrected + where + corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s + + -- | Remove double slashes + rds :: String -> String + rds [] = [] + rds [x] = [x] + rds (a:b:c) + | a == '/' && b == '/' = rds (b:c) + | otherwise = a : rds (b:c) + + -- | Add a trailing slash if it is missing. Empty string is left alone. + ats :: String -> String + ats [] = [] + ats s = + if last s == '/' || dbs (reverse s) + then s + else s ++ "/" + + -- | Remove a trailing slash if the last piece has a period. + rts :: String -> String + rts [] = [] + rts s = + if last s == '/' && dbs (tail $ reverse s) + then init s + else s + + -- | Is there a period before a slash here? + dbs :: String -> Bool + dbs ('/':_) = False + dbs (_:'.':_) = True + dbs (_:x) = dbs x + dbs [] = False + -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. @@ -189,9 +230,12 @@ class Eq (Route a) => Yesod a where where fixSegs [] = [] fixSegs [x] - | any (== '.') x = [x] + | anyButLast (== '.') x = [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs + anyButLast p [] = False + anyButLast p [_] = False + anyButLast p (x:xs) = p x || anyButLast p xs -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and @@ -395,6 +439,7 @@ $maybe jscript j testSuite :: Test testSuite = testGroup "Yesod.Yesod" [ testProperty "join/split path" propJoinSplitPath + , testCase "join/split path [\".\"]" caseJoinSplitPathDquote , testCase "utf8 split path" caseUtf8SplitPath , testCase "utf8 join path" caseUtf8JoinPath ] @@ -411,6 +456,17 @@ propJoinSplitPath ss = where ss' = filter (not . null) ss +caseJoinSplitPathDquote :: Assertion +caseJoinSplitPathDquote = do + splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."] + splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."] + joinPath TmpYesod "" ["z."] [] @?= "/z./" + x @?= Right ss + where + x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) + ss' = filter (not . null) ss + ss = ["a."] + caseUtf8SplitPath :: Assertion caseUtf8SplitPath = do Right ["שלום"] @=? From 92ab8ee889f18b87b2a46bb641e08a46ad1350a0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 11:03:26 +0200 Subject: [PATCH 514/624] GHC 7 support. GHC 7 changes the syntax for quasi-quotation. A later patch release (7.0.2) should be adding back backwards-compatibility with the old syntax, but in the meanwhile this (relatively ugly) hack should fix it. --- Yesod/Form.hs | 47 ++++++++++++++++++++++---- Yesod/Form/Fields.hs | 38 ++++++++++++++++++--- Yesod/Form/Jquery.hs | 43 ++++++++++++++++++++---- Yesod/Form/Nic.hs | 19 +++++++++-- Yesod/Form/Profiles.hs | 71 +++++++++++++++++++++++++++++++++------ Yesod/Helpers/AtomFeed.hs | 22 ++++++++++-- Yesod/Helpers/Crud.hs | 29 +++++++++++++--- Yesod/Helpers/Sitemap.hs | 11 ++++-- Yesod/Internal.hs | 11 ++++-- Yesod/Yesod.hs | 57 ++++++++++++++++++++++++++----- scaffold.hs | 8 +++++ scaffold/Model_hs.cg | 2 +- scaffold/sitearg_hs.cg | 4 +-- yesod.cabal | 20 +++++++++-- 14 files changed, 329 insertions(+), 53 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 0fd42b43..dca34270 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -3,6 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} -- | Parse forms (and query strings). module Yesod.Form ( -- * Data types @@ -72,7 +73,12 @@ fieldsToPlain = mapFormXml $ mapM_ fiInput fieldsToTable :: FormField sub y a -> Form sub y a fieldsToTable = mapFormXml $ mapM_ go where - go fi = [$hamlet| + go fi = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %tr.$clazz.fi$ %td %label!for=$fiIdent.fi$ $fiLabel.fi$ @@ -88,7 +94,12 @@ fieldsToTable = mapFormXml $ mapM_ go fieldsToDivs :: FormField sub y a -> Form sub y a fieldsToDivs = mapFormXml $ mapM_ go where - go fi = [$hamlet| + go fi = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif .$clazz.fi$ %label!for=$fiIdent.fi$ $fiLabel.fi$ .tooltip $fiTooltip.fi$ @@ -125,7 +136,14 @@ runFormPost f = do _ -> res return (res', xml, enctype, hidden nonce) where - hidden nonce = [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|] + hidden nonce = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + %input!type=hidden!name=$nonceName$!value=$nonce$ +|] nonceName :: String nonceName = "_nonce" @@ -158,7 +176,12 @@ runFormTable :: Route m -> String -> FormField s m a -> GHandler s m (FormResult a, GWidget s m ()) runFormTable dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form - let widget' = [$hamlet| + let widget' = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=post!action=@dest@!enctype=$enctype$ %table ^widget^ @@ -174,7 +197,12 @@ runFormDivs :: Route m -> String -> FormField s m a -> GHandler s m (FormResult a, GWidget s m ()) runFormDivs dest inputLabel form = do (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form - let widget' = [$hamlet| + let widget' = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=post!action=@dest@!enctype=$enctype$ ^widget^ %div @@ -199,7 +227,14 @@ generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) generateForm f = do (_, b, c) <- runFormGeneric [] [] f nonce <- fmap reqNonce getRequest - return (b, c, [$hamlet|%input!type=hidden!name=$nonceName$!value=$nonce$|]) + return (b, c, +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + %input!type=hidden!name=$nonceName$!value=$nonce$ +|]) -- | Run a form against GET parameters. runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index 82e0a9ba..abdfc4b0 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} module Yesod.Form.Fields ( -- * Fields -- ** Required @@ -126,7 +127,12 @@ boolField ffs orig = toForm $ do { fiLabel = string label , fiTooltip = tooltip , fiIdent = theId - , fiInput = [$hamlet| + , fiInput = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!type=checkbox!name=$name$!:val:checked |] , fiErrors = case res of @@ -170,7 +176,12 @@ selectField pairs ffs initial = toForm $ do case res of FormSuccess y -> x == y _ -> Just x == initial - let input = [$hamlet| + let input = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %select#$theId$!name=$name$ %option!value=none $forall pairs' pair @@ -215,7 +226,12 @@ maybeSelectField pairs ffs initial' = toForm $ do case res of FormSuccess y -> Just x == y _ -> Just x == initial - let input = [$hamlet| + let input = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %select#$theId$!name=$name$ %option!value=none $forall pairs' pair @@ -251,7 +267,14 @@ boolInput n = GForm $ do Just "" -> FormSuccess False Just "false" -> FormSuccess False Just _ -> FormSuccess True - let xml = [$hamlet|%input#$n$!type=checkbox!name=$n$|] + let xml = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + %input#$n$!type=checkbox!name=$n$ +|] return (res, [xml], UrlEncoded) dayInput :: String -> FormInput sub master Day @@ -356,6 +379,11 @@ maybeFileField ffs = toForm $ do return (res, fi, Multipart) fileWidget :: String -> String -> Bool -> GWidget s m () -fileWidget theId name isReq = [$hamlet| +fileWidget theId name isReq = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!type=file!name=$name$!:isReq:required |] diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 7158be4a..4e9b4565 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..) @@ -75,13 +76,23 @@ jqueryDayFieldProfile jds = FieldProfile . readMay , fpRender = show , fpWidget = \theId name val isReq -> do - addHtml [$hamlet| + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJulius [$julius| + addJulius +#if GHC7 + [julius| +#else + [$julius| +#endif $(function(){$("#%theId%").datepicker({ dateFormat:'yy-mm-dd', changeMonth:%jsBool.jdsChangeMonth.jds%, @@ -133,14 +144,24 @@ jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do - addHtml [$hamlet| + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJulius [$julius| + addJulius +#if GHC7 + [julius| +#else + [$julius| +#endif $(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -177,13 +198,23 @@ jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> do - addHtml [$hamlet| + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJulius [$julius| + addJulius +#if GHC7 + [julius| +#else + [$julius| +#endif $(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index 30622b12..66447a4a 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- | Provide the user with a rich text editor. module Yesod.Form.Nic ( YesodNic (..) @@ -35,9 +36,23 @@ nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do - addHtml [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + %textarea.html#$theId$!name=$name$ $val$ +|] addScript' urlNicEdit - addJulius [$julius|bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")});|] + addJulius +#if GHC7 + [julius| +#else + [$julius| +#endif +bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")}); +|] } addScript' :: (y -> Either (Route y) String) -> GWidget sub y () diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index fb436f92..fa7e16c5 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Yesod.Form.Profiles ( stringFieldProfile , textareaFieldProfile @@ -35,7 +36,12 @@ intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] } @@ -49,7 +55,12 @@ doubleFieldProfile :: FieldProfile sub y Double doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -58,7 +69,12 @@ dayFieldProfile :: FieldProfile sub y Day dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] } @@ -67,7 +83,12 @@ timeFieldProfile :: FieldProfile sub y TimeOfDay timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!:isReq:required!value=$val$ |] } @@ -76,7 +97,12 @@ htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %textarea.html#$theId$!name=$name$ $val$ |] } @@ -102,7 +128,12 @@ textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %textarea#$theId$!name=$name$ $val$ |] } @@ -111,7 +142,12 @@ hiddenFieldProfile :: FieldProfile sub y String hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpWidget = \theId name val _isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val _isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input!type=hidden#$theId$!name=$name$!value=$val$ |] } @@ -120,7 +156,12 @@ stringFieldProfile :: FieldProfile sub y String stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -169,7 +210,12 @@ emailFieldProfile = FieldProfile then Right s else Left "Invalid e-mail address" , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] } @@ -180,7 +226,12 @@ urlFieldProfile = FieldProfile Nothing -> Left "Invalid URL" Just _ -> Right s , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet [$hamlet| + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] } diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index 0e6a5160..8a5ea4a8 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.AtomFeed @@ -49,7 +50,12 @@ data AtomFeedEntry url = AtomFeedEntry } template :: AtomFeed url -> Hamlet url -template arg = [$xhamlet| +template arg = +#if GHC7 + [xhamlet| +#else + [$xhamlet| +#endif <?xml version="1.0" encoding="utf-8"?> %feed!xmlns="http://www.w3.org/2005/Atom" %title $atomTitle.arg$ @@ -62,7 +68,12 @@ template arg = [$xhamlet| |] entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = [$xhamlet| +entryTemplate arg = +#if GHC7 + [xhamlet| +#else + [$xhamlet| +#endif %entry %id @atomEntryLink.arg@ %link!href=@atomEntryLink.arg@ @@ -75,6 +86,11 @@ entryTemplate arg = [$xhamlet| atomLink :: Route m -> String -- ^ title -> GWidget s m () -atomLink u title = addHamletHead [$hamlet| +atomLink u title = addHamletHead +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ |] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs index 5aebcae9..7690da70 100644 --- a/Yesod/Helpers/Crud.hs +++ b/Yesod/Helpers/Crud.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Yesod.Helpers.Crud ( Item (..) , Crud (..) @@ -41,7 +42,12 @@ mkYesodSub "Crud master item" , ClassP ''Item [VarT $ mkName "item"] , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] - ] [$parseRoutes| + ] +#if GHC7 + [parseRoutes| +#else + [$parseRoutes| +#endif / CrudListR GET /add CrudAddR GET POST /edit/#String CrudEditR GET POST @@ -55,7 +61,12 @@ getCrudListR = do toMaster <- getRouteToMaster defaultLayout $ do setTitle "Items" - addWidget [$hamlet| + addWidget +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Items %ul $forall items item @@ -115,7 +126,12 @@ getCrudDeleteR s = do toMaster <- getRouteToMaster defaultLayout $ do setTitle "Confirm delete" - addWidget [$hamlet| + addWidget +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %form!method=post!action=@toMaster.CrudDeleteR.s@ %h1 Really delete? %p Do you really want to delete $itemTitle.item$? @@ -157,7 +173,12 @@ crudHelper title me isPost = do _ -> return () defaultLayout $ do setTitle $ string title - addWidget [$hamlet| + addWidget +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %p %a!href=@toMaster.CrudListR@ Return to list %h1 $title$ diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 5b009553..34807eb5 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap @@ -51,7 +52,12 @@ data SitemapUrl url = SitemapUrl } template :: [SitemapUrl url] -> Hamlet url -template urls = [$hamlet| +template urls = +#if GHC7 + [xhamlet| +#else + [$xhamlet| +#endif %urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" $forall urls url %url @@ -69,4 +75,5 @@ robots :: Route sub -- ^ sitemap url -> GHandler sub master RepPlain robots smurl = do tm <- getRouteToMaster - RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|] + render <- getUrlRender + return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index 97ddbfe3..20a1cc28 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} -- | Normal users should never need access to these. module Yesod.Internal ( -- * Error responses @@ -39,6 +40,12 @@ import qualified Data.Text.Encoding.Error as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +#if GHC7 +#define HAMLET hamlet +#else +#define HAMLET $hamlet +#endif + -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = @@ -63,8 +70,8 @@ langKey = "_LANG" data Location url = Local url | Remote String deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [$hamlet|@url@|] -locationToHamlet (Remote s) = [$hamlet|$s$|] +locationToHamlet (Local url) = [HAMLET|@url@|] +locationToHamlet (Remote s) = [HAMLET|$s$|] newtype UniqueList x = UniqueList ([x] -> [x]) instance Monoid (UniqueList x) where diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index dce31ef6..0fbd2881 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -73,6 +73,12 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif +#if GHC7 +#define HAMLET hamlet +#else +#define HAMLET $hamlet +#endif + -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class Eq (Route y) => YesodSite y where @@ -117,7 +123,7 @@ class Eq (Route a) => Yesod a where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage - hamletToRepHtml [$hamlet| + hamletToRepHtml [HAMLET| !!! %html %head @@ -312,31 +318,56 @@ defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest let path' = bsToChars $ pathInfo r - applyLayout' "Not Found" $ [$hamlet| + applyLayout' "Not Found" [hamlet| +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Not Found %p $path'$ |] where pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" $ [$hamlet| + applyLayout' "Permission Denied" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Permission denied %p $msg$ |] defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" $ [$hamlet| + applyLayout' "Invalid Arguments" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Invalid Arguments %ul $forall ia msg %li $msg$ |] defaultErrorHandler (InternalError e) = - applyLayout' "Internal Server Error" $ [$hamlet| + applyLayout' "Internal Server Error" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Internal Server Error %p $e$ |] defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" $ [$hamlet| + applyLayout' "Bad Method" +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif %h1 Method Not Supported %p Method "$m$" not supported |] @@ -416,7 +447,12 @@ widgetToPageContent (GWidget w) = do $ renderJulius render s return $ renderLoc x - let head'' = [$hamlet| + let head'' = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif $forall scripts s %script!src=^s^ $forall stylesheets s @@ -490,7 +526,12 @@ caseUtf8JoinPath = do -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. redirectToPost :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml [$hamlet| +redirectToPost dest = hamletToRepHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif !!! %html %head diff --git a/scaffold.hs b/scaffold.hs index 36f6deed..cfca5303 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} import CodeGen import System.IO import System.Directory @@ -10,6 +11,13 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +qq :: String +#if GHC7 +qq = "" +#else +qq = "$" +#endif + main :: IO () main = do putStr $(codegen "welcome") diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 7ad3062d..4fa4dec6 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -8,7 +8,7 @@ import Database.Persist.GenericSql (mkMigrate) -- You can define all of your database entities here. You can find more -- information on persistent and how to declare entities at: -- http://docs.yesodweb.com/book/persistent/ -share2 mkPersist (mkMigrate "migrateAll") [$persist| +share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| User ident String password String null update diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 2c693f05..dad00631 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -68,7 +68,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" [$parseRoutes| +mkYesodData "~sitearg~" [~qq~parseRoutes| /static StaticR Static getStatic /auth AuthR Auth getAuth @@ -175,7 +175,7 @@ instance YesodAuthEmail ~sitearg~ where { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing - , partContent = renderHtml [$hamlet| + , partContent = renderHtml [~qq~hamlet| %p Please confirm your email address by clicking on the link below. %p %a!href=$verurl$ $verurl$ diff --git a/yesod.cabal b/yesod.cabal index 0b8deb1d..1312cd4b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -20,9 +20,15 @@ flag test description: Build the executable to run unit tests default: False +flag ghc7 + library - build-depends: base >= 4 && < 5 - , time >= 1.1.4 && < 1.3 + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: time >= 1.1.4 && < 1.3 , wai >= 0.2.0 && < 0.3 , wai-extra >= 0.2.4 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10 @@ -72,6 +78,11 @@ library ghc-options: -Wall executable yesod + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 build-depends: parsec >= 2.1 && < 4 ghc-options: -Wall main-is: scaffold.hs @@ -79,6 +90,11 @@ executable yesod extensions: TemplateHaskell executable runtests + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 if flag(test) Buildable: True cpp-options: -DTEST From dd693a96a4cb79a99c5048128275110cdaedf91b Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 11:37:54 +0200 Subject: [PATCH 515/624] widgetFile in scaffolded site --- scaffold/Root_hs.cg | 4 +--- scaffold/Settings_hs.cg | 31 +++++++++++++++++++++++++------ scaffold/sitearg_hs.cg | 2 +- 3 files changed, 27 insertions(+), 10 deletions(-) diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index c05d8e37..2c3f42f9 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -16,7 +16,5 @@ getRootR = do defaultLayout $ do h2id <- newIdent setTitle "~project~ homepage" - addCassius $(cassiusFile "homepage") - addJulius $(juliusFile "homepage") - addWidget $(hamletFile "homepage") + addWidget $(widgetFile "homepage") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index e1ba8c7f..7e80e669 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -8,6 +8,7 @@ module Settings ( hamletFile , cassiusFile , juliusFile + , widgetFile , connStr , ConnectionPool , withConnectionPool @@ -22,7 +23,9 @@ import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~ -import Yesod (MonadInvertIO) +import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) +import Data.Monoid (mempty) +import System.Directory (doesFileExist) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you, @@ -98,23 +101,39 @@ connectionCount = 10 -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. +toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath +toHamletFile x = "hamlet/" ++ x ++ ".hamlet" +toCassiusFile x = "cassius/" ++ x ++ ".cassius" +toJuliusFile x = "julius/" ++ x ++ ".julius" + hamletFile :: FilePath -> Q Exp -hamletFile x = H.hamletFile $ "hamlet/" ++ x ++ ".hamlet" +hamletFile = H.hamletFile . toHamletFile cassiusFile :: FilePath -> Q Exp #ifdef PRODUCTION -cassiusFile x = H.cassiusFile $ "cassius/" ++ x ++ ".cassius" +cassiusFile = H.cassiusFile . toCassiusFile #else -cassiusFile x = H.cassiusFileDebug $ "cassius/" ++ x ++ ".cassius" +cassiusFile = H.cassiusFileDebug . toCassiusFile #endif juliusFile :: FilePath -> Q Exp #ifdef PRODUCTION -juliusFile x = H.juliusFile $ "julius/" ++ x ++ ".julius" +juliusFile = H.juliusFile . toJuliusFile #else -juliusFile x = H.juliusFileDebug $ "julius/" ++ x ++ ".julius" +juliusFile = H.juliusFileDebug . toJuliusFile #endif +widgetFile :: FilePath -> Q Exp +widgetFile x = do + let h = unlessExists toHamletFile hamletFile + let c = unlessExists toCassiusFile cassiusFile + let j = unlessExists toJuliusFile juliusFile + [|addWidget $h >> addCassius $c >> addJulius $j|] + where + unlessExists tofn f = do + e <- qRunIO $ doesFileExist $ tofn x + if e then f x else [|mempty|] + -- The next two functions are for allocating a connection pool and running -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index dad00631..493c27d4 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -24,7 +24,7 @@ import System.Directory import qualified Data.ByteString.Lazy as L import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql -import Settings (hamletFile, cassiusFile, juliusFile) +import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model import Data.Maybe (isJust) import Control.Monad (join) From 33c072d372c3414dc2c24bb4e38104bc829ef93f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 11:39:30 +0200 Subject: [PATCH 516/624] persistent 0.3.1.1 in scaffolded site --- scaffold/Model_hs.cg | 6 +++--- scaffold/cabal.cg | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 4fa4dec6..d97260a5 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -11,12 +11,12 @@ import Database.Persist.GenericSql (mkMigrate) share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| User ident String - password String null update + password String Maybe Update UniqueUser ident Email email String - user UserId null update - verkey String null update + user UserId Maybe Update + verkey String Maybe Update UniqueEmail email |] diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 63e2f5b2..715ca99b 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -28,7 +28,7 @@ executable simple-server , directory , bytestring , text - , persistent + , persistent >= 0.3.1.1 , persistent-~lower~ , template-haskell , hamlet From 22b177f08c6f75e324664ff6adec8e66ff99e3dd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 11:47:21 +0200 Subject: [PATCH 517/624] Javascript minification in scaffolded site --- scaffold/cabal.cg | 1 + scaffold/sitearg_hs.cg | 13 +++++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 715ca99b..accbcd57 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -33,6 +33,7 @@ executable simple-server , template-haskell , hamlet , web-routes + , hjsmin >= 0.0.4 && < 0.1 ghc-options: -Wall extensions: TemplateHaskell, QuasiQuotes, TypeFamilies diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 493c27d4..f83f8335 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -27,10 +27,11 @@ import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model import Data.Maybe (isJust) -import Control.Monad (join) +import Control.Monad (join, unless) import Network.Mail.Mime import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding +import Text.Jasmine (minifym) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -109,9 +110,17 @@ instance Yesod ~sitearg~ where -- users receiving stale content. addStaticContent ext' _ content = do let fn = base64md5 content ++ '.' : ext' + let content' = + if ext' == "js" + then case minifym content of + Left _ -> content + Right y -> y + else content let statictmp = Settings.staticdir ++ "/tmp/" liftIO $ createDirectoryIfMissing True statictmp - liftIO $ L.writeFile (statictmp ++ fn) content + let fn' = statictmp ++ fn + exists <- liftIO $ doesFileExist fn' + unless exists $ liftIO $ L.writeFile fn' content' return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) -- How to run database actions. From 26209f9aebd0bc18ec559f56ea16d6ea27243abf Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 11:47:39 +0200 Subject: [PATCH 518/624] yesod 0.6.3 bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 1312cd4b..a5c1278f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.2 +version: 0.6.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From cc09c071a63466d709c8767e5eef80f4ebafa1e6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 19 Nov 2010 12:02:11 +0200 Subject: [PATCH 519/624] Minor fixes --- Yesod/Yesod.hs | 28 ++++++++++++---------------- scaffold/Settings_hs.cg | 1 + 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 0fbd2881..6a2523c4 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -55,7 +55,6 @@ import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Failure (Failure) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 -import qualified Network.Wai.Middleware.CleanPath import qualified Data.ByteString.Lazy as L import Data.Monoid import Control.Monad.Trans.Writer @@ -64,7 +63,6 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes -import Network.URI (unEscapeString) #if TEST import Test.Framework (testGroup, Test) @@ -207,18 +205,18 @@ class Eq (Route a) => Yesod a where -- | Add a trailing slash if it is missing. Empty string is left alone. ats :: String -> String ats [] = [] - ats s = - if last s == '/' || dbs (reverse s) - then s - else s ++ "/" + ats t = + if last t == '/' || dbs (reverse t) + then t + else t ++ "/" -- | Remove a trailing slash if the last piece has a period. rts :: String -> String rts [] = [] - rts s = - if last s == '/' && dbs (tail $ reverse s) - then init s - else s + rts t = + if last t == '/' && dbs (tail $ reverse t) + then init t + else t -- | Is there a period before a slash here? dbs :: String -> Bool @@ -239,8 +237,8 @@ class Eq (Route a) => Yesod a where | anyButLast (== '.') x = [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs - anyButLast p [] = False - anyButLast p [_] = False + anyButLast _ [] = False + anyButLast _ [_] = False anyButLast p (x:xs) = p x || anyButLast p xs -- | This function is used to store some static content to be served as an @@ -317,8 +315,8 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path' = bsToChars $ pathInfo r - applyLayout' "Not Found" [hamlet| + let path' = bsToChars $ W.pathInfo r + applyLayout' "Not Found" #if GHC7 [hamlet| #else @@ -327,8 +325,6 @@ defaultErrorHandler NotFound = do %h1 Not Found %p $path'$ |] - where - pathInfo = W.pathInfo defaultErrorHandler (PermissionDenied msg) = applyLayout' "Permission Denied" #if GHC7 diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 7e80e669..dad79c92 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod From 967ad7ec804e11dd19ab03bd16ed6f6dc681a956 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 21 Nov 2010 20:21:48 +0200 Subject: [PATCH 520/624] Blacklist -> whitelist for staticFiles --- Yesod/Helpers/Static.hs | 8 +++++--- yesod.cabal | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 744de2ad..6c3c4e53 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -153,9 +153,11 @@ staticFiles fp = do fs <- qRunIO $ getFileList fp concat `fmap` mapM go fs where - replace' '.' = '_' - replace' '-' = '_' - replace' c = c + replace' c + | 'A' <= c && c <= 'Z' = c + | 'a' <= c && c <= 'z' = c + | '0' <= c && c <= '9' = c + | otherwise = '_' go f = do let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f diff --git a/yesod.cabal b/yesod.cabal index a5c1278f..efdfe931 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.3 +version: 0.6.3.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From d15368065febdfc40e5f87d9a0e5b3e972e11e69 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 22 Nov 2010 07:47:53 +0200 Subject: [PATCH 521/624] passwordField --- Yesod/Form/Fields.hs | 10 ++++++++++ Yesod/Form/Profiles.hs | 15 +++++++++++++++ hellowidget.hs | 7 ++++--- yesod.cabal | 2 +- 4 files changed, 30 insertions(+), 4 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index abdfc4b0..a71bd576 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -6,6 +6,7 @@ module Yesod.Form.Fields ( -- * Fields -- ** Required stringField + , passwordField , textareaField , hiddenField , intField @@ -20,6 +21,7 @@ module Yesod.Form.Fields , fileField -- ** Optional , maybeStringField + , maybePasswordField , maybeTextareaField , maybeHiddenField , maybeIntField @@ -65,6 +67,14 @@ maybeStringField :: (IsForm f, FormType f ~ Maybe String) => FormFieldSettings -> Maybe (Maybe String) -> f maybeStringField = optionalFieldHelper stringFieldProfile +passwordField :: (IsForm f, FormType f ~ String) + => FormFieldSettings -> Maybe String -> f +passwordField = requiredFieldHelper passwordFieldProfile + +maybePasswordField :: (IsForm f, FormType f ~ Maybe String) + => FormFieldSettings -> Maybe (Maybe String) -> f +maybePasswordField = optionalFieldHelper passwordFieldProfile + intInput :: Integral i => String -> FormInput sub master i intInput n = mapFormXml fieldsToInput $ diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index fa7e16c5..b42bf3c7 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -4,6 +4,7 @@ {-# LANGUAGE CPP #-} module Yesod.Form.Profiles ( stringFieldProfile + , passwordFieldProfile , textareaFieldProfile , hiddenFieldProfile , intFieldProfile @@ -166,6 +167,20 @@ stringFieldProfile = FieldProfile |] } +passwordFieldProfile :: FieldProfile s m String +passwordFieldProfile = FieldProfile + { fpParse = Right + , fpRender = id + , fpWidget = \theId name val isReq -> addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +%input#$theId$!name=$name$!type=password!:isReq:required!value=$val$ +|] + } + readMay :: Read a => String -> Maybe a readMay s = case reads s of (x, _):_ -> Just x diff --git a/hellowidget.hs b/hellowidget.hs index 038768f0..3c73e81a 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -61,7 +61,7 @@ getRootR = defaultLayout $ wrapper $ do addHtmlHead [$hamlet|%meta!keywords=haskell|] handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,) + (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,) <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing <*> stringField ("Another field") (Just "some default text") <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) @@ -85,11 +85,12 @@ handleFormR = do <*> maybeEmailField ("An e-mail addres") Nothing <*> maybeTextareaField "A text area" Nothing <*> maybeFileField "Any file" + <*> maybePasswordField "Enter a password" Nothing let (mhtml, mfile) = case res of - FormSuccess (_, _, _, _, _, _, _, x, _, _, y) -> (Just x, y) + FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y) _ -> (Nothing, Nothing) let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _) -> Just x + FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x _ -> Nothing defaultLayout $ do addCassius [$cassius| diff --git a/yesod.cabal b/yesod.cabal index efdfe931..61a68b76 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.3.1 +version: 0.6.4 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From a7eae5413e6658d68bb37fb65f521522d9078730 Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Mon, 22 Nov 2010 10:39:50 -0800 Subject: [PATCH 522/624] mkYesodSubData, mkYesodSubDispatch --- Yesod/Dispatch.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index a3021503..0a8fda24 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -10,7 +10,9 @@ module Yesod.Dispatch , mkYesodSub -- ** More fine-grained , mkYesodData + , mkYesodSubData , mkYesodDispatch + , mkYesodSubDispatch -- ** Path pieces , SinglePiece (..) , MultiPiece (..) @@ -112,8 +114,15 @@ mkYesodSub name clazzes = -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [Resource] -> Q [Dec] -mkYesodData name res = do - (x, _) <- mkYesodGeneral name [] [] False res +mkYesodData name res = mkYesodDataGeneral name [] False res + +mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res + +mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec] +mkYesodDataGeneral name clazzes isSub res = do + let (name':rest) = words name + (x, _) <- mkYesodGeneral name' rest clazzes isSub res let rname = mkName $ "resources" ++ name eres <- lift res let y = [ SigD rname $ ListT `AppT` ConT ''Resource @@ -125,6 +134,10 @@ mkYesodData name res = do mkYesodDispatch :: String -> [Resource] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False +mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] +mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True + where (name':rest) = words name + mkYesodGeneral :: String -- ^ argument name -> [String] -- ^ parameters for site argument -> Cxt -- ^ classes From 93f934eb97e2e1f82dd4e7af70d66d313b7d4f93 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 23 Nov 2010 06:19:25 +0200 Subject: [PATCH 523/624] comments for mkEmbedFiles and getStaticHandler Conflicts: Yesod/Helpers/Static.hs --- Yesod/Helpers/Static.hs | 46 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 6c3c4e53..e84afe3c 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -105,6 +105,52 @@ fileLookupDir dir = Static $ \fp -> do then return $ Just $ Left fp' else return Nothing +-- | Lookup files in a specific directory, and embed them into the haskell source. +-- +-- A variation of fileLookupDir which allows subsites distributed via cabal to include +-- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler +-- for dispatching static content for a subsite. +mkEmbedFiles :: FilePath -> Q Exp +mkEmbedFiles d = do + fs <- qRunIO $ getFileList d + clauses <- mapM (mkClause . intercalate "/") fs + defC <- defaultClause + return $ static $ clauses ++ [defC] + where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f + f = mkName "f" + fun clauses = FunD f clauses + defaultClause = do + b <- [| return Nothing |] + return $ Clause [WildP] (NormalB b) [] + + mkClause path = do + content <- qRunIO $ readFile $ d ++ '/':path + let pat = LitP $ StringL path + foldAppE = foldl1 AppE + content' = return $ LitE $ StringL $ content + body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] + return $ Clause [pat] body [] + +-- | Dispatch static route for a subsite +-- +-- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. +-- Instead of a subsite route: +-- /static StaticR Static getStatic +-- Use a normal route: +-- /static/*Strings StaticR GET +-- +-- Then, define getStaticR something like: +-- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR +-- */ end CPP comment +getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep +getStaticHandler static toSubR pieces = do + toMasterR <- getRouteToMaster + toMasterHandler (toMasterR . toSubR) toSub route handler + where route = StaticRoute pieces [] + toSub _ = static + staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) + handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" + getStaticRoute :: [String] -> GHandler Static master (ContentType, Content) getStaticRoute fp' = do From 37ff175edee7312d16687ecd1bca6eaf13be4527 Mon Sep 17 00:00:00 2001 From: Aaron Culich <aculich@gmail.com> Date: Thu, 25 Nov 2010 11:25:29 -0800 Subject: [PATCH 524/624] added missing import of Language.Haskell.TH required for normalB --- Yesod/Helpers/Static.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index e84afe3c..6d5a954b 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -44,6 +44,7 @@ import Data.Maybe (fromMaybe) import Yesod hiding (lift) import Data.List (intercalate) +import Language.Haskell.TH import Language.Haskell.TH.Syntax import Web.Routes From 24669f8d38dd5e8e4a09cb92e59e1b9707c4f5f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 28 Nov 2010 21:44:09 +0200 Subject: [PATCH 525/624] sendResponseStatus and sendResponseCreated --- Yesod/Handler.hs | 36 ++++++++++++++++++++++++++++++------ yesod.cabal | 2 +- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 72d208a8..1e0f233a 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -48,6 +48,8 @@ module Yesod.Handler -- ** Short-circuit responses. , sendFile , sendResponse + , sendResponseStatus + , sendResponseCreated -- * Setting headers , setCookie , deleteCookie @@ -110,6 +112,7 @@ import Text.Hamlet import Control.Monad.Invert (MonadInvertIO (..)) import Control.Monad (liftM) import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as S8 #if TEST import Test.Framework (testGroup, Test) @@ -217,10 +220,11 @@ newtype YesodApp = YesodApp } data HandlerContents = - HCContent ChooseRep + HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String + | HCCreated String instance Failure ErrorResponse (GHandler sub master) where failure = GHandler . lift . throwMEither . HCError @@ -285,7 +289,7 @@ runHandler handler mrender sroute tomr ma tosa = $ flip runReaderT hd $ unGHandler handler ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither id (HCContent . chooseRep) contents' + let contents = meither id (HCContent W.status200 . chooseRep) contents' let handleError e = do (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession let hs' = headers hs @@ -293,9 +297,9 @@ runHandler handler mrender sroute tomr ma tosa = let sendFile' ct fp = return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) case contents of - HCContent a -> do + HCContent status a -> do (ct, c) <- chooseRep a cts - return (W.status200, headers [], ct, c, finalSession) + return (status, headers [], ct, c, finalSession) HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] @@ -304,6 +308,11 @@ runHandler handler mrender sroute tomr ma tosa = HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) + HCCreated loc -> do + let hs = Header "Location" loc : headers [] + return (W.Status 201 (S8.pack "Created"), hs, typePlain, + emptyContent, + finalSession) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do @@ -395,9 +404,24 @@ getMessage = do sendFile :: ContentType -> FilePath -> GHandler sub master a sendFile ct = GHandler . lift . throwMEither . HCSendFile ct --- | Bypass remaining handler code and output the given content. +-- | Bypass remaining handler code and output the given content with a 200 +-- status code. sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep +sendResponse = GHandler . lift . throwMEither . HCContent W.status200 + . chooseRep + +-- | Bypass remaining handler code and output the given content with the given +-- status code. +sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a +sendResponseStatus s = GHandler . lift . throwMEither . HCContent s + . chooseRep + +-- | Send a 201 "Created" response with the given route as the Location +-- response header. +sendResponseCreated :: Route m -> GHandler s m a +sendResponseCreated url = do + r <- getUrlRender + GHandler $ lift $ throwMEither $ HCCreated $ r url -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a diff --git a/yesod.cabal b/yesod.cabal index 61a68b76..16099fd9 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.4 +version: 0.6.5 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From ac809e8316b6f27c49a7f7dcb0088bc1da2ee124 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 30 Nov 2010 09:09:31 +0200 Subject: [PATCH 526/624] Fix runFormTable HTML output --- Yesod/Form.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Yesod/Form.hs b/Yesod/Form.hs index dca34270..9d9d054d 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -187,8 +187,8 @@ runFormTable dest inputLabel form = do ^widget^ %tr %td!colspan=2 - $nonce$ - %input!type=submit!value=$inputLabel$ + $nonce$ + %input!type=submit!value=$inputLabel$ |] return (res, widget') From ee5c8da8c9469ee4c81702685e2b8de06bfcfaed Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 30 Nov 2010 09:09:46 +0200 Subject: [PATCH 527/624] Using blaze writeHtmlEscapedChar for Textarea --- Yesod/Form/Profiles.hs | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index b42bf3c7..f0a5d7f0 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -28,7 +28,7 @@ import Network.URI (parseURI) import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) -import Blaze.ByteString.Builder.Char.Utf8 (writeChar) +import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (fromWrite4List, writeByteString) import Yesod.Internal (lbsToChars) @@ -117,13 +117,8 @@ instance ToHtml Textarea where Html . fromWrite4List writeHtmlEscapedChar . unTextarea where -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '<' = writeByteString "<" - writeHtmlEscapedChar '>' = writeByteString ">" - writeHtmlEscapedChar '&' = writeByteString "&" - writeHtmlEscapedChar '"' = writeByteString """ - writeHtmlEscapedChar '\'' = writeByteString "'" writeHtmlEscapedChar '\n' = writeByteString "<br>" - writeHtmlEscapedChar c = writeChar c + writeHtmlEscapedChar c = B.writeHtmlEscapedChar c textareaFieldProfile :: FieldProfile sub y Textarea textareaFieldProfile = FieldProfile From ca1fe977c568b7d8c9a375d33d5a2a90d7bec715 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 30 Nov 2010 09:14:20 +0200 Subject: [PATCH 528/624] Scaffolded FastCGI: threaded by default --- scaffold/cabal.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index accbcd57..cbd36003 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -53,6 +53,6 @@ executable fastcgi Buildable: False cpp-options: -DPRODUCTION main-is: fastcgi.hs - ghc-options: -Wall + ghc-options: -Wall -threaded extensions: TemplateHaskell, QuasiQuotes, TypeFamilies From cc612db73f4de912e4117ee457b5dfd4b29d5857 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 30 Nov 2010 20:44:24 +0200 Subject: [PATCH 529/624] text 0.11 --- Yesod/Handler.hs | 8 -------- yesod.cabal | 2 +- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 1e0f233a..ff7b99b4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -49,7 +49,6 @@ module Yesod.Handler , sendFile , sendResponse , sendResponseStatus - , sendResponseCreated -- * Setting headers , setCookie , deleteCookie @@ -416,13 +415,6 @@ sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a sendResponseStatus s = GHandler . lift . throwMEither . HCContent s . chooseRep --- | Send a 201 "Created" response with the given route as the Location --- response header. -sendResponseCreated :: Route m -> GHandler s m a -sendResponseCreated url = do - r <- getUrlRender - GHandler $ lift $ throwMEither $ HCCreated $ r url - -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound diff --git a/yesod.cabal b/yesod.cabal index 16099fd9..09509ed1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -33,7 +33,7 @@ library , wai-extra >= 0.2.4 && < 0.3 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.11 + , text >= 0.5 && < 0.12 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.7 From c8bf6d5215be7e58de2324c44dd758c984e849fa Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Fri, 26 Nov 2010 23:51:37 -0800 Subject: [PATCH 530/624] dynamic subsites --- Yesod/Dispatch.hs | 12 +++++++----- Yesod/Handler.hs | 10 ++++++++++ Yesod/Yesod.hs | 2 ++ 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 0a8fda24..e1db0723 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -162,7 +162,7 @@ mkYesodGeneral name args clazzes isSub res = do render'' <- newName "render" let render = LetE [FunD render'' render'] $ VarE render'' - tmh <- [|toMasterHandler|] + tmh <- [|toMasterHandlerDyn|] modMaster <- [|fmap chooseRep|] dispatch' <- createDispatch modMaster tmh th dispatch'' <- newName "dispatch" @@ -188,10 +188,11 @@ fromStatic (StaticPiece s) = s fromStatic _ = error "fromStatic" thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps attribs) - | all (all isUpper) attribs = return (n, Simple ps attribs) +thResourceFromResource _ (Resource n ps atts) + | all (all isUpper) atts = return (n, Simple ps atts) thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) - | all isStatic ps && any (any isLower) atts = do + -- static route to subsite + = do let stype' = ConT $ mkName stype gss <- [|getSubSite|] let inside = ConT ''Maybe `AppT` @@ -213,8 +214,9 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) , ssRender = render , ssDispatch = dispatch , ssToMasterArg = VarE $ mkName toSubArg - , ssPieces = map fromStatic ps + , ssPieces = ps }) + thResourceFromResource _ (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index ff7b99b4..502f93d9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -77,6 +77,7 @@ module Yesod.Handler , runHandler , YesodApp (..) , toMasterHandler + , toMasterHandlerDyn , toMasterHandlerMaybe , localNoCurrent , HandlerData @@ -166,6 +167,15 @@ toMasterHandler :: (Route sub -> Route master) toMasterHandler tm ts route (GHandler h) = GHandler $ withReaderT (handlerSubData tm ts route) h +toMasterHandlerDyn :: (Route sub -> Route master) + -> GHandler sub' master sub + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerDyn tm getSub route (GHandler h) = do + sub <- getSub + GHandler $ withReaderT (handlerSubData tm (const sub) route) h + toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6a2523c4..71a0a579 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -87,6 +87,8 @@ type Method = String -- to deal with it directly, as the mkYesodSub creates instances appropriately. class Eq (Route s) => YesodSubSite s y where getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) + getSiteFromSubSite _ = getSubSite -- | Define settings for a Yesod applications. The only required setting is -- 'approot'; other than that, there are intelligent defaults. From 6e90c6188e0e5e0c460d2a84acca0e15557f3b21 Mon Sep 17 00:00:00 2001 From: Matt Brown <matt@softmechanics.net> Date: Sat, 27 Nov 2010 17:07:41 -0800 Subject: [PATCH 531/624] new SubsiteGetter class to support either pure (master -> sub) or impure (GHandler master master sub) versions of sub site lookup functions --- Yesod/Dispatch.hs | 16 +++++++++++++++- Yesod/Handler.hs | 16 ++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index e1db0723..3c691152 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -208,18 +208,32 @@ thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) let render = render' `AppE` gss' dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] let dispatch = dispatch' `AppE` gss' + tmg <- mkToMasterArg ps toSubArg return (n, SubSite { ssType = ConT ''Route `AppT` stype' , ssParse = parse , ssRender = render , ssDispatch = dispatch - , ssToMasterArg = VarE $ mkName toSubArg + , ssToMasterArg = tmg , ssPieces = ps }) + thResourceFromResource _ (Resource n _ _) = error $ "Invalid attributes for resource: " ++ n +mkToMasterArg :: [Piece] -> String -> Q Exp +mkToMasterArg ps fname = do + let nargs = length $ filter (not.isStatic) ps + f = VarE $ mkName fname + args <- sequence $ take nargs $ repeat $ newName "x" + rsg <- [| runSubsiteGetter|] + let xps = map VarP args + xes = map VarE args + e' = foldl (\x y -> x `AppE` y) f xes + e = rsg `AppE` e' + return $ LamE xps e + sessionName :: String sessionName = "_SESSION" diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 502f93d9..eb7db8a9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -8,6 +8,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FunctionalDependencies #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -76,6 +77,7 @@ module Yesod.Handler -- * Internal Yesod , runHandler , YesodApp (..) + , SubsiteGetter(..) , toMasterHandler , toMasterHandlerDyn , toMasterHandlerMaybe @@ -176,6 +178,20 @@ toMasterHandlerDyn tm getSub route (GHandler h) = do sub <- getSub GHandler $ withReaderT (handlerSubData tm (const sub) route) h +class SubsiteGetter g m s | g -> s where + runSubsiteGetter :: g -> m s + +instance (master ~ master' + ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where + runSubsiteGetter get = do + y <- getYesod + return $ get y + +instance (anySub ~ anySub' + ,master ~ master' + ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where + runSubsiteGetter = id + toMasterHandlerMaybe :: (Route sub -> Route master) -> (master -> sub) -> Maybe (Route sub) From 3a92c467875a70f4e45283e8045723268b4e3b7d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 2 Dec 2010 16:13:45 +0200 Subject: [PATCH 532/624] web-routes-quasi version bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 09509ed1..3c70c6c1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -35,7 +35,7 @@ library , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 , template-haskell >= 2.4 && < 2.6 - , web-routes-quasi >= 0.6 && < 0.7 + , web-routes-quasi >= 0.6.2 && < 0.7 , hamlet >= 0.5.1 && < 0.7 , blaze-builder >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3 From 7cf560900940a69d95eca53c9e907689014705bc Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 2 Dec 2010 22:37:44 +0200 Subject: [PATCH 533/624] Do not expose SubsiteGetter, fix a number of warnings --- Yesod/Dispatch.hs | 8 ++------ Yesod/Handler.hs | 6 +++--- Yesod/Helpers/Static.hs | 3 +++ 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 3c691152..1396d733 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -62,7 +62,7 @@ import Control.Monad import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS -import Data.Char (isLower, isUpper) +import Data.Char (isUpper) import Data.Serialize import qualified Data.Serialize as Ser @@ -183,14 +183,10 @@ isStatic :: Piece -> Bool isStatic StaticPiece{} = True isStatic _ = False -fromStatic :: Piece -> String -fromStatic (StaticPiece s) = s -fromStatic _ = error "fromStatic" - thResourceFromResource :: Type -> Resource -> Q THResource thResourceFromResource _ (Resource n ps atts) | all (all isUpper) atts = return (n, Simple ps atts) -thResourceFromResource master (Resource n ps atts@[stype, toSubArg]) +thResourceFromResource master (Resource n ps [stype, toSubArg]) -- static route to subsite = do let stype' = ConT $ mkName stype diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index eb7db8a9..e9d9a4f4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -77,7 +77,7 @@ module Yesod.Handler -- * Internal Yesod , runHandler , YesodApp (..) - , SubsiteGetter(..) + , runSubsiteGetter , toMasterHandler , toMasterHandlerDyn , toMasterHandlerMaybe @@ -183,9 +183,9 @@ class SubsiteGetter g m s | g -> s where instance (master ~ master' ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where - runSubsiteGetter get = do + runSubsiteGetter getter = do y <- getYesod - return $ get y + return $ getter y instance (anySub ~ anySub' ,master ~ master' diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 6d5a954b..7a9048f5 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -31,6 +31,9 @@ module Yesod.Helpers.Static -- * Lookup files in filesystem , fileLookupDir , staticFiles + -- * Embed files + , mkEmbedFiles + , getStaticHandler -- * Hashing , base64md5 #if TEST From 610529d7bf9ba7069dfae8b38c7288dee7089421 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 4 Dec 2010 19:07:11 +0200 Subject: [PATCH 534/624] Add back sendResponseCreated --- Yesod/Handler.hs | 8 ++++++++ yesod.cabal | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index e9d9a4f4..608ac2aa 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,7 @@ module Yesod.Handler , sendFile , sendResponse , sendResponseStatus + , sendResponseCreated -- * Setting headers , setCookie , deleteCookie @@ -441,6 +442,13 @@ sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a sendResponseStatus s = GHandler . lift . throwMEither . HCContent s . chooseRep +-- | Send a 201 "Created" response with the given route as the Location +-- response header. +sendResponseCreated :: Route m -> GHandler s m a +sendResponseCreated url = do + r <- getUrlRender + GHandler $ lift $ throwMEither $ HCCreated $ r url + -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound diff --git a/yesod.cabal b/yesod.cabal index 3c70c6c1..96a71620 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.5 +version: 0.6.6 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 76dcee9c1234192f113e4e05e7feb988952213a8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 12 Dec 2010 20:33:20 +0200 Subject: [PATCH 535/624] Added Yesod category --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 96a71620..0293a2e7 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -9,7 +9,7 @@ description: Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving. . The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi. -category: Web +category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple From 67d6a59f15d3cedeccc2e1f3870d3aee1cb09f95 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 10 Dec 2010 17:32:21 -0800 Subject: [PATCH 536/624] bad link in README --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README b/README index 5994b259..7803d43c 100644 --- a/README +++ b/README @@ -1,3 +1,3 @@ After installing, type "yesod init" to start a new project. -More information available at: http://www.yesodweb.com/code.html +Learn more at [Yesod docs](http://docs.yesodweb.com/) From 200ba5d1112f3af8139d3f04ab1d2870003b033d Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 10 Dec 2010 17:34:49 -0800 Subject: [PATCH 537/624] this isn't markdown --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README b/README index 7803d43c..c738f600 100644 --- a/README +++ b/README @@ -1,3 +1,3 @@ After installing, type "yesod init" to start a new project. -Learn more at [Yesod docs](http://docs.yesodweb.com/) +Learn more at http://docs.yesodweb.com/ From 59486dcc77fcdc2bb8433c3a3be4e51e70a5f046 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sat, 11 Dec 2010 00:30:46 -0800 Subject: [PATCH 538/624] add field type of search with autoFocus technically autoFocus could go on any field. Actually, it could only go on one field of a form. I would assume it always goes on the first non-hiden field --- Yesod/Form/Fields.hs | 10 +++++ Yesod/Form/Jquery.hs | 52 +++++++---------------- Yesod/Form/Profiles.hs | 96 ++++++++++++++++++------------------------ 3 files changed, 67 insertions(+), 91 deletions(-) diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs index a71bd576..ad3fb22a 100644 --- a/Yesod/Form/Fields.hs +++ b/Yesod/Form/Fields.hs @@ -17,6 +17,7 @@ module Yesod.Form.Fields , selectField , boolField , emailField + , searchField , urlField , fileField -- ** Optional @@ -31,6 +32,7 @@ module Yesod.Form.Fields , maybeHtmlField , maybeSelectField , maybeEmailField + , maybeSearchField , maybeUrlField , maybeFileField -- * Inputs @@ -326,6 +328,14 @@ emailInput n = mapFormXml fieldsToInput $ requiredFieldHelper emailFieldProfile (nameSettings n) Nothing +searchField :: (IsForm f, FormType f ~ String) + => AutoFocus -> FormFieldSettings -> Maybe String -> f +searchField = requiredFieldHelper . searchFieldProfile + +maybeSearchField :: (IsForm f, FormType f ~ Maybe String) + => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f +maybeSearchField = optionalFieldHelper . searchFieldProfile + textareaField :: (IsForm f, FormType f ~ Textarea) => FormFieldSettings -> Maybe Textarea -> f textareaField = requiredFieldHelper textareaFieldProfile diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs index 4e9b4565..d527bcd0 100644 --- a/Yesod/Form/Jquery.hs +++ b/Yesod/Form/Jquery.hs @@ -27,6 +27,16 @@ import Yesod.Hamlet import Data.Char (isSpace) import Data.Default +#if GHC7 +#define HAMLET hamlet +#define CASSIUS cassius +#define JULIUS julius +#else +#define HAMLET $hamlet +#define CASSIUS $cassius +#define JULIUS $julius +#endif + -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: String -> String googleHostedJqueryUiCss theme = concat @@ -76,23 +86,13 @@ jqueryDayFieldProfile jds = FieldProfile . readMay , fpRender = show , fpWidget = \theId name val isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + addHtml [HAMLET| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif + addJulius [JULIUS| $(function(){$("#%theId%").datepicker({ dateFormat:'yy-mm-dd', changeMonth:%jsBool.jdsChangeMonth.jds%, @@ -144,24 +144,14 @@ jqueryDayTimeFieldProfile = FieldProfile { fpParse = parseUTCTime , fpRender = jqueryDayTimeUTCTime , fpWidget = \theId name val isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + addHtml [HAMLET| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addScript' urlJqueryUiDateTimePicker addStylesheet' urlJqueryUiCss - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif + addJulius [JULIUS| $(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); |] } @@ -198,23 +188,13 @@ jqueryAutocompleteFieldProfile src = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + addHtml [HAMLET| %input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif + addJulius [JULIUS| $(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); |] } diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index f0a5d7f0..13dffe35 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -12,6 +12,8 @@ module Yesod.Form.Profiles , timeFieldProfile , htmlFieldProfile , emailFieldProfile + , searchFieldProfile + , AutoFocus , urlFieldProfile , doubleFieldProfile , parseDate @@ -22,27 +24,35 @@ module Yesod.Form.Profiles import Yesod.Form.Core import Yesod.Widget import Text.Hamlet +import Text.Cassius import Data.Time (Day, TimeOfDay(..)) import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField) import Text.HTML.SanitizeXSS (sanitizeBalance) +import Control.Monad (when) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (fromWrite4List, writeByteString) import Yesod.Internal (lbsToChars) +#if GHC7 +#define HAMLET hamlet +#define CASSIUS cassius +#define JULIUS julius +#else +#define HAMLET $hamlet +#define CASSIUS $cassius +#define JULIUS $julius +#endif + intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI , fpRender = showI , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ |] } @@ -57,11 +67,7 @@ doubleFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid number") Right . readMay , fpRender = show , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -71,11 +77,7 @@ dayFieldProfile = FieldProfile { fpParse = parseDate , fpRender = show , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ |] } @@ -85,11 +87,7 @@ timeFieldProfile = FieldProfile { fpParse = parseTime , fpRender = show , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!:isReq:required!value=$val$ |] } @@ -99,11 +97,7 @@ htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeBalance , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %textarea.html#$theId$!name=$name$ $val$ |] } @@ -125,11 +119,7 @@ textareaFieldProfile = FieldProfile { fpParse = Right . Textarea , fpRender = unTextarea , fpWidget = \theId name val _isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %textarea#$theId$!name=$name$ $val$ |] } @@ -139,11 +129,7 @@ hiddenFieldProfile = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val _isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input!type=hidden#$theId$!name=$name$!value=$val$ |] } @@ -153,11 +139,7 @@ stringFieldProfile = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ |] } @@ -167,11 +149,7 @@ passwordFieldProfile = FieldProfile { fpParse = Right , fpRender = id , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=password!:isReq:required!value=$val$ |] } @@ -221,15 +199,27 @@ emailFieldProfile = FieldProfile else Left "Invalid e-mail address" , fpRender = id , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ |] } +type AutoFocus = Bool +searchFieldProfile :: AutoFocus -> FieldProfile s y String +searchFieldProfile autoFocus = FieldProfile + { fpParse = Right + , fpRender = id + , fpWidget = \theId name val isReq -> do + addHtml [HAMLET| +%input#$theId$!name=$name$!type=search!:isReq:required!:autoFocus:autofocus!value=$val$ +|] + when autoFocus $ do + addHtml $ [HAMLET| <script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('$theId$').focus();}</script> |] + addCassius [CASSIUS| + #$theId$ -webkit-appearance: textfield; + |] + } + urlFieldProfile :: FieldProfile s y String urlFieldProfile = FieldProfile { fpParse = \s -> case parseURI s of @@ -237,11 +227,7 @@ urlFieldProfile = FieldProfile Just _ -> Right s , fpRender = id , fpWidget = \theId name val isReq -> addHamlet -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif + [HAMLET| %input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ |] } From e6a39365775539a6d14e61b63bbad0c4a008842f Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sat, 11 Dec 2010 00:50:26 -0800 Subject: [PATCH 539/624] fix css --- Yesod/Form/Profiles.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 13dffe35..1dd78255 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -216,7 +216,8 @@ searchFieldProfile autoFocus = FieldProfile when autoFocus $ do addHtml $ [HAMLET| <script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('$theId$').focus();}</script> |] addCassius [CASSIUS| - #$theId$ -webkit-appearance: textfield; + #$theId$ + -webkit-appearance: textfield |] } From 2cc68e8256debe5756ab52b7464259c7a6082323 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 13 Dec 2010 23:20:44 +0200 Subject: [PATCH 540/624] blaze-builder 0.2.1 --- Yesod/Form/Profiles.hs | 5 +++-- Yesod/Json.hs | 3 ++- yesod.cabal | 4 ++-- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 1dd78255..e224e50b 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -33,7 +33,8 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when) import qualified Blaze.ByteString.Builder.Html.Utf8 as B -import Blaze.ByteString.Builder (fromWrite4List, writeByteString) +import Blaze.ByteString.Builder (writeByteString) +import Blaze.ByteString.Builder.Internal.Write (fromWriteList) import Yesod.Internal (lbsToChars) @@ -108,7 +109,7 @@ newtype Textarea = Textarea { unTextarea :: String } deriving (Show, Read, Eq, PersistField) instance ToHtml Textarea where toHtml = - Html . fromWrite4List writeHtmlEscapedChar . unTextarea + Html . fromWriteList writeHtmlEscapedChar . unTextarea where -- Taken from blaze-builder and modified with newline handling. writeHtmlEscapedChar '\n' = writeByteString "<br>" diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 797ad44e..3e96aca3 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -25,6 +25,7 @@ import Numeric (showHex) import Data.Monoid (Monoid (..)) import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 (writeChar) +import Blaze.ByteString.Builder.Internal.Write (fromWriteList) #if TEST import Test.Framework (testGroup, Test) @@ -63,7 +64,7 @@ jsonToRepJson = fmap RepJson . jsonToContent jsonScalar :: String -> Json jsonScalar s = Json $ mconcat [ fromByteString "\"" - , fromWrite4List writeJsonChar s + , fromWriteList writeJsonChar s , fromByteString "\"" ] where diff --git a/yesod.cabal b/yesod.cabal index 0293a2e7..adb34e63 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.6 +version: 0.6.7 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -37,7 +37,7 @@ library , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6.2 && < 0.7 , hamlet >= 0.5.1 && < 0.7 - , blaze-builder >= 0.2 && < 0.3 + , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 , pureMD5 >= 1.1.0.0 && < 2.2 From 676a6aa6c1f427b6ed20fd9f0e5b430bbcbd473e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 16:30:28 +0200 Subject: [PATCH 541/624] enableClientSessions --- Yesod/Dispatch.hs | 43 +++++++++++++++++++++++++++++-------------- Yesod/Yesod.hs | 7 +++++++ yesod.cabal | 2 +- 3 files changed, 37 insertions(+), 15 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 1396d733..afd94551 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,10 +27,10 @@ module Yesod.Dispatch ) where #if TEST -import Yesod.Yesod hiding (testSuite) +import Yesod.Yesod hiding (testSuite, Key) import Yesod.Handler hiding (testSuite) #else -import Yesod.Yesod +import Yesod.Yesod hiding (Key) import Yesod.Handler #endif @@ -236,27 +236,33 @@ sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI -- handler. You can use 'basicHandler' if you wish. toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp a = +toWaiApp a = do + key' <- if enableClientSessions a + then Just `fmap` encryptKey a + else return Nothing return $ gzip $ jsonp $ cleanPathFunc (splitPath a) (B.pack $ approot a) - $ toWaiApp' a + $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) => y + -> Maybe Key -> [String] -> W.Request -> IO W.Response -toWaiApp' y segments env = do - key' <- encryptKey y +toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y let host = if sessionIpAddress y then W.remoteHost env else "" - let session' = fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key' now host val + let session' = + case key' of + Nothing -> [] + Just key'' -> fromMaybe [] $ do + raw <- lookup "Cookie" $ W.requestHeaders env + val <- lookup (B.pack sessionName) $ parseCookies raw + decodeSession key'' now host val let site = getSite method = B.unpack $ W.requestMethod env types = httpAccept env @@ -295,12 +301,21 @@ toWaiApp' y segments env = do let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap - let sessionVal = encodeSession key' exp' host + let sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> + encodeSession key'' exp' host $ Map.toList $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = AddCookie (clientSessionDuration y) sessionName - (bsToChars sessionVal) - : hs + let hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs hs'' = map (headerToPair getExpires) hs' hs''' = ("Content-Type", charsToBs ct) : hs'' return $ W.Response s hs''' c diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 71a0a579..74288fa3 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -109,6 +109,13 @@ class Eq (Route a) => Yesod a where encryptKey :: a -> IO CS.Key encryptKey _ = getKey defaultKeyFile + -- | Whether or not to use client sessions. + -- + -- FIXME: A better API would be to have 'encryptKey' return a Maybe, but + -- that would be a breaking change. Please include in Yesod 0.7. + enableClientSessions :: a -> Bool + enableClientSessions _ = True + -- | Number of minutes before a client session times out. Defaults to -- 120 (2 hours). clientSessionDuration :: a -> Int diff --git a/yesod.cabal b/yesod.cabal index adb34e63..c28800ed 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.7 +version: 0.6.8 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 05fde1f464c3632175fb726b358b48ce578e7a96 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Dec 2010 19:00:30 +0200 Subject: [PATCH 542/624] getBy404 --- Yesod/Yesod.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 74288fa3..1523f7d4 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -15,6 +15,7 @@ module Yesod.Yesod , YesodPersist (..) , module Database.Persist , get404 + , getBy404 -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -392,6 +393,15 @@ get404 key = do Nothing -> lift notFound Just res -> return res +getBy404 :: (PersistBackend (t m), PersistEntity val, Monad (t m), + Failure ErrorResponse m, MonadTrans t) + => Unique val -> t m (Key val, val) +getBy404 ukey = do + mres <- getBy ukey + case mres of + Nothing -> lift notFound + Just res -> return res + -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only From 29c0fb7a2ba2a4b4e99296ad6ab28e2839c65d60 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 17:47:13 +0200 Subject: [PATCH 543/624] monad-peel --- Yesod.hs | 4 ++-- Yesod/Handler.hs | 14 ++------------ Yesod/Widget.hs | 13 ++----------- yesod.cabal | 9 +++++---- 4 files changed, 11 insertions(+), 29 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 948e1b01..25b55099 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -13,7 +13,7 @@ module Yesod , Application , lift , liftIO - , MonadInvertIO + , MonadPeelIO , mempty , showIntegral , readIntegral @@ -41,7 +41,7 @@ import Yesod.Hamlet import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Data.Monoid (mempty) -import Control.Monad.Invert (MonadInvertIO) +import Control.Monad.IO.Peel (MonadPeelIO) showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 608ac2aa..be1740d5 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -112,8 +112,7 @@ import Control.Failure (Failure (failure)) import Text.Hamlet -import Control.Monad.Invert (MonadInvertIO (..)) -import Control.Monad (liftM) +import Control.Monad.IO.Peel (MonadPeelIO) import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8 @@ -210,7 +209,7 @@ newtype GHandler sub master a = GHandler { unGHandler :: GHInner sub master a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) type GHInner s m = ReaderT (HandlerData s m) ( @@ -222,15 +221,6 @@ type GHInner s m = type SessionMap = Map.Map String String -instance MonadInvertIO (GHandler s m) where - newtype InvertedIO (GHandler s m) a = - InvGHandlerIO - { runInvGHandlerIO :: InvertedIO (GHInner s m) a - } - type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ())) - invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler - revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f - type Endo a = a -> a -- | An extension of the basic WAI 'W.Application' datatype to provide extra diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index efff5338..7be74bb9 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -46,7 +46,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal -import Control.Monad.Invert (MonadInvertIO (..)) +import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad (liftM) import qualified Data.Map as Map @@ -54,7 +54,7 @@ import qualified Data.Map as Map -- site datatypes. This is basically a large 'WriterT' stack keeping track of -- dependencies along with a 'StateT' to track unique identifiers. newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) type GWInner sub master = WriterT (Body (Route master)) ( WriterT (Last Title) ( @@ -69,15 +69,6 @@ type GWInner sub master = instance Monoid (GWidget sub master ()) where mempty = return () mappend x y = x >> y -instance MonadInvertIO (GWidget s m) where - newtype InvertedIO (GWidget s m) a = - InvGWidgetIO - { runInvGWidgetIO :: InvertedIO (GWInner s m) a - } - type InvertedArg (GWidget s m) = - (Int, (HandlerData s m, (Map.Map String String, ()))) - invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget - revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f instance HamletValue (GWidget s m ()) where newtype HamletMonad (GWidget s m ()) a = diff --git a/yesod.cabal b/yesod.cabal index c28800ed..ff1d5f72 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.8 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -36,7 +36,7 @@ library , text >= 0.5 && < 0.12 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.5.1 && < 0.7 + , hamlet >= 0.6 && < 0.7 , blaze-builder >= 0.2.1 && < 0.3 , transformers >= 0.2 && < 0.3 , clientsession >= 0.4.0 && < 0.5 @@ -45,8 +45,8 @@ library , cereal >= 0.2 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.3.0 && < 0.4 - , neither >= 0.1.0 && < 0.2 + , persistent >= 0.4 && < 0.5 + , neither >= 0.2 && < 0.3 , network >= 2.2.1.5 && < 2.4 , email-validate >= 0.2.5 && < 0.3 , web-routes >= 0.23 && < 0.24 @@ -54,6 +54,7 @@ library , data-default >= 0.2 && < 0.3 , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 + , monad-peel >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From a6fd8ab18b0ccd7d48d6849124bfcdb15494ddad Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 18:12:55 +0200 Subject: [PATCH 544/624] wai 0.3 --- Yesod/Content.hs | 19 +++++++++++-------- Yesod/Dispatch.hs | 44 +++++++++++++++++++++++++++++++++----------- Yesod/Handler.hs | 5 ++++- Yesod/Json.hs | 1 + yesod.cabal | 5 +++-- 5 files changed, 52 insertions(+), 22 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 7d4d5683..e8fe59b0 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -8,7 +8,7 @@ module Yesod.Content ( -- * Content - Content + Content (..) , emptyContent , ToContent (..) -- * Mime types @@ -57,8 +57,6 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text as T -import qualified Network.Wai as W - import Data.Time import System.Locale @@ -72,11 +70,16 @@ import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) #endif -type Content = W.ResponseBody +import Data.Enumerator (Enumerator) +import Blaze.ByteString.Builder (Builder) + +data Content = ContentLBS L.ByteString + | ContentEnum (forall a. Enumerator Builder IO a) + | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = W.ResponseLBS L.empty +emptyContent = ContentLBS L.empty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -86,13 +89,13 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = W.ResponseLBS . L.fromChunks . return + toContent = ContentLBS . L.fromChunks . return instance ToContent L.ByteString where - toContent = W.ResponseLBS + toContent = ContentLBS instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = ContentLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index afd94551..f95af393 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -43,7 +43,7 @@ import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPathFunc) +import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -75,6 +75,9 @@ import System.Random (randomR, newStdGen) import qualified Data.Map as Map +import Control.Applicative ((<$>)) +import Data.Enumerator (($$), run_) + #if TEST import Test.Framework (testGroup, Test) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -234,15 +237,25 @@ sessionName :: String sessionName = "_SESSION" -- | Convert the given argument into a WAI application, executable with any WAI --- handler. You can use 'basicHandler' if you wish. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp a = do +-- handler. This is the same as 'toWaiAppPlain', except it includes three +-- middlewares: GZIP compression, JSON-P and path cleaning. This is the +-- recommended approach for most users. +toWaiApp :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiApp y = do + a <- toWaiAppPlain y + return $ gzip False + $ jsonp + a + +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. This differs from 'toWaiApp' in that it only uses the cleanpath +-- middleware. +toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiAppPlain a = do key' <- if enableClientSessions a then Just `fmap` encryptKey a else return Nothing - return $ gzip - $ jsonp - $ cleanPathFunc (splitPath a) (B.pack $ approot a) + return $ cleanPath (splitPath a) (B.pack $ approot a) $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) @@ -250,7 +263,7 @@ toWaiApp' :: (Yesod y, YesodSite y) -> Maybe Key -> [String] -> W.Request - -> IO W.Response + -> IO (W.Response a) toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now @@ -318,7 +331,12 @@ toWaiApp' y key' segments env = do : hs hs'' = map (headerToPair getExpires) hs' hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ W.Response s hs''' c + return $ + case c of + ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentFile fp -> W.ResponseFile s hs''' fp + ContentEnum e -> W.ResponseEnumerator $ \iter -> + run_ $ e $$ iter s hs''' httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack @@ -399,8 +417,12 @@ nonceKey :: String nonceKey = "_NONCE" rbHelper :: W.Request -> IO RequestBodyContents -rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (bsToChars *** bsToChars) +rbHelper req = + (map fix1 *** map fix2) <$> run_ (enum $$ iter) + where + enum = W.requestBody req + iter = parseRequestBody lbsSink req + fix1 = bsToChars *** bsToChars fix2 (x, NWP.FileInfo a b c) = (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index be1740d5..7bb01d74 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -311,7 +311,7 @@ runHandler handler mrender sroute tomr ma tosa = let hs' = headers hs return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = - return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) + return (W.status200, headers [], ct, ContentFile fp, finalSession) case contents of HCContent status a -> do (ct, c) <- chooseRep a cts @@ -559,3 +559,6 @@ testSuite = testGroup "Yesod.Handler" ] #endif + +-- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status +-- and header stuff diff --git a/Yesod/Json.hs b/Yesod/Json.hs index 3e96aca3..bd22f66e 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -1,4 +1,5 @@ -- | Efficient generation of JSON documents. +-- FIXME remove this module, possibly make a blaze-json {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/yesod.cabal b/yesod.cabal index ff1d5f72..6276a1d3 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -29,8 +29,8 @@ library else build-depends: base >= 4 && < 4.3 build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.2.0 && < 0.3 - , wai-extra >= 0.2.4 && < 0.3 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 @@ -55,6 +55,7 @@ library , failure >= 0.1 && < 0.2 , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 + , enumerator >= 0.4 && < 0.5 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From dc25a66d5b49be5f319d07a8f6d9ee663bc430fd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 20:30:26 +0200 Subject: [PATCH 545/624] Removed type variable on Response et al --- Yesod/Dispatch.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f95af393..bc508a39 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -240,7 +240,7 @@ sessionName = "_SESSION" -- handler. This is the same as 'toWaiAppPlain', except it includes three -- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- recommended approach for most users. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiApp y = do a <- toWaiAppPlain y return $ gzip False @@ -250,7 +250,7 @@ toWaiApp y = do -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it only uses the cleanpath -- middleware. -toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO (W.Application a) +toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain a = do key' <- if enableClientSessions a then Just `fmap` encryptKey a @@ -263,7 +263,7 @@ toWaiApp' :: (Yesod y, YesodSite y) -> Maybe Key -> [String] -> W.Request - -> IO (W.Response a) + -> IO W.Response toWaiApp' y key' segments env = do now <- getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now From 13d6d9e593109d0ffe639446efb62f52e4bf2c7a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 21:38:01 +0200 Subject: [PATCH 546/624] Full support for ResponseEnumerator --- Yesod/Dispatch.hs | 51 +++++++++++++++++++++-------------------- Yesod/Handler.hs | 58 +++++++++++++++++++++++++++++++++-------------- 2 files changed, 68 insertions(+), 41 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index bc508a39..27847cfc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -313,30 +313,33 @@ toWaiApp' y key' segments env = do let ya = runHandler h render eurl' id y id let sessionMap = Map.fromList $ filter (\(x, _) -> x /= nonceKey) session' - (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentLBS lbs -> W.ResponseLBS s hs''' lbs - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' + yar <- unYesodApp ya eh rr types sessionMap + case yar of + YARPlain s hs ct c sessionFinal -> do + let sessionVal = + case key' of + Nothing -> B.empty + Just key'' -> + encodeSession key'' exp' host + $ Map.toList + $ Map.insert nonceKey (reqNonce rr) sessionFinal + let hs' = + case key' of + Nothing -> hs + Just _ -> AddCookie + (clientSessionDuration y) + sessionName + (bsToChars sessionVal) + : hs + hs'' = map (headerToPair getExpires) hs' + hs''' = ("Content-Type", charsToBs ct) : hs'' + return $ + case c of + ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentFile fp -> W.ResponseFile s hs''' fp + ContentEnum e -> W.ResponseEnumerator $ \iter -> + run_ $ e $$ iter s hs''' + YAREnum e -> return $ W.ResponseEnumerator e httpAccept :: W.Request -> [ContentType] httpAccept = map B.unpack diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 7bb01d74..1420a8f4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -51,6 +51,7 @@ module Yesod.Handler , sendResponse , sendResponseStatus , sendResponseCreated + , sendResponseEnumerator -- * Setting headers , setCookie , deleteCookie @@ -85,6 +86,7 @@ module Yesod.Handler , localNoCurrent , HandlerData , ErrorResponse (..) + , YesodAppResult (..) #if TEST , testSuite #endif @@ -232,15 +234,20 @@ newtype YesodApp = YesodApp -> Request -> [ContentType] -> SessionMap - -> IO (W.Status, [Header], ContentType, Content, SessionMap) + -> IO YesodAppResult } +data YesodAppResult + = YAREnum (forall a. W.ResponseEnumerator a) + | YARPlain W.Status [Header] ContentType Content SessionMap + data HandlerContents = HCContent W.Status ChooseRep | HCError ErrorResponse | HCSendFile ContentType FilePath | HCRedirect RedirectType String | HCCreated String + | HCEnum (forall a. W.ResponseEnumerator a) instance Failure ErrorResponse (GHandler sub master) where failure = GHandler . lift . throwMEither . HCError @@ -307,34 +314,46 @@ runHandler handler mrender sroute tomr ma tosa = ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) let contents = meither id (HCContent W.status200 . chooseRep) contents' let handleError e = do - (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession - let hs' = headers hs - return (getStatus e, hs', ct, c, sess) + yar <- unYesodApp (eh e) safeEh rr cts finalSession + case yar of + YARPlain _ hs ct c sess -> + let hs' = headers hs + in return $ YARPlain (getStatus e) hs' ct c sess + YAREnum _ -> return yar let sendFile' ct fp = - return (W.status200, headers [], ct, ContentFile fp, finalSession) + return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession case contents of HCContent status a -> do (ct, c) <- chooseRep a cts - return (status, headers [], ct, c, finalSession) + return $ YARPlain status (headers []) ct c finalSession HCError e -> handleError e HCRedirect rt loc -> do let hs = Header "Location" loc : headers [] - return (getRedirectStatus rt, hs, typePlain, emptyContent, - finalSession) + return $ YARPlain + (getRedirectStatus rt) hs typePlain emptyContent + finalSession HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler) - HCCreated loc -> do + HCCreated loc -> do -- FIXME add status201 to WAI let hs = Header "Location" loc : headers [] - return (W.Status 201 (S8.pack "Created"), hs, typePlain, - emptyContent, - finalSession) + return $ YARPlain + (W.Status 201 (S8.pack "Created")) + hs + typePlain + emptyContent + finalSession + HCEnum e -> return $ YAREnum e safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.status500, [], typePlain, toContent "Internal Server Error", - session) + return $ YARPlain + W.status500 + [] + typePlain + (toContent "Internal Server Error") + session -- | Redirect to the given route. redirect :: RedirectType -> Route master -> GHandler sub master a @@ -439,6 +458,14 @@ sendResponseCreated url = do r <- getUrlRender GHandler $ lift $ throwMEither $ HCCreated $ r url +-- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely +-- necessary, and will /disregard/ any changes to response headers and session +-- that you have already specified. This function short-circuits. It should be +-- considered only for they specific needs. If you are not sure if you need it, +-- you don't. +sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b +sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum + -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound @@ -559,6 +586,3 @@ testSuite = testGroup "Yesod.Handler" ] #endif - --- FIXME add a sendEnum that uses a ResponseEnumerator and bypasses all status --- and header stuff From 091aa6c52d505d2916531f8d10e53f39942ef2d5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 16 Dec 2010 22:05:54 +0200 Subject: [PATCH 547/624] Removed Yesod.Form hierarchy All of this code will be included in a separate yesod-form package to allow for more flexibility in API changes, plus to make it more natural to swap in other packages such as digestive-functors. --- Yesod.hs | 2 - Yesod/Form.hs | 341 ---------------------------------- Yesod/Form/Class.hs | 61 ------ Yesod/Form/Core.hs | 369 ------------------------------------- Yesod/Form/Fields.hs | 409 ----------------------------------------- Yesod/Form/Jquery.hs | 235 ----------------------- Yesod/Form/Nic.hs | 61 ------ Yesod/Form/Profiles.hs | 235 ----------------------- Yesod/Helpers/Crud.hs | 208 --------------------- Yesod/Widget.hs | 4 +- hellowidget.hs | 161 ---------------- yesod.cabal | 10 +- 12 files changed, 2 insertions(+), 2094 deletions(-) delete mode 100644 Yesod/Form.hs delete mode 100644 Yesod/Form/Class.hs delete mode 100644 Yesod/Form/Core.hs delete mode 100644 Yesod/Form/Fields.hs delete mode 100644 Yesod/Form/Jquery.hs delete mode 100644 Yesod/Form/Nic.hs delete mode 100644 Yesod/Form/Profiles.hs delete mode 100644 Yesod/Helpers/Crud.hs delete mode 100644 hellowidget.hs diff --git a/Yesod.hs b/Yesod.hs index 25b55099..f3be2aa7 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -6,7 +6,6 @@ module Yesod , module Yesod.Yesod , module Yesod.Handler , module Yesod.Dispatch - , module Yesod.Form , module Yesod.Hamlet , module Yesod.Json , module Yesod.Widget @@ -34,7 +33,6 @@ import Yesod.Handler hiding (runHandler) #endif import Yesod.Request -import Yesod.Form import Yesod.Widget import Network.Wai (Application) import Yesod.Hamlet diff --git a/Yesod/Form.hs b/Yesod/Form.hs deleted file mode 100644 index 9d9d054d..00000000 --- a/Yesod/Form.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Parse forms (and query strings). -module Yesod.Form - ( -- * Data types - GForm - , FormResult (..) - , Enctype (..) - , FormFieldSettings (..) - , Textarea (..) - , FieldInfo (..) - -- ** Utilities - , formFailures - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Unwrapping functions - , generateForm - , runFormGet - , runFormMonadGet - , runFormPost - , runFormPostNoNonce - , runFormMonadPost - , runFormGet' - , runFormPost' - -- ** High-level form post unwrappers - , runFormTable - , runFormDivs - -- * Field/form helpers - , fieldsToTable - , fieldsToDivs - , fieldsToPlain - , checkForm - -- * Type classes - , module Yesod.Form.Class - -- * Template Haskell - , mkToForm - , module Yesod.Form.Fields - ) where - -import Yesod.Form.Core -import Yesod.Form.Fields -import Yesod.Form.Class -import Yesod.Form.Profiles (Textarea (..)) -import Yesod.Widget (GWidget) - -import Text.Hamlet -import Yesod.Request -import Yesod.Handler -import Control.Applicative hiding (optional) -import Data.Maybe (fromMaybe, mapMaybe) -import "transformers" Control.Monad.IO.Class -import Control.Monad ((<=<)) -import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) -import Data.Char (toUpper, isUpper) -import Control.Arrow ((&&&)) -import Data.List (group, sort) - --- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: FormField sub y a -> Form sub y a -fieldsToPlain = mapFormXml $ mapM_ fiInput - --- | Display the label, tooltip, input code and errors in a single row of a --- table. -fieldsToTable :: FormField sub y a -> Form sub y a -fieldsToTable = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%tr.$clazz.fi$ - %td - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - %td - ^fiInput.fi^ - $maybe fiErrors.fi err - %td.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Display the label, tooltip, input code and errors in a single div. -fieldsToDivs :: FormField sub y a -> Form sub y a -fieldsToDivs = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -.$clazz.fi$ - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - ^fiInput.fi^ - $maybe fiErrors.fi err - %div.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Run a form against POST parameters, without CSRF protection. -runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormPostNoNonce f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters. --- --- This function includes CSRF protection by checking a nonce value. You must --- therefore embed this nonce in the form as a hidden field; that is the --- meaning of the fourth element in the tuple. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) -runFormPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - nonce <- fmap reqNonce getRequest - (res, xml, enctype) <- runFormGeneric pp files f - let res' = - case res of - FormSuccess x -> - if lookup nonceName pp == Just nonce - then FormSuccess x - else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] - _ -> res - return (res', xml, enctype, hidden nonce) - where - hidden nonce = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|] - -nonceName :: String -nonceName = "_nonce" - --- | Run a form against POST parameters. Please note that this does not provide --- CSRF protection. -runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters, disregarding the resulting HTML and --- returning an error response on invalid input. Note: this does /not/ perform --- CSRF protection. -runFormPost' :: GForm sub y xml a -> GHandler sub y a -runFormPost' f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - x <- runFormGeneric pp files f - helper x - --- | Create a table-styled form. --- --- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of --- some of the boiler-plate in creating forms. In particular, is automatically --- creates the form element, sets the method, action and enctype attributes, --- adds the CSRF-protection nonce hidden field and inserts a submit button. -runFormTable :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormTable dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - %table - ^widget^ - %tr - %td!colspan=2 - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. -runFormDivs :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormDivs dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - ^widget^ - %div - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Run a form against GET parameters, disregarding the resulting HTML and --- returning an error response on invalid input. -runFormGet' :: GForm sub y xml a -> GHandler sub y a -runFormGet' = helper <=< runFormGet - -helper :: (FormResult a, b, c) -> GHandler sub y a -helper (FormSuccess a, _, _) = return a -helper (FormFailure e, _, _) = invalidArgs e -helper (FormMissing, _, _) = invalidArgs ["No input found"] - --- | Generate a form, feeding it no data. The third element in the result tuple --- is a nonce hidden field. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) -generateForm f = do - (_, b, c) <- runFormGeneric [] [] f - nonce <- fmap reqNonce getRequest - return (b, c, -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|]) - --- | Run a form against GET parameters. -runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - -runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - --- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: PersistEntity v => v -> Q [Dec] -mkToForm = - fmap return . derive . entityDef - where - afterPeriod s = - case dropWhile (/= '.') s of - ('.':t) -> t - _ -> s - beforePeriod s = - case break (== '.') s of - (t, '.':_) -> Just t - _ -> Nothing - getSuperclass (_, _, z) = getTFF' z >>= beforePeriod - getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z - getTFF' [] = Nothing - getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x - getTFF' (_:x) = getTFF' x - getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z - getLabel' [] = Nothing - getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x - getLabel' (_:x) = getLabel' x - getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z - getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x - getTooltip' (_:x) = getTooltip' x - getTooltip' [] = Nothing - getId (_, _, z) = fromMaybe "" $ getId' z - getId' (('i':'d':'=':x):_) = Just x - getId' (_:x) = getId' x - getId' [] = Nothing - getName (_, _, z) = fromMaybe "" $ getName' z - getName' (('n':'a':'m':'e':'=':x):_) = Just x - getName' (_:x) = getName' x - getName' [] = Nothing - derive :: EntityDef -> Q Dec - derive t = do - let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t - ap <- [|(<*>)|] - just <- [|pure|] - nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ entityName t) - string' <- [|string|] - ftt <- [|fieldsToTable|] - ffs' <- [|FormFieldSettings|] - let stm "" = nothing - stm x = just `AppE` LitE (StringL x) - let go_ = go ap just' ffs' stm string' ftt - let c1 = Clause [ ConP (mkName "Nothing") [] - ] - (NormalB $ go_ $ zip cols $ map (const nothing) cols) - [] - xs <- mapM (const $ newName "x") cols - let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) - $ map VarP xs]] - (NormalB $ go_ $ zip cols xs') - [] - let y = mkName "y" - let ctx = map (\x -> ClassP (mkName x) [VarT y]) - $ map head $ group $ sort - $ mapMaybe getSuperclass - $ entityColumns t - return $ InstanceD ctx ( ConT ''ToForm - `AppT` ConT (mkName $ entityName t) - `AppT` VarT y) - [FunD (mkName "toForm") [c1, c2]] - go ap just' ffs' stm string' ftt a = - let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a - in ftt `AppE` x - go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = - let label' = LitE $ StringL label - tooltip' = string' `AppE` LitE (StringL tooltip) - ffs = ffs' `AppE` - label' `AppE` - tooltip' `AppE` - (stm theId) `AppE` - (stm name) - in VarE (mkName tff) `AppE` ffs `AppE` ex - ap' ap x y = InfixE (Just x) ap (Just y) - -toLabel :: String -> String -toLabel "" = "" -toLabel (x:rest) = toUpper x : go rest - where - go "" = "" - go (c:cs) - | isUpper c = ' ' : c : go cs - | otherwise = c : go cs - -formFailures :: FormResult a -> Maybe [String] -formFailures (FormFailure x) = Just x -formFailures _ = Nothing diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs deleted file mode 100644 index 290b15d7..00000000 --- a/Yesod/Form/Class.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Form.Class - ( ToForm (..) - , ToFormField (..) - ) where - -import Text.Hamlet -import Yesod.Form.Fields -import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea) -import Data.Int (Int64) -import Data.Time (Day, TimeOfDay) - -class ToForm a y where - toForm :: Formlet sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> FormletField sub y a - -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField - -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -instance ToFormField Bool y where - toFormField = boolField - -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -instance ToFormField Textarea y where - toFormField = textareaField -instance ToFormField (Maybe Textarea) y where - toFormField = maybeTextareaField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs deleted file mode 100644 index be5fcbe0..00000000 --- a/Yesod/Form/Core.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | Users of the forms library should not need to use this module in general. --- It is intended only for writing custom forms and form fields. -module Yesod.Form.Core - ( FormResult (..) - , GForm (..) - , newFormIdent - , deeperFormIdent - , shallowerFormIdent - , Env - , FileEnv - , Enctype (..) - , Ints (..) - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml - , checkForm - , checkField - , askParams - , askFiles - , liftForm - , IsForm (..) - , RunForm (..) - , GFormMonad - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - , FieldProfile (..) - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - ) where - -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Class (lift) -import Yesod.Handler -import Yesod.Widget -import Data.Monoid (Monoid (..)) -import Control.Applicative -import Yesod.Request -import Control.Monad (liftM) -import Text.Hamlet -import Data.String -import Control.Monad (join) - --- | A form can produce three different results: there was no data available, --- the data was invalid, or there was a successful parse. --- --- The 'Applicative' instance will concatenate the failure messages in two --- 'FormResult's. -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart - deriving (Eq, Enum, Bounded) -instance ToHtml Enctype where - toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" - toHtml Multipart = unsafeByteString "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ '-' : show is - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm s m xml a = GForm - { deform :: FormInner s m (FormResult a, xml, Enctype) - } - -type GFormMonad s m a = WriterT Enctype (FormInner s m) a - -type FormInner s m = - StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - GHandler s m - ))) - -type Env = [(String, String)] -type FileEnv = [(String, FileInfo)] - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ liftM (first3 $ fmap f) g - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ do - (f1, f2, f3) <- f - (g1, g2, g3) <- g - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper - :: IsForm f - => FieldProfile (FormSub f) (FormMaster f) (FormType f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -class IsForm f where - type FormSub f - type FormMaster f - type FormType f - toForm :: FormInner - (FormSub f) - (FormMaster f) - (FormResult (FormType f), - FieldInfo (FormSub f) (FormMaster f), - Enctype) -> f -instance IsForm (FormField s m a) where - type FormSub (FormField s m a) = s - type FormMaster (FormField s m a) = m - type FormType (FormField s m a) = a - toForm x = GForm $ do - (a, b, c) <- x - return (a, [b], c) -instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where - type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s - type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m - type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a - toForm x = do - (res, fi, enctype) <- lift x - tell enctype - return (res, fi) - -class RunForm f where - type RunFormSub f - type RunFormMaster f - type RunFormType f - runFormGeneric :: Env -> FileEnv -> f - -> GHandler (RunFormSub f) - (RunFormMaster f) - (RunFormType f) - -instance RunForm (GForm s m xml a) where - type RunFormSub (GForm s m xml a) = s - type RunFormMaster (GForm s m xml a) = m - type RunFormType (GForm s m xml a) = - (FormResult a, xml, Enctype) - runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe - -instance RunForm (GFormMonad s m a) where - type RunFormSub (GFormMonad s m a) = s - type RunFormMaster (GFormMonad s m a) = m - type RunFormType (GFormMonad s m a) = (a, Enctype) - runFormGeneric e fe f = - runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper - :: (IsForm f, Maybe b ~ FormType f) - => FieldProfile (FormSub f) (FormMaster f) b - -> FormFieldSettings - -> Maybe (Maybe b) - -> f -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val False - , fiErrors = case res of - FormFailure x -> Just $ string $ unlines x - _ -> Nothing - , fiRequired = False - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ do - (res, xml, enc) <- g - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - , fiRequired :: Bool - } - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: String - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings s mempty Nothing Nothing - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - -- | ID, name, value, required - , fpWidget :: String -> String -> String -> Bool -> GWidget sub y () - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Add a validation check to a form. --- --- Note that if there is a validation error, this message will /not/ --- automatically appear on the form; for that, you need to use 'checkField'. -checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b -checkForm f (GForm form) = GForm $ do - (res, xml, enc) <- form - let res' = case res of - FormSuccess a -> f a - FormFailure e -> FormFailure e - FormMissing -> FormMissing - return (res', xml, enc) - --- | Add a validation check to a 'FormField'. --- --- Unlike 'checkForm', the validation error will appear in the generated HTML --- of the form. -checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b -checkField f (GForm form) = GForm $ do - (res, xml, enc) <- form - let (res', merr) = - case res of - FormSuccess a -> - case f a of - Left e -> (FormFailure [e], Just e) - Right x -> (FormSuccess x, Nothing) - FormFailure e -> (FormFailure e, Nothing) - FormMissing -> (FormMissing, Nothing) - let xml' = - case merr of - Nothing -> xml - Just err -> flip map xml $ \fi -> fi - { fiErrors = Just $ - case fiErrors fi of - Nothing -> string err - Just x -> x - } - return (res', xml', enc) - -askParams :: Monad m => StateT Ints (ReaderT Env m) Env -askParams = lift ask - -askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv -askFiles = lift $ lift ask - -liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a -liftForm = lift . lift . lift diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs deleted file mode 100644 index ad3fb22a..00000000 --- a/Yesod/Form/Fields.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Fields - ( -- * Fields - -- ** Required - stringField - , passwordField - , textareaField - , hiddenField - , intField - , doubleField - , dayField - , timeField - , htmlField - , selectField - , boolField - , emailField - , searchField - , urlField - , fileField - -- ** Optional - , maybeStringField - , maybePasswordField - , maybeTextareaField - , maybeHiddenField - , maybeIntField - , maybeDoubleField - , maybeDayField - , maybeTimeField - , maybeHtmlField - , maybeSelectField - , maybeEmailField - , maybeSearchField - , maybeUrlField - , maybeFileField - -- * Inputs - -- ** Required - , stringInput - , intInput - , boolInput - , dayInput - , emailInput - , urlInput - -- ** Optional - , maybeStringInput - , maybeDayInput - , maybeIntInput - ) where - -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Request (FileInfo) -import Yesod.Widget (GWidget) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Time (Day, TimeOfDay) -import Text.Hamlet -import Data.Monoid -import Control.Monad (join) -import Data.Maybe (fromMaybe) - -stringField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybePasswordField = optionalFieldHelper passwordFieldProfile - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i) -maybeIntInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: (Integral (FormType f), IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeIntField = optionalFieldHelper intFieldProfile - -doubleField :: (IsForm f, FormType f ~ Double) - => FormFieldSettings -> Maybe Double -> f -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) - => FormFieldSettings -> Maybe (Maybe Double) -> f -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -dayField :: (IsForm f, FormType f ~ Day) - => FormFieldSettings -> Maybe Day -> f -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: (IsForm f, FormType f ~ Maybe Day) - => FormFieldSettings -> Maybe (Maybe Day) -> f -maybeDayField = optionalFieldHelper dayFieldProfile - -timeField :: (IsForm f, FormType f ~ TimeOfDay) - => FormFieldSettings -> Maybe TimeOfDay -> f -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) - => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f -maybeTimeField = optionalFieldHelper timeFieldProfile - -boolField :: (IsForm f, FormType f ~ Bool) - => FormFieldSettings -> Maybe Bool -> f -boolField ffs orig = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just "" -> (FormSuccess False, False) - Just "false" -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=checkbox!name=$name$!:val:checked -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -htmlField :: (IsForm f, FormType f ~ Html) - => FormFieldSettings -> Maybe Html -> f -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) - => FormFieldSettings -> Maybe (Maybe Html) -> f -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -selectField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, String)] - -> FormFieldSettings - -> Maybe x - -> f -selectField pairs ffs initial = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, String)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeSelectField pairs ffs initial' = toForm $ do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ do - env <- askParams - let res = case lookup n env of - Nothing -> FormSuccess False - Just "" -> FormSuccess False - Just "false" -> FormSuccess False - Just _ -> FormSuccess True - let xml = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input#$n$!type=checkbox!name=$n$ -|] - return (res, [xml], UrlEncoded) - -dayInput :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -searchField :: (IsForm f, FormType f ~ String) - => AutoFocus -> FormFieldSettings -> Maybe String -> f -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField :: (IsForm f, FormType f ~ Maybe String) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f -maybeSearchField = optionalFieldHelper . searchFieldProfile - -textareaField :: (IsForm f, FormType f ~ Textarea) - => FormFieldSettings -> Maybe Textarea -> f -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeHiddenField = optionalFieldHelper hiddenFieldProfile - -fileField :: (IsForm f, FormType f ~ FileInfo) - => FormFieldSettings -> f -fileField ffs = toForm $ do - env <- lift ask - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = - if null env && null fenv - then FormMissing - else case lookup name fenv of - Nothing -> FormFailure ["File is required"] - Just x -> FormSuccess x - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, Multipart) - -maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) - => FormFieldSettings -> f -maybeFileField ffs = toForm $ do - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = FormSuccess $ lookup name fenv - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: String -> String -> Bool -> GWidget s m () -fileWidget theId name isReq = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=file!name=$name$!:isReq:required -|] diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs deleted file mode 100644 index d527bcd0..00000000 --- a/Yesod/Form/Jquery.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Some fields spiced up with jQuery UI. -module Yesod.Form.Jquery - ( YesodJquery (..) - , jqueryDayField - , maybeJqueryDayField - , jqueryDayTimeField - , jqueryDayTimeFieldProfile - , jqueryAutocompleteField - , maybeJqueryAutocompleteField - , jqueryDayFieldProfile - , googleHostedJqueryUiCss - , JqueryDaySettings (..) - , Default (..) - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Widget -import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, - timeToTimeOfDay) -import Yesod.Hamlet -import Data.Char (isSpace) -import Data.Default - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - --- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. -googleHostedJqueryUiCss :: String -> String -googleHostedJqueryUiCss theme = concat - [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" - , theme - , "/jquery-ui.css" - ] - -class YesodJquery a where - -- | The jQuery 1.4 Javascript file. - urlJqueryJs :: a -> Either (Route a) String - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js" - - -- | The jQuery UI 1.8 Javascript file. - urlJqueryUiJs :: a -> Either (Route a) String - urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" - - -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. - urlJqueryUiCss :: a -> Either (Route a) String - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) String - urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" - -jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile - -maybeJqueryDayField - :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile - -jqueryDayFieldProfile :: YesodJquery y - => JqueryDaySettings -> FieldProfile sub y Day -jqueryDayFieldProfile jds = FieldProfile - { fpParse = maybe - (Left "Invalid day, must be in YYYY-MM-DD format") - Right - . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datepicker({ - dateFormat:'yy-mm-dd', - changeMonth:%jsBool.jdsChangeMonth.jds%, - changeYear:%jsBool.jdsChangeYear.jds%, - numberOfMonths:%mos.jdsNumberOfMonths.jds%, - yearRange:"%jdsYearRange.jds%" -})}); -|] - } - where - jsBool True = "true" - jsBool False = "false" - mos (Left i) = show i - mos (Right (x, y)) = concat - [ "[" - , show x - , "," - , show y - , "]" - ] - -ifRight :: Either a b -> (b -> c) -> Either a c -ifRight e f = case e of - Left l -> Left l - Right r -> Right $ f r - -showLeadingZero :: (Show a) => a -> String -showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t - -jqueryDayTimeField - :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) - => FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile - --- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) -jqueryDayTimeUTCTime :: UTCTime -> String -jqueryDayTimeUTCTime (UTCTime day utcTime) = - let timeOfDay = timeToTimeOfDay utcTime - in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay - where - showTimeOfDay (TimeOfDay hour minute _) = - let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") - in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm - -jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime -jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime - , fpRender = jqueryDayTimeUTCTime - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addScript' urlJqueryUiDateTimePicker - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); -|] - } - -parseUTCTime :: String -> Either String UTCTime -parseUTCTime s = - let (dateS, timeS) = break isSpace (dropWhile isSpace s) - dateE = parseDate dateS - in case dateE of - Left l -> Left l - Right date -> - ifRight (parseTime timeS) - (UTCTime date . timeOfDayToTime) - -jqueryAutocompleteField - :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String -jqueryAutocompleteFieldProfile src = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () -addStylesheet' f = do - y <- liftHandler getYesod - addStylesheetEither $ f y - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -data JqueryDaySettings = JqueryDaySettings - { jdsChangeMonth :: Bool - , jdsChangeYear :: Bool - , jdsYearRange :: String - , jdsNumberOfMonths :: Either Int (Int, Int) - } - -instance Default JqueryDaySettings where - def = JqueryDaySettings - { jdsChangeMonth = False - , jdsChangeYear = False - , jdsYearRange = "c-10:c+10" - , jdsNumberOfMonths = Left 1 - } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs deleted file mode 100644 index 66447a4a..00000000 --- a/Yesod/Form/Nic.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Provide the user with a rich text editor. -module Yesod.Form.Nic - ( YesodNic (..) - , nicHtmlField - , maybeNicHtmlField - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Hamlet -import Yesod.Widget -import Text.HTML.SanitizeXSS (sanitizeBalance) - -import Yesod.Internal (lbsToChars) - -class YesodNic a where - -- | NIC Editor Javascript file. - urlNicEdit :: a -> Either (Route a) String - urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" - -nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe Html -> f -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile - -maybeNicHtmlField - :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile - -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html -nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %textarea.html#$theId$!name=$name$ $val$ -|] - addScript' urlNicEdit - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif -bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs deleted file mode 100644 index e224e50b..00000000 --- a/Yesod/Form/Profiles.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Profiles - ( stringFieldProfile - , passwordFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , searchFieldProfile - , AutoFocus - , urlFieldProfile - , doubleFieldProfile - , parseDate - , parseTime - , Textarea (..) - ) where - -import Yesod.Form.Core -import Yesod.Widget -import Text.Hamlet -import Text.Cassius -import Data.Time (Day, TimeOfDay(..)) -import qualified Text.Email.Validate as Email -import Network.URI (parseURI) -import Database.Persist (PersistField) -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Control.Monad (when) - -import qualified Blaze.ByteString.Builder.Html.Utf8 as B -import Blaze.ByteString.Builder (writeByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -import Yesod.Internal (lbsToChars) - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI - , fpRender = showI - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - } - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - } - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea.html#$theId$!name=$name$ $val$ -|] - } - --- | A newtype wrapper around a 'String' that converts newlines to HTML --- br-tags. -newtype Textarea = Textarea { unTextarea :: String } - deriving (Show, Read, Eq, PersistField) -instance ToHtml Textarea where - toHtml = - Html . fromWriteList writeHtmlEscapedChar . unTextarea - where - -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '\n' = writeByteString "<br>" - writeHtmlEscapedChar c = B.writeHtmlEscapedChar c - -textareaFieldProfile :: FieldProfile sub y Textarea -textareaFieldProfile = FieldProfile - { fpParse = Right . Textarea - , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea#$theId$!name=$name$ $val$ -|] - } - -hiddenFieldProfile :: FieldProfile sub y String -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%input!type=hidden#$theId$!name=$name$!value=$val$ -|] - } - -stringFieldProfile :: FieldProfile sub y String -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -passwordFieldProfile :: FieldProfile s m String -passwordFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=password!:isReq:required!value=$val$ -|] - } - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either String TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = - parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = - let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 - in parseTimeHelper (h1', h2', m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper (h1, h2, m1, m2, s1, s2) -parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -emailFieldProfile :: FieldProfile s y String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid s - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ -|] - } - -type AutoFocus = Bool -searchFieldProfile :: AutoFocus -> FieldProfile s y String -searchFieldProfile autoFocus = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=search!:isReq:required!:autoFocus:autofocus!value=$val$ -|] - when autoFocus $ do - addHtml $ [HAMLET| <script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('$theId$').focus();}</script> |] - addCassius [CASSIUS| - #$theId$ - -webkit-appearance: textfield - |] - } - -urlFieldProfile :: FieldProfile s y String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ -|] - } diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs deleted file mode 100644 index 7690da70..00000000 --- a/Yesod/Helpers/Crud.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Yesod.Helpers.Crud - ( Item (..) - , Crud (..) - , CrudRoute (..) - , defaultCrud - ) where - -import Yesod.Yesod -import Yesod.Widget -import Yesod.Dispatch -import Yesod.Content -import Yesod.Handler -import Text.Hamlet -import Yesod.Form -import Language.Haskell.TH.Syntax - --- | An entity which can be displayed by the Crud subsite. -class Item a where - -- | The title of an entity, to be displayed in the list of all entities. - itemTitle :: a -> String - --- | Defines all of the CRUD operations (Create, Read, Update, Delete) --- necessary to implement this subsite. When using the "Yesod.Form" module and --- 'ToForm' typeclass, you can probably just use 'defaultCrud'. -data Crud master item = Crud - { crudSelect :: GHandler (Crud master item) master [(Key item, item)] - , crudReplace :: Key item -> item -> GHandler (Crud master item) master () - , crudInsert :: item -> GHandler (Crud master item) master (Key item) - , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) - , crudDelete :: Key item -> GHandler (Crud master item) master () - } - -mkYesodSub "Crud master item" - [ ClassP ''Yesod [VarT $ mkName "master"] - , ClassP ''Item [VarT $ mkName "item"] - , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] - , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] - ] -#if GHC7 - [parseRoutes| -#else - [$parseRoutes| -#endif -/ CrudListR GET -/add CrudAddR GET POST -/edit/#String CrudEditR GET POST -/delete/#String CrudDeleteR GET POST -|] - -getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) - => GHandler (Crud master item) master RepHtml -getCrudListR = do - items <- getYesodSub >>= crudSelect - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Items" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Items -%ul - $forall items item - %li - %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ - $itemTitle.snd.item$ -%p - %a!href=@toMaster.CrudAddR@ Add new item -|] - -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -getCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - False - -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -postCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - True - -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -getCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - False - -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -postCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - True - -getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -getCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Confirm delete" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@toMaster.CrudDeleteR.s@ - %h1 Really delete? - %p Do you really want to delete $itemTitle.item$? - %p - %input!type=submit!value=Yes - \ $ - %a!href=@toMaster.CrudListR@ No -|] - -postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -postCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - toMaster <- getRouteToMaster - crudDelete crud itemId - redirect RedirectTemporary $ toMaster CrudListR - -itemReadId :: SinglePiece x => String -> Maybe x -itemReadId = either (const Nothing) Just . fromSinglePiece - -crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) - => String -> Maybe (Key a, a) -> Bool - -> GHandler (Crud master a) master RepHtml -crudHelper title me isPost = do - crud <- getYesodSub - (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me - toMaster <- getRouteToMaster - case (isPost, errs) of - (True, FormSuccess a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - _ -> return () - defaultLayout $ do - setTitle $ string title - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%p - %a!href=@toMaster.CrudListR@ Return to list -%h1 $title$ -%form!method=post!enctype=$enctype$ - %table - ^form^ - %tr - %td!colspan=2 - $hidden$ - %input!type=submit - $maybe me e - \ $ - %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete -|] - --- | A default 'Crud' value which relies about persistent and "Yesod.Form". -defaultCrud - :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)), - YesodPersist a) - => a -> Crud a i -defaultCrud = const Crud - { crudSelect = runDB $ selectList [] [] 0 0 - , crudReplace = \a -> runDB . replace a - , crudInsert = runDB . insert - , crudGet = runDB . get - , crudDelete = runDB . delete - } diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index 7be74bb9..8a4c4cb8 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -40,15 +40,13 @@ import Control.Monad.Trans.State import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) +import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) import Control.Applicative (Applicative) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (lift) import Yesod.Internal import Control.Monad.IO.Peel (MonadPeelIO) -import Control.Monad (liftM) -import qualified Data.Map as Map -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. This is basically a large 'WriterT' stack keeping track of diff --git a/hellowidget.hs b/hellowidget.hs deleted file mode 100644 index 3c73e81a..00000000 --- a/hellowidget.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, OverloadedStrings #-} -import Yesod -import Yesod.Widget -import Yesod.Helpers.Static -import Yesod.Form.Jquery -import Yesod.Form.Core -import Data.Monoid -import Yesod.Form.Nic -import Control.Applicative -import qualified Data.ByteString.Lazy as L -import System.Directory -import Control.Monad.Trans.Class -import Data.Default - -data HW = HW { hwStatic :: Static } -mkYesod "HW" [$parseRoutes| -/ RootR GET -/form FormR -/static StaticR Static hwStatic -/autocomplete AutoCompleteR GET -/customform CustomFormR GET -|] -instance Yesod HW where - approot _ = "" - addStaticContent ext _ content = do - let fn = (base64md5 content) ++ '.' : ext - liftIO $ createDirectoryIfMissing True "static/tmp" - liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) - -type Handler = GHandler HW HW - -instance YesodNic HW -instance YesodJquery HW where - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "ui-darkness" -wrapper h = [$hamlet| -#wrapper ^h^ -%footer Brought to you by Yesod Widgets™ -|] -getRootR = defaultLayout $ wrapper $ do - i <- newIdent - setTitle $ string "Hello Widgets" - addCassius [$cassius| -#$i$ - color: red -|] - addStylesheet $ StaticR $ StaticRoute ["style.css"] [] - addStylesheetRemote "http://localhost:3000/static/style2.css" - addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js" - addScript $ StaticR $ StaticRoute ["script.js"] [] - addHamlet [$hamlet| -%h1#$i$ Welcome to my first widget!!! -%p - %a!href=@RootR@ Recursive link. -%p - %a!href=@FormR@ Check out the form. -%p - %a!href=@CustomFormR@ Custom form arrangement. -%p.noscript Your script did not load. :( -|] - addHtmlHead [$hamlet|%meta!keywords=haskell|] - -handleFormR = do - (res, form, enctype, hidden) <- runFormPost $ fieldsToTable $ (,,,,,,,,,,,) - <$> stringField (FormFieldSettings "My Field" "Some tooltip info" Nothing Nothing) Nothing - <*> stringField ("Another field") (Just "some default text") - <*> intField (FormFieldSettings "A number field" "some nums" Nothing Nothing) (Just 5) - <*> jqueryDayField def - { jdsChangeMonth = True - , jdsChangeYear = True - , jdsYearRange = "1900:c+10" - , jdsNumberOfMonths = Right (2, 3) - } ("A day field") Nothing - <*> timeField ("A time field") Nothing - <*> boolField FormFieldSettings - { ffsLabel = "A checkbox" - , ffsTooltip = "" - , ffsId = Nothing - , ffsName = Nothing - } (Just False) - <*> jqueryAutocompleteField AutoCompleteR - (FormFieldSettings "Autocomplete" "Try it!" Nothing Nothing) Nothing - <*> nicHtmlField ("HTML") - (Just $ string "You can put rich text here") - <*> maybeEmailField ("An e-mail addres") Nothing - <*> maybeTextareaField "A text area" Nothing - <*> maybeFileField "Any file" - <*> maybePasswordField "Enter a password" Nothing - let (mhtml, mfile) = case res of - FormSuccess (_, _, _, _, _, _, _, x, _, _, y, _) -> (Just x, y) - _ -> (Nothing, Nothing) - let txt = case res of - FormSuccess (_, _, _, _, _, _, _, _, _, Just x, _, _) -> Just x - _ -> Nothing - defaultLayout $ do - addCassius [$cassius| -.tooltip - color: #666 - font-style: italic -|] - addCassius [$cassius| -textarea.html - width: 300px - height: 150px -|] - addWidget [$hamlet| -$maybe formFailures.res failures - %ul.errors - $forall failures f - %li $f$ -%form!method=post!enctype=$enctype$ - $hidden$ - %table - ^form^ - %tr - %td!colspan=2 - %input!type=submit - $maybe mhtml html - $html$ - $maybe txt t - $t$ - $maybe mfile f - $show.f$ -|] - setTitle $ string "Form" - -main = basicHandler 3000 $ HW $ fileLookupDir "static" typeByExt - -getAutoCompleteR :: Handler RepJson -getAutoCompleteR = do - term <- runFormGet' $ stringInput "term" - jsonToRepJson $ jsonList - [ jsonScalar $ term ++ "foo" - , jsonScalar $ term ++ "bar" - , jsonScalar $ term ++ "baz" - ] - -data Person = Person String Int -getCustomFormR = do - let customForm = GForm $ do - (a1, [b1], c1) <- deform $ stringInput "name" - (a2, [b2], c2) <- deform $ intInput "age" - let b = do - b1' <- extractBody b1 - b2' <- extractBody b2 - addHamlet [$hamlet| -%p This is a custom layout. -%h1 Name Follows! -%p ^b1'^ -%p Age: ^b2'^ -|] - return (Person <$> a1 <*> a2, b , c1 `mappend` c2) - (_, wform, enctype) <- runFormGet customForm - defaultLayout $ do - form <- extractBody wform - addHamlet [$hamlet| -%form - ^form^ - %div - %input!type=submit -|] diff --git a/yesod.cabal b/yesod.cabal index 6276a1d3..fdff1e9b 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -59,10 +59,6 @@ library exposed-modules: Yesod Yesod.Content Yesod.Dispatch - Yesod.Form - Yesod.Form.Core - Yesod.Form.Jquery - Yesod.Form.Nic Yesod.Hamlet Yesod.Handler Yesod.Json @@ -70,13 +66,9 @@ library Yesod.Widget Yesod.Yesod Yesod.Helpers.AtomFeed - Yesod.Helpers.Crud Yesod.Helpers.Sitemap Yesod.Helpers.Static - other-modules: Yesod.Form.Class - Yesod.Internal - Yesod.Form.Fields - Yesod.Form.Profiles + other-modules: Yesod.Internal ghc-options: -Wall executable yesod From c4570580c701e92d1f50525b861df2f147b71635 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 20 Dec 2010 18:55:33 +0200 Subject: [PATCH 548/624] reqRequestBody doc update --- Yesod/Request.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index d526ff65..48cc4236 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -100,6 +100,13 @@ data Request = Request -- thunk, which essentially means it will be computed once at most, but -- only if requested. This allows avoidance of the potentially costly -- parsing of POST bodies for pages which do not use them. + -- + -- Additionally, since the request body is not read until needed, you can + -- directly access the 'W.requestBody' record in 'reqWaiRequest' and + -- perform other forms of parsing. For example, when designing a web + -- service, you may want to accept JSON-encoded data. Just be aware that + -- if you do such parsing, the standard POST form parsing functions will + -- no longer work. , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request -- | Languages which the client supports. From cba608ef9045a62029a0dc578518e0649e67a338 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 21 Dec 2010 00:07:33 +0200 Subject: [PATCH 549/624] Using cookie package --- Yesod/Content.hs | 5 ----- Yesod/Dispatch.hs | 17 +++++++++++++---- yesod.cabal | 1 + 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index e8fe59b0..10a83557 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -45,7 +45,6 @@ module Yesod.Content -- * Utilities , formatW3 , formatRFC1123 - , formatCookieExpires #if TEST , testSuite #endif @@ -260,7 +259,3 @@ formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123. formatRFC1123 :: UTCTime -> String formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" - --- | Format a 'UTCTime' for a cookie. -formatCookieExpires :: UTCTime -> String -formatCookieExpires = formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 27847cfc..174c707b 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -52,6 +52,9 @@ import qualified Network.Wai.Handler.CGI as CGI import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (toLazyByteString) import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -63,6 +66,7 @@ import Data.Maybe import Web.ClientSession import qualified Web.ClientSession as CS import Data.Char (isUpper) +import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) import Data.Serialize import qualified Data.Serialize as Ser @@ -447,10 +451,15 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> Header -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = - let expires = getExpires minutes - in ("Set-Cookie", charsToBs - $ key ++ "=" ++ value ++"; path=/; expires=" - ++ formatCookieExpires expires) + ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie + { setCookieName = B.pack key -- FIXME check for non-ASCII + , setCookieValue = B.pack value -- FIXME check for non-ASCII + , setCookiePath = Just "/" -- FIXME make a config option, or use approot? + , setCookieExpires = Just $ getExpires minutes + , setCookieDomain = Nothing + }) + where + builderToBS = S.concat . L.toChunks . toLazyByteString headerToPair _ (DeleteCookie key) = ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") diff --git a/yesod.cabal b/yesod.cabal index fdff1e9b..136a3083 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -56,6 +56,7 @@ library , containers >= 0.2 && < 0.5 , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 + , cookie >= 0.0 && < 0.1 exposed-modules: Yesod Yesod.Content Yesod.Dispatch From d723e4054296fb270ab09d6015690e41694819d1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 21 Dec 2010 00:07:50 +0200 Subject: [PATCH 550/624] ContentBuilder and responseBuilder --- Yesod/Content.hs | 13 +++++++------ Yesod/Dispatch.hs | 2 +- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 10a83557..65a77038 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -70,15 +70,16 @@ import Test.HUnit hiding (Test) #endif import Data.Enumerator (Enumerator) -import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) +import Data.Monoid (mempty) -data Content = ContentLBS L.ByteString +data Content = ContentBuilder Builder | ContentEnum (forall a. Enumerator Builder IO a) | ContentFile FilePath -- | Zero-length enumerator. emptyContent :: Content -emptyContent = ContentLBS L.empty +emptyContent = ContentBuilder mempty -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentEnum' constructor. An easier approach will be to use @@ -88,13 +89,13 @@ class ToContent a where toContent :: a -> Content instance ToContent B.ByteString where - toContent = ContentLBS . L.fromChunks . return + toContent = ContentBuilder . fromByteString instance ToContent L.ByteString where - toContent = ContentLBS + toContent = ContentBuilder . fromLazyByteString instance ToContent T.Text where toContent = toContent . Data.Text.Encoding.encodeUtf8 instance ToContent Text where - toContent = ContentLBS . Data.Text.Lazy.Encoding.encodeUtf8 + toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 174c707b..26f629bc 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -339,7 +339,7 @@ toWaiApp' y key' segments env = do hs''' = ("Content-Type", charsToBs ct) : hs'' return $ case c of - ContentLBS lbs -> W.ResponseLBS s hs''' lbs + ContentBuilder b -> W.responseBuilder s hs''' b ContentFile fp -> W.ResponseFile s hs''' fp ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s hs''' From cb9f798ff9fd14776ea605fdcb7add3d7364c910 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 21 Dec 2010 00:24:15 +0200 Subject: [PATCH 551/624] Removed persistent dependency --- Yesod/Dispatch.hs | 4 ++-- Yesod/Yesod.hs | 32 -------------------------------- yesod.cabal | 3 +-- 3 files changed, 3 insertions(+), 36 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 26f629bc..d45654ac 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -27,10 +27,10 @@ module Yesod.Dispatch ) where #if TEST -import Yesod.Yesod hiding (testSuite, Key) +import Yesod.Yesod hiding (testSuite) import Yesod.Handler hiding (testSuite) #else -import Yesod.Yesod hiding (Key) +import Yesod.Yesod import Yesod.Handler #endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 1523f7d4..1015e322 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -11,11 +11,6 @@ module Yesod.Yesod Yesod (..) , YesodSite (..) , YesodSubSite (..) - -- ** Persistence - , YesodPersist (..) - , module Database.Persist - , get404 - , getBy404 -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs @@ -51,9 +46,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import Database.Persist -import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Failure (Failure) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -378,30 +370,6 @@ defaultErrorHandler (BadMethod m) = %p Method "$m$" not supported |] -class YesodPersist y where - type YesodDB y :: (* -> *) -> * -> * - runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a - - --- Get the given entity by ID, or return a 404 not found if it doesn't exist. -get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m), - Failure ErrorResponse m, MonadTrans t) - => Key val -> t m val -get404 key = do - mres <- get key - case mres of - Nothing -> lift notFound - Just res -> return res - -getBy404 :: (PersistBackend (t m), PersistEntity val, Monad (t m), - Failure ErrorResponse m, MonadTrans t) - => Unique val -> t m (Key val, val) -getBy404 ukey = do - mres <- getBy ukey - case mres of - Nothing -> lift notFound - Just res -> return res - -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only diff --git a/yesod.cabal b/yesod.cabal index 136a3083..51a43131 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -34,7 +34,7 @@ library , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.12 - , template-haskell >= 2.4 && < 2.6 + , template-haskell , web-routes-quasi >= 0.6.2 && < 0.7 , hamlet >= 0.6 && < 0.7 , blaze-builder >= 0.2.1 && < 0.3 @@ -45,7 +45,6 @@ library , cereal >= 0.2 && < 0.4 , base64-bytestring >= 0.1 && < 0.2 , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.4 && < 0.5 , neither >= 0.2 && < 0.3 , network >= 2.2.1.5 && < 2.4 , email-validate >= 0.2.5 && < 0.3 From 2211503e02dbad3aaf923dcfe82853f658f5d7a8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 21 Dec 2010 17:32:24 +0200 Subject: [PATCH 552/624] yesodVersion --- Yesod/Yesod.hs | 7 +++++++ yesod.cabal | 1 + 2 files changed, 8 insertions(+) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 1015e322..39f81eae 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -23,6 +23,8 @@ module Yesod.Yesod , defaultErrorHandler -- * Data types , AuthResult (..) + -- * Misc + , yesodVersion #if TEST , testSuite #endif @@ -39,6 +41,8 @@ import Yesod.Json import Yesod.Handler #endif +import qualified Paths_yesod +import Data.Version (showVersion) import Yesod.Widget import Yesod.Request import Yesod.Hamlet @@ -525,3 +529,6 @@ redirectToPost dest = hamletToRepHtml %p Javascript has been disabled; please click on the button below to be redirected. %input!type=submit!value=Continue |] >>= sendResponse + +yesodVersion :: String +yesodVersion = showVersion Paths_yesod.version diff --git a/yesod.cabal b/yesod.cabal index 51a43131..27edae04 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -69,6 +69,7 @@ library Yesod.Helpers.Sitemap Yesod.Helpers.Static other-modules: Yesod.Internal + Paths_yesod ghc-options: -Wall executable yesod From e2ace86bb9e3b3a971f0572e13a4b6828f3930c5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 24 Dec 2010 08:17:21 +0200 Subject: [PATCH 553/624] Removed Yesod.Json, using json-types --- Yesod.hs | 3 - Yesod/Content.hs | 5 ++ Yesod/Json.hs | 141 ----------------------------------------------- Yesod/Yesod.hs | 13 +++-- yesod.cabal | 3 +- 5 files changed, 15 insertions(+), 150 deletions(-) delete mode 100644 Yesod/Json.hs diff --git a/Yesod.hs b/Yesod.hs index f3be2aa7..31dd3b88 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -7,7 +7,6 @@ module Yesod , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Hamlet - , module Yesod.Json , module Yesod.Widget , Application , lift @@ -20,13 +19,11 @@ module Yesod #if TEST import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) import Yesod.Dispatch hiding (testSuite) import Yesod.Yesod hiding (testSuite) import Yesod.Handler hiding (runHandler, testSuite) #else import Yesod.Content -import Yesod.Json import Yesod.Dispatch import Yesod.Yesod import Yesod.Handler hiding (runHandler) diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 65a77038..9be7a2f8 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -73,6 +73,9 @@ import Data.Enumerator (Enumerator) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) +import qualified Data.JSON.Types as J +import qualified Text.JSON.Enumerator as J + data Content = ContentBuilder Builder | ContentEnum (forall a. Enumerator Builder IO a) | ContentFile FilePath @@ -98,6 +101,8 @@ instance ToContent Text where toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where toContent = toContent . T.pack +instance ToContent J.Value where + toContent = ContentBuilder . J.renderValue -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Json.hs b/Yesod/Json.hs deleted file mode 100644 index bd22f66e..00000000 --- a/Yesod/Json.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | Efficient generation of JSON documents. --- FIXME remove this module, possibly make a blaze-json -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Json - ( -- * Monad - Json - , jsonToContent - , jsonToRepJson - -- * Generate Json output - , jsonScalar - , jsonList - , jsonMap - , jsonRaw -#if TEST - , testSuite -#endif - ) - where - -import qualified Data.ByteString.Char8 as S -import Data.Char (isControl) -import Yesod.Handler (GHandler) -import Numeric (showHex) -import Data.Monoid (Monoid (..)) -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 (writeChar) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -import Data.ByteString.Lazy.Char8 (unpack) -import Yesod.Content hiding (testSuite) -#else -import Yesod.Content -#endif - --- | A monad for generating Json output. It wraps the Builder monoid from the --- blaze-builder package. --- --- This is an opaque type to avoid any possible insertion of non-JSON content. --- Due to the limited nature of the JSON format, you can create any valid JSON --- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'. -newtype Json = Json { unJson :: Builder } - deriving Monoid - --- | Extract the final result from the given 'Json' value. --- --- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json -> GHandler sub master Content -jsonToContent = return . toContent . toLazyByteString . unJson - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json -> GHandler sub master RepJson -jsonToRepJson = fmap RepJson . jsonToContent - --- | Outputs a single scalar. This function essentially: --- --- * Performs JSON encoding. --- --- * Wraps the resulting string in quotes. -jsonScalar :: String -> Json -jsonScalar s = Json $ mconcat - [ fromByteString "\"" - , fromWriteList writeJsonChar s - , fromByteString "\"" - ] - where - writeJsonChar '\b' = writeByteString "\\b" - writeJsonChar '\f' = writeByteString "\\f" - writeJsonChar '\n' = writeByteString "\\n" - writeJsonChar '\r' = writeByteString "\\r" - writeJsonChar '\t' = writeByteString "\\t" - writeJsonChar '"' = writeByteString "\\\"" - writeJsonChar '\\' = writeByteString "\\\\" - writeJsonChar c - | not $ isControl c = writeChar c - | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs - | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs - | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs - where hexxs = showHex (fromEnum c) "" - writeJsonChar c = writeChar c - writeString = writeByteString . S.pack - --- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json] -> Json -jsonList [] = Json $ fromByteString "[]" -jsonList (x:xs) = mconcat - [ Json $ fromByteString "[" - , x - , mconcat $ map go xs - , Json $ fromByteString "]" - ] - where - go = mappend (Json $ fromByteString ",") - --- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json)] -> Json -jsonMap [] = Json $ fromByteString "{}" -jsonMap (x:xs) = mconcat - [ Json $ fromByteString "{" - , go x - , mconcat $ map go' xs - , Json $ fromByteString "}" - ] - where - go' y = mappend (Json $ fromByteString ",") $ go y - go (k, v) = mconcat - [ jsonScalar k - , Json $ fromByteString ":" - , v - ] - --- | Outputs raw JSON data without performing any escaping. Use with caution: --- this is the only function in this module that allows you to create broken --- JSON documents. -jsonRaw :: S.ByteString -> Json -jsonRaw = Json . fromByteString - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Json" - [ testCase "simple output" caseSimpleOutput - ] - -caseSimpleOutput :: Assertion -caseSimpleOutput = do - let j = do - jsonMap - [ ("foo" , jsonList - [ jsonScalar "bar" - , jsonScalar "baz" - ]) - ] - "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j) - -#endif diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 39f81eae..ee094a15 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -18,6 +18,7 @@ module Yesod.Yesod , maybeAuthorized , widgetToPageContent , defaultLayoutJson + , jsonToRepJson , redirectToPost -- * Defaults , defaultErrorHandler @@ -32,12 +33,10 @@ module Yesod.Yesod #if TEST import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) import Yesod.Handler hiding (testSuite) import qualified Data.ByteString.UTF8 as BSU #else import Yesod.Content -import Yesod.Json import Yesod.Handler #endif @@ -60,6 +59,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Web.Routes +import qualified Data.JSON.Types as J #if TEST import Test.Framework (testGroup, Test) @@ -302,12 +302,15 @@ breadcrumbs = do -- the default layout for the HTML output ('defaultLayout'). defaultLayoutJson :: Yesod master => GWidget sub master () - -> Json + -> J.Value -> GHandler sub master RepHtmlJson defaultLayoutJson w json = do RepHtml html' <- defaultLayout w - json' <- jsonToContent json - return $ RepHtmlJson html' json' + return $ RepHtmlJson html' $ toContent json + +-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. +jsonToRepJson :: J.Value -> GHandler sub master RepJson +jsonToRepJson = return . RepJson . toContent applyLayout' :: Yesod master => Html -- ^ title diff --git a/yesod.cabal b/yesod.cabal index 27edae04..5aaaf0f4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -56,12 +56,13 @@ library , monad-peel >= 0.1 && < 0.2 , enumerator >= 0.4 && < 0.5 , cookie >= 0.0 && < 0.1 + , json-enumerator >= 0.0 && < 0.1 + , json-types >= 0.1 && < 0.2 exposed-modules: Yesod Yesod.Content Yesod.Dispatch Yesod.Hamlet Yesod.Handler - Yesod.Json Yesod.Request Yesod.Widget Yesod.Yesod From c88bbfa33ede105901ebc79725d1fd5f2f2dc5ca Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 26 Dec 2010 10:59:12 +0200 Subject: [PATCH 554/624] yesod-core split --- ChangeLog.md | 90 ------ Setup.lhs | 6 +- Yesod.hs | 42 ++- Yesod/Content.hs | 267 ----------------- Yesod/Dispatch.hs | 539 ---------------------------------- Yesod/Hamlet.hs | 59 ---- Yesod/Handler.hs | 588 -------------------------------------- Yesod/Helpers/AtomFeed.hs | 96 ------- Yesod/Helpers/Sitemap.hs | 79 ----- Yesod/Helpers/Static.hs | 252 ---------------- Yesod/Internal.hs | 103 ------- Yesod/Request.hs | 168 ----------- Yesod/Widget.hs | 189 ------------ Yesod/Yesod.hs | 537 ---------------------------------- blog.hs | 108 ------- blog2.hs | 71 ----- freeform.hs | 40 --- haddock.sh | 2 - helloworld.hs | 7 - mail.hs | 14 - runtests.hs | 18 -- test/.ignored | 0 test/bar/baz | 0 test/foo | 0 test/tmp/ignored | 0 yesod.cabal | 84 +----- 26 files changed, 40 insertions(+), 3319 deletions(-) delete mode 100644 ChangeLog.md delete mode 100644 Yesod/Content.hs delete mode 100644 Yesod/Dispatch.hs delete mode 100644 Yesod/Hamlet.hs delete mode 100644 Yesod/Handler.hs delete mode 100644 Yesod/Helpers/AtomFeed.hs delete mode 100644 Yesod/Helpers/Sitemap.hs delete mode 100644 Yesod/Helpers/Static.hs delete mode 100644 Yesod/Internal.hs delete mode 100644 Yesod/Request.hs delete mode 100644 Yesod/Widget.hs delete mode 100644 Yesod/Yesod.hs delete mode 100644 blog.hs delete mode 100644 blog2.hs delete mode 100644 freeform.hs delete mode 100755 haddock.sh delete mode 100644 helloworld.hs delete mode 100644 mail.hs delete mode 100644 runtests.hs delete mode 100644 test/.ignored delete mode 100644 test/bar/baz delete mode 100644 test/foo delete mode 100644 test/tmp/ignored diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index d9808462..00000000 --- a/ChangeLog.md +++ /dev/null @@ -1,90 +0,0 @@ -### Yesod 0.5.0 (August 29, 2010) - -* Forms no longer have special types for special views; instead, there is a -toFormField attribute when declaring entities to specify a form rendering -function. - -* URL settings for jQuery and Nic are now in their own typeclasses. This will -be the approach used in the future when adding more widgets and forms that -require Javascript libraries. - -* You can explicitly specify the id and name attributes to be used in forms if -you like. When omitted, a unique name is automatically generated. - -* The isAuthorized function now takes a function specifying whether the -request is a write request. This should make it simpler to develop read/write -authorization systems. Bonus points: if you use HTTP request methods properly, -the isWriteRequest function will automatically determine whether a request is -a read or write request. - -* You can now specify splitPath and joinPath functions yourself. Previously, -the built-in versions had very specific URL rules, such as enforcing a -trailing slash. If you want something more flexible, you can override these -functions. - -* addStaticContent is used to serve CSS and Javascript code from widgets from -external files. This allows caching to take place as you'd normally like. - -* Static files served from the static subsite can have a hash string added to -the query string; this is done automatically when using the getStaticFiles -function. This allows you to set your expires headers far in the future. - -* A new Yesod.Mail module provides datatypes and functions for creating -multipart MIME email messages and sending them via the sendmail executable. -Since these functions generate lazy bytestrings, you can use any delivery -mechanism you want. - -* Change the type of defaultLayout to use Widgets instead of PageContent. This -makes it easier to avoid double-including scripts and stylesheets. - -* Major reworking of the Auth subsite to make it easier to use. - -* Update of the site scaffolder to include much more functionality. Also -removed the Handler type alias from the library, as the scaffolder now -provides that. - -### New in Yesod 0.4.0 - -A big thanks on this release to Simon Michael, who pointed out a number of -places where the docs were unclear, the API was unintuitive, or the names were -inconsistent. - -* Widgets. These allow you to create composable pieces of a webpage that -keep track of their own Javascript and CSS. It includes a function for -obtaining unique identifiers to avoid name collisions, and does automatic -dependency combining; in other words, if you have two widgets that depend on -jQuery, the combined widget will only include it once. - -* Combined the Yesod.Form and Yesod.Formable module into a single, consistent, -widget-based API. It includes basic input functions as well as fancier -Javascript-driven functions; for example, there is a plain day entry field, -and a day entry field which automatically loads the jQuery UI date picker. - -* Added the yesod executable which performs basic scaffolding. - -* Cleaned up a bunch of API function names for consistency. For example, -Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming -scheme. - -* Changed the type of basicHandler to require less typing, and added -basicHandler' which allows you to modify the line output to STDOUT (or skip it -altogether). - -* Switched the Handler monad from ContT to MEitherT (provided by the neither -package). ContT does not have a valid MonadCatchIO instance, which is used for -the sqlite persitent backend. - -* Facebook support in the Auth helper. - -* Ensure that HTTP request methods are given in ALL CAPS. - -* Cleaned up signatures of many methods in the Yesod typeclass. In particular, -due to changes in web-routes-quasi, many of those functions can now live in -the Handler monad, making it easier to use standard functions on them. - -* The static file helper now has extensible file-extension-to-mimetype -mappings. - -* Added the sendResponse function for handler short-circuiting. - -* Renamed Routes to Route. diff --git a/Setup.lhs b/Setup.lhs index 1125d1d3..06e2708f 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -2,10 +2,6 @@ > 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 () +> main = defaultMain diff --git a/Yesod.hs b/Yesod.hs index 31dd3b88..9ff8202c 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,41 +1,55 @@ {-# LANGUAGE CPP #-} -- | This module simply re-exports from other modules for your convenience. module Yesod - ( module Yesod.Request + ( -- * Re-exports from yesod-core + module Yesod.Request , module Yesod.Content - , module Yesod.Yesod + , module Yesod.Core , module Yesod.Handler , module Yesod.Dispatch - , module Yesod.Hamlet , module Yesod.Widget + -- * Commonly referenced functions/datatypes , Application , lift , liftIO , MonadPeelIO - , mempty + -- * Utilities , showIntegral , readIntegral + -- * Hamlet library + -- ** Hamlet + , hamlet + , xhamlet + , Hamlet + , Html + , renderHamlet + , renderHtml + , string + , preEscapedString + , cdata + -- ** Julius + , julius + , Julius + , renderJulius + -- ** Cassius + , cassius + , Cassius + , renderCassius ) where -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Dispatch hiding (testSuite) -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (runHandler, testSuite) -#else import Yesod.Content import Yesod.Dispatch -import Yesod.Yesod +import Yesod.Core import Yesod.Handler hiding (runHandler) -#endif +import Text.Hamlet +import Text.Cassius +import Text.Julius import Yesod.Request import Yesod.Widget import Network.Wai (Application) -import Yesod.Hamlet import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) import Control.Monad.IO.Peel (MonadPeelIO) showIntegral :: Integral a => a -> String diff --git a/Yesod/Content.hs b/Yesod/Content.hs deleted file mode 100644 index 9be7a2f8..00000000 --- a/Yesod/Content.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} - -module Yesod.Content - ( -- * Content - Content (..) - , emptyContent - , ToContent (..) - -- * Mime types - -- ** Data type - , ContentType - , typeHtml - , typePlain - , typeJson - , typeXml - , typeAtom - , typeJpeg - , typePng - , typeGif - , typeJavascript - , typeCss - , typeFlv - , typeOgv - , typeOctet - -- ** File extensions - , typeByExt - , ext - -- * Utilities - , simpleContentType - -- * Representations - , ChooseRep - , HasReps (..) - , defChooseRep - -- ** Specific content types - , RepHtml (..) - , RepJson (..) - , RepHtmlJson (..) - , RepPlain (..) - , RepXml (..) - -- * Utilities - , formatW3 - , formatRFC1123 -#if TEST - , testSuite -#endif - ) where - -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.Time -import System.Locale - -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy.Encoding - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -import Data.Enumerator (Enumerator) -import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) -import Data.Monoid (mempty) - -import qualified Data.JSON.Types as J -import qualified Text.JSON.Enumerator as J - -data Content = ContentBuilder Builder - | ContentEnum (forall a. Enumerator Builder IO a) - | ContentFile FilePath - --- | Zero-length enumerator. -emptyContent :: Content -emptyContent = ContentBuilder mempty - --- | Anything which can be converted into 'Content'. Most of the time, you will --- want to use the 'ContentEnum' constructor. An easier approach will be to use --- a pre-defined 'toContent' function, such as converting your data into a lazy --- bytestring and then calling 'toContent' on that. -class ToContent a where - toContent :: a -> Content - -instance ToContent B.ByteString where - toContent = ContentBuilder . fromByteString -instance ToContent L.ByteString where - toContent = ContentBuilder . fromLazyByteString -instance ToContent T.Text where - toContent = toContent . Data.Text.Encoding.encodeUtf8 -instance ToContent Text where - toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8 -instance ToContent String where - toContent = toContent . T.pack -instance ToContent J.Value where - toContent = ContentBuilder . J.renderValue - --- | A function which gives targetted representations of content based on the --- content-types the user accepts. -type ChooseRep = - [ContentType] -- ^ list of content-types user accepts, ordered by preference - -> IO (ContentType, Content) - --- | Any type which can be converted to representations. -class HasReps a where - chooseRep :: a -> ChooseRep - --- | A helper method for generating 'HasReps' instances. --- --- This function should be given a list of pairs of content type and conversion --- functions. If none of the content types match, the first pair is used. -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 to defChooseRep" - (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 $ toContent "")] - -instance HasReps (ContentType, Content) where - chooseRep = const . return - -instance HasReps [(ContentType, Content)] where - chooseRep a cts = return $ - case filter (\(ct, _) -> go ct `elem` map go cts) a of - ((ct, c):_) -> (ct, c) - _ -> case a of - (x:_) -> x - _ -> error "chooseRep [(ContentType, Content)] of empty" - where - go = simpleContentType - -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) - ] -newtype RepPlain = RepPlain Content -instance HasReps RepPlain where - chooseRep (RepPlain c) _ = return (typePlain, c) -newtype RepXml = RepXml Content -instance HasReps RepXml where - chooseRep (RepXml c) _ = return (typeXml, c) - -type ContentType = String - -typeHtml :: ContentType -typeHtml = "text/html; charset=utf-8" - -typePlain :: ContentType -typePlain = "text/plain; charset=utf-8" - -typeJson :: ContentType -typeJson = "application/json; charset=utf-8" - -typeXml :: ContentType -typeXml = "text/xml" - -typeAtom :: ContentType -typeAtom = "application/atom+xml" - -typeJpeg :: ContentType -typeJpeg = "image/jpeg" - -typePng :: ContentType -typePng = "image/png" - -typeGif :: ContentType -typeGif = "image/gif" - -typeJavascript :: ContentType -typeJavascript = "text/javascript; charset=utf-8" - -typeCss :: ContentType -typeCss = "text/css; charset=utf-8" - -typeFlv :: ContentType -typeFlv = "video/x-flv" - -typeOgv :: ContentType -typeOgv = "video/ogg" - -typeOctet :: ContentType -typeOctet = "application/octet-stream" - --- | Removes \"extra\" information at the end of a content type string. In --- particular, removes everything after the semicolon, if present. --- --- For example, \"text/html; charset=utf-8\" is commonly used to specify the --- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: String -> String -simpleContentType = fst . span (/= ';') - --- | A default extension to mime-type dictionary. -typeByExt :: [(String, ContentType)] -typeByExt = - [ ("jpg", typeJpeg) - , ("jpeg", typeJpeg) - , ("js", typeJavascript) - , ("css", typeCss) - , ("html", typeHtml) - , ("png", typePng) - , ("gif", typeGif) - , ("txt", typePlain) - , ("flv", typeFlv) - , ("ogv", typeOgv) - ] - --- | 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 - Just typeJavascript @=? lookup (ext "foo.js") typeByExt - Just typeHtml @=? lookup (ext "foo.html") typeByExt -#endif - --- | Format a 'UTCTime' in W3 format. -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" - --- | Format as per RFC 1123. -formatRFC1123 :: UTCTime -> String -formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs deleted file mode 100644 index d45654ac..00000000 --- a/Yesod/Dispatch.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Dispatch - ( -- * Quasi-quoted routing - parseRoutes - , mkYesod - , mkYesodSub - -- ** More fine-grained - , mkYesodData - , mkYesodSubData - , mkYesodDispatch - , mkYesodSubDispatch - -- ** Path pieces - , SinglePiece (..) - , MultiPiece (..) - , Strings - -- * Convert to WAI - , toWaiApp - , basicHandler - , basicHandler' -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (testSuite) -#else -import Yesod.Yesod -import Yesod.Handler -#endif - -import Yesod.Request -import Yesod.Internal - -import Web.Routes.Quasi -import Web.Routes.Quasi.Parse -import Web.Routes.Quasi.TH -import Language.Haskell.TH.Syntax - -import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPath) -import Network.Wai.Middleware.Jsonp -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) - -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (toLazyByteString) - -import Control.Concurrent.MVar -import Control.Arrow ((***)) - -import Data.Time - -import Control.Monad -import Data.Maybe -import Web.ClientSession -import qualified Web.ClientSession as CS -import Data.Char (isUpper) -import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie) - -import Data.Serialize -import qualified Data.Serialize as Ser -import Network.Wai.Parse hiding (FileInfo) -import qualified Network.Wai.Parse as NWP -import Data.String (fromString) -import Web.Routes -import Control.Arrow (first) -import System.Random (randomR, newStdGen) - -import qualified Data.Map as Map - -import Control.Applicative ((<$>)) -import Data.Enumerator (($$), run_) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck -import System.IO.Unsafe -import Yesod.Content hiding (testSuite) -import Data.Serialize.Get -import Data.Serialize.Put -#else -import Yesod.Content -#endif - --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. --- Use 'parseRoutes' to create the 'Resource's. -mkYesod :: String -- ^ name of the argument datatype - -> [Resource] - -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False - --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. --- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not --- executable by itself, but instead provides functionality to --- be embedded in other sites. -mkYesodSub :: String -- ^ name of the argument datatype - -> Cxt - -> [Resource] - -> Q [Dec] -mkYesodSub name clazzes = - fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True - where - (name':rest) = words name - --- | Sometimes, you will want to declare your routes in one file and define --- your handlers elsewhere. For example, this is the only way to break up a --- monolithic file into smaller parts. Use this function, paired with --- 'mkYesodDispatch', to do just that. -mkYesodData :: String -> [Resource] -> Q [Dec] -mkYesodData name res = mkYesodDataGeneral name [] False res - -mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] -mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res - -mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec] -mkYesodDataGeneral name clazzes isSub res = do - let (name':rest) = words name - (x, _) <- mkYesodGeneral name' rest clazzes isSub res - let rname = mkName $ "resources" ++ name - eres <- lift res - let y = [ SigD rname $ ListT `AppT` ConT ''Resource - , FunD rname [Clause [] (NormalB eres) []] - ] - return $ x ++ y - --- | See 'mkYesodData'. -mkYesodDispatch :: String -> [Resource] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False - -mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] -mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True - where (name':rest) = words name - -mkYesodGeneral :: String -- ^ argument name - -> [String] -- ^ parameters for site argument - -> Cxt -- ^ classes - -> Bool -- ^ is subsite? - -> [Resource] - -> Q ([Dec], [Dec]) -mkYesodGeneral name args clazzes isSub res = do - let name' = mkName name - args' = map mkName args - arg = foldl AppT (ConT name') $ map VarT args' - th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites - w' <- createRoutes th - let routesName = mkName $ name ++ "Route" - let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] - let x = TySynInstD ''Route [arg] $ ConT routesName - - parse' <- createParse th - parse'' <- newName "parse" - let parse = LetE [FunD parse'' parse'] $ VarE parse'' - - render' <- createRender th - render'' <- newName "render" - let render = LetE [FunD render'' render'] $ VarE render'' - - tmh <- [|toMasterHandlerDyn|] - modMaster <- [|fmap chooseRep|] - dispatch' <- createDispatch modMaster tmh th - dispatch'' <- newName "dispatch" - let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' - - site <- [|Site|] - let site' = site `AppE` dispatch `AppE` render `AppE` parse - let (ctx, ytyp, yfunc) = - if isSub - then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") - else ([], ConT ''YesodSite `AppT` arg, "getSite") - let y = InstanceD ctx ytyp - [ FunD (mkName yfunc) [Clause [] (NormalB site') []] - ] - return ([w, x], [y]) - -isStatic :: Piece -> Bool -isStatic StaticPiece{} = True -isStatic _ = False - -thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps atts) - | all (all isUpper) atts = return (n, Simple ps atts) -thResourceFromResource master (Resource n ps [stype, toSubArg]) - -- static route to subsite - = do - let stype' = ConT $ mkName stype - gss <- [|getSubSite|] - let inside = ConT ''Maybe `AppT` - (ConT ''GHandler `AppT` stype' `AppT` master `AppT` - ConT ''ChooseRep) - let typ = ConT ''Site `AppT` - (ConT ''Route `AppT` stype') `AppT` - (ArrowT `AppT` ConT ''String `AppT` inside) - let gss' = gss `SigE` typ - parse' <- [|parsePathSegments|] - let parse = parse' `AppE` gss' - render' <- [|formatPathSegments|] - let render = render' `AppE` gss' - dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] - let dispatch = dispatch' `AppE` gss' - tmg <- mkToMasterArg ps toSubArg - return (n, SubSite - { ssType = ConT ''Route `AppT` stype' - , ssParse = parse - , ssRender = render - , ssDispatch = dispatch - , ssToMasterArg = tmg - , ssPieces = ps - }) - - -thResourceFromResource _ (Resource n _ _) = - error $ "Invalid attributes for resource: " ++ n - -mkToMasterArg :: [Piece] -> String -> Q Exp -mkToMasterArg ps fname = do - let nargs = length $ filter (not.isStatic) ps - f = VarE $ mkName fname - args <- sequence $ take nargs $ repeat $ newName "x" - rsg <- [| runSubsiteGetter|] - let xps = map VarP args - xes = map VarE args - e' = foldl (\x y -> x `AppE` y) f xes - e = rsg `AppE` e' - return $ LamE xps e - -sessionName :: String -sessionName = "_SESSION" - --- | Convert the given argument into a WAI application, executable with any WAI --- handler. This is the same as 'toWaiAppPlain', except it includes three --- middlewares: GZIP compression, JSON-P and path cleaning. This is the --- recommended approach for most users. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp y = do - a <- toWaiAppPlain y - return $ gzip False - $ jsonp - a - --- | Convert the given argument into a WAI application, executable with any WAI --- handler. This differs from 'toWaiApp' in that it only uses the cleanpath --- middleware. -toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiAppPlain a = do - key' <- if enableClientSessions a - then Just `fmap` encryptKey a - else return Nothing - return $ cleanPath (splitPath a) (B.pack $ approot a) - $ toWaiApp' a key' - -toWaiApp' :: (Yesod y, YesodSite y) - => y - -> Maybe Key - -> [String] - -> W.Request - -> IO W.Response -toWaiApp' y key' segments env = do - now <- getCurrentTime - let getExpires m = fromIntegral (m * 60) `addUTCTime` now - let exp' = getExpires $ clientSessionDuration y - let host = if sessionIpAddress y then W.remoteHost env else "" - let session' = - case key' of - Nothing -> [] - Just key'' -> fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key'' now host val - let site = getSite - method = B.unpack $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) segments - eurl = parsePathSegments site pathSegments - render u qs = - let (ps, qs') = formatPathSegments site u - in fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - let errorHandler' = localNoCurrent . errorHandler - rr <- parseWaiRequest env session' - let h = do - onRequest - case eurl of - Left _ -> errorHandler' NotFound - Right url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute y of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s - case handleSite site render url method of - Nothing -> errorHandler' $ BadMethod method - Just h' -> h' - let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler' er) render eurl' id y id - let ya = runHandler h render eurl' id y id - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - yar <- unYesodApp ya eh rr types sessionMap - case yar of - YARPlain s hs ct c sessionFinal -> do - let sessionVal = - case key' of - Nothing -> B.empty - Just key'' -> - encodeSession key'' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = - case key' of - Nothing -> hs - Just _ -> AddCookie - (clientSessionDuration y) - sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ - case c of - ContentBuilder b -> W.responseBuilder s hs''' b - ContentFile fp -> W.ResponseFile s hs''' fp - ContentEnum e -> W.ResponseEnumerator $ \iter -> - run_ $ e $$ iter s hs''' - YAREnum e -> return $ W.ResponseEnumerator e - -httpAccept :: W.Request -> [ContentType] -httpAccept = map B.unpack - . parseHttpAccept - . fromMaybe B.empty - . lookup "Accept" - . W.requestHeaders - --- | Runs an application with CGI if CGI variables are present (namely --- PATH_INFO); otherwise uses SimpleServer. -basicHandler :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> y - -> IO () -basicHandler port y = basicHandler' port (Just "localhost") y - - --- | Same as 'basicHandler', but allows you to specify the hostname to display --- to the user. If 'Nothing' is provided, then no output is produced. -basicHandler' :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> Maybe String -- ^ host name, 'Nothing' to show nothing - -> y - -> IO () -basicHandler' port mhost y = do - app <- toWaiApp y - vars <- getEnvironment - case lookup "PATH_INFO" vars of - Nothing -> do - case mhost of - Nothing -> return () - Just h -> putStrLn $ concat - ["http://", h, ":", show port, "/"] - SS.run port app - Just _ -> CGI.run app - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> IO Request -parseWaiRequest env session' = do - let gets' = map (bsToChars *** bsToChars) - $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey session' of - Nothing -> langs - Just x -> x : langs - 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 - nonce <- case lookup nonceKey session' of - Just x -> return x - Nothing -> do - g <- newStdGen - return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce - where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -nonceKey :: String -nonceKey = "_NONCE" - -rbHelper :: W.Request -> IO RequestBodyContents -rbHelper req = - (map fix1 *** map fix2) <$> run_ (enum $$ iter) - where - enum = W.requestBody req - iter = parseRequestBody lbsSink req - fix1 = bsToChars *** bsToChars - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | 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) - --- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header - -> (W.ResponseHeader, B.ByteString) -headerToPair getExpires (AddCookie minutes key value) = - ("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie - { setCookieName = B.pack key -- FIXME check for non-ASCII - , setCookieValue = B.pack value -- FIXME check for non-ASCII - , setCookiePath = Just "/" -- FIXME make a config option, or use approot? - , setCookieExpires = Just $ getExpires minutes - , setCookieDomain = Nothing - }) - where - builderToBS = S.concat . L.toChunks . toLazyByteString -headerToPair _ (DeleteCookie key) = - ("Set-Cookie", charsToBs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = - (fromString key, charsToBs value) - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> B.ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> B.ByteString -- ^ cookie value -encodeSession key expire rhost session' = - encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- decrypt key encrypted - SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' - -data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c - get = do - a <- getTime - b <- Ser.get - c <- Ser.get - return $ SessionCookie a b c - -putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt - -getTime :: Get UTCTime -getTime = do - d <- Ser.get - ndt <- Ser.get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Dispatch" - [ testProperty "encode/decode session" propEncDecSession - , testProperty "get/put time" propGetPutTime - ] - -propEncDecSession :: [(String, String)] -> Bool -propEncDecSession session' = unsafePerformIO $ do - key <- getDefaultKey - now <- getCurrentTime - let expire = addUTCTime 1 now - let rhost = B.pack "some host" - let val = encodeSession key expire rhost session' - return $ Just session' == decodeSession key now rhost val - -propGetPutTime :: UTCTime -> Bool -propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) - -instance Arbitrary UTCTime where - arbitrary = do - a <- arbitrary - b <- arbitrary - return $ addUTCTime (fromRational b) - $ UTCTime (ModifiedJulianDay a) 0 - -#endif diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs deleted file mode 100644 index e472981e..00000000 --- a/Yesod/Hamlet.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Hamlet - ( -- * Hamlet library - -- ** Hamlet - hamlet - , xhamlet - , Hamlet - , Html - , renderHamlet - , renderHtml - , string - , preEscapedString - , cdata - -- ** Julius - , julius - , Julius - , renderJulius - -- ** Cassius - , cassius - , Cassius - , renderCassius - -- * Convert to something displayable - , hamletToContent - , hamletToRepHtml - -- * Page templates - , PageContent (..) - ) - where - -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Content -import Yesod.Handler - --- | Content for a web page. By providing this datatype, we can easily create --- generic site templates, which would have the type signature: --- --- > PageContent url -> Hamlet url -data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: Hamlet url - , pageBody :: Hamlet url - } - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ renderHamlet render h - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs deleted file mode 100644 index 1420a8f4..00000000 --- a/Yesod/Handler.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} ---------------------------------------------------------- --- --- Module : Yesod.Handler --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : unstable --- Portability : portable --- --- Define Handler stuff. --- ---------------------------------------------------------- -module Yesod.Handler - ( -- * Type families - Route - , YesodSubRoute (..) - -- * Handler monad - , GHandler - -- ** Read information from handler - , getYesod - , getYesodSub - , getUrlRender - , getUrlRenderParams - , getCurrentRoute - , getRouteToMaster - -- * Special responses - -- ** Redirecting - , RedirectType (..) - , redirect - , redirectParams - , redirectString - -- ** Errors - , notFound - , badMethod - , permissionDenied - , invalidArgs - -- ** Short-circuit responses. - , sendFile - , sendResponse - , sendResponseStatus - , sendResponseCreated - , sendResponseEnumerator - -- * Setting headers - , setCookie - , deleteCookie - , setHeader - , setLanguage - -- ** Content caching and expiration - , cacheSeconds - , neverExpires - , alreadyExpired - , expiresAt - -- * Session - , SessionMap - , lookupSession - , getSession - , setSession - , deleteSession - -- ** Ultimate destination - , setUltDest - , setUltDestString - , setUltDest' - , redirectUltDest - -- ** Messages - , setMessage - , getMessage - -- * Internal Yesod - , runHandler - , YesodApp (..) - , runSubsiteGetter - , toMasterHandler - , toMasterHandlerDyn - , toMasterHandlerMaybe - , localNoCurrent - , HandlerData - , ErrorResponse (..) - , YesodAppResult (..) -#if TEST - , testSuite -#endif - ) where - -import Prelude hiding (catch) -import Yesod.Request -import Yesod.Internal -import Data.Neither -import Data.Time (UTCTime) - -import Control.Exception hiding (Handler, catch, finally) -import qualified Control.Exception as E -import Control.Applicative - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State - -import System.IO -import qualified Network.Wai as W -import Control.Failure (Failure (failure)) - -import Text.Hamlet - -import Control.Monad.IO.Peel (MonadPeelIO) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as S8 - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit hiding (Test) -import Yesod.Content hiding (testSuite) -import Data.IORef -#else -import Yesod.Content -#endif - --- | The type-safe URLs associated with a site argument. -type family Route a - -class YesodSubRoute s y where - fromSubRoute :: s -> y -> Route s -> Route y - -data HandlerData sub master = HandlerData - { handlerRequest :: Request - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> [(String, String)] -> String) - , handlerToMaster :: Route sub -> Route master - } - -handlerSubData :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubData tm ts = handlerSubDataMaybe tm ts . Just - -handlerSubDataMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route - } - --- | Used internally for promoting subsite handler functions to master site --- handler functions. Should not be needed by users. -toMasterHandler :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandler tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubData tm ts route) h - -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerDyn tm getSub route (GHandler h) = do - sub <- getSub - GHandler $ withReaderT (handlerSubData tm (const sub) route) h - -class SubsiteGetter g m s | g -> s where - runSubsiteGetter :: g -> m s - -instance (master ~ master' - ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where - runSubsiteGetter getter = do - y <- getYesod - return $ getter y - -instance (anySub ~ anySub' - ,master ~ master' - ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where - runSubsiteGetter = id - -toMasterHandlerMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerMaybe tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h - --- | A generic handler monad, which can have a different subsite and master --- site. This monad is a combination of 'ReaderT' for basic arguments, a --- 'WriterT' for headers and session, and an 'MEitherT' monad for handling --- special responses. It is declared as a newtype to make compiler errors more --- readable. -newtype GHandler sub master a = - GHandler - { unGHandler :: GHInner sub master a - } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) - -type GHInner s m = - ReaderT (HandlerData s m) ( - MEitherT HandlerContents ( - WriterT (Endo [Header]) ( - StateT SessionMap ( -- session - IO - )))) - -type SessionMap = Map.Map String String - -type Endo a = a -> a - --- | An extension of the basic WAI 'W.Application' datatype to provide extra --- features needed by Yesod. Users should never need to use this directly, as --- the 'GHandler' monad and template haskell code should hide it away. -newtype YesodApp = YesodApp - { unYesodApp - :: (ErrorResponse -> YesodApp) - -> Request - -> [ContentType] - -> SessionMap - -> IO YesodAppResult - } - -data YesodAppResult - = YAREnum (forall a. W.ResponseEnumerator a) - | YARPlain W.Status [Header] ContentType Content SessionMap - -data HandlerContents = - HCContent W.Status ChooseRep - | HCError ErrorResponse - | HCSendFile ContentType FilePath - | HCRedirect RedirectType String - | HCCreated String - | HCEnum (forall a. W.ResponseEnumerator a) - -instance Failure ErrorResponse (GHandler sub master) where - failure = GHandler . lift . throwMEither . HCError -instance RequestReader (GHandler sub master) where - getRequest = handlerRequest <$> GHandler ask - --- | Get the sub application argument. -getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> GHandler ask - --- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = handlerMaster <$> GHandler ask - --- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> String) -getUrlRender = do - x <- handlerRender <$> GHandler ask - return $ flip x [] - --- | The URL rendering function with query-string parameters. -getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) -getUrlRenderParams = handlerRender <$> GHandler ask - --- | Get the route requested by the user. If this is a 404 response- where the --- user requested an invalid route- this function will return 'Nothing'. -getCurrentRoute :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute <$> GHandler ask - --- | Get the function to promote a route for a subsite to a route for the --- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster <$> GHandler ask - --- | Function used internally by Yesod in the process of converting a --- 'GHandler' into an 'W.Application'. Should not be needed by users. -runHandler :: HasReps c - => GHandler sub master c - -> (Route master -> [(String, String)] -> String) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> (master -> sub) - -> YesodApp -runHandler handler mrender sroute tomr ma tosa = - YesodApp $ \eh rr cts initSession -> do - let toErrorHandler = - InternalError - . (show :: Control.Exception.SomeException -> String) - let hd = HandlerData - { handlerRequest = rr - , handlerSub = tosa ma - , handlerMaster = ma - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr - } - ((contents', headers), finalSession) <- E.catch ( - flip runStateT initSession - $ runWriterT - $ runMEitherT - $ flip runReaderT hd - $ unGHandler handler - ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither id (HCContent W.status200 . chooseRep) contents' - let handleError e = do - yar <- unYesodApp (eh e) safeEh rr cts finalSession - case yar of - YARPlain _ hs ct c sess -> - let hs' = headers hs - in return $ YARPlain (getStatus e) hs' ct c sess - YAREnum _ -> return yar - let sendFile' ct fp = - return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession - case contents of - HCContent status a -> do - (ct, c) <- chooseRep a cts - return $ YARPlain status (headers []) ct c finalSession - HCError e -> handleError e - HCRedirect rt loc -> do - let hs = Header "Location" loc : headers [] - return $ YARPlain - (getRedirectStatus rt) hs typePlain emptyContent - finalSession - HCSendFile ct fp -> E.catch - (sendFile' ct fp) - (handleError . toErrorHandler) - HCCreated loc -> do -- FIXME add status201 to WAI - let hs = Header "Location" loc : headers [] - return $ YARPlain - (W.Status 201 (S8.pack "Created")) - hs - typePlain - emptyContent - finalSession - HCEnum e -> return $ YAREnum e - -safeEh :: ErrorResponse -> YesodApp -safeEh er = YesodApp $ \_ _ _ session -> do - liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ YARPlain - W.status500 - [] - typePlain - (toContent "Internal Server Error") - session - --- | Redirect to the given route. -redirect :: RedirectType -> Route master -> GHandler sub master a -redirect rt url = redirectParams rt url [] - --- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Route master -> [(String, String)] - -> GHandler sub master a -redirectParams rt url params = do - r <- getUrlRenderParams - redirectString rt $ r url params - --- | Redirect to the given URL. -redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt = GHandler . lift . throwMEither . HCRedirect rt - -ultDestKey :: String -ultDestKey = "_ULT" - --- | Sets the ultimate destination variable to the given route. --- --- An ultimate destination is stored in the user session and can be loaded --- later by 'redirectUltDest'. -setUltDest :: Route master -> GHandler sub master () -setUltDest dest = do - render <- getUrlRender - setUltDestString $ render dest - --- | Same as 'setUltDest', but use the given string. -setUltDestString :: String -> GHandler sub master () -setUltDestString = setSession ultDestKey - --- | Same as 'setUltDest', but uses the current page. --- --- If this is a 404 handler, there is no current page, and then this call does --- nothing. -setUltDest' :: GHandler sub master () -setUltDest' = do - route <- getCurrentRoute - case route of - Nothing -> return () - Just r -> do - tm <- getRouteToMaster - gets' <- reqGetParams <$> getRequest - render <- getUrlRenderParams - setUltDestString $ render (tm r) gets' - --- | Redirect to the ultimate destination in the user's session. Clear the --- value from the session. --- --- The ultimate destination is set with 'setUltDest'. -redirectUltDest :: RedirectType - -> Route master -- ^ default destination if nothing in session - -> GHandler sub master () -redirectUltDest rt def = do - mdest <- lookupSession ultDestKey - deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt) mdest - -msgKey :: String -msgKey = "_MSG" - --- | Sets a message in the user's session. --- --- See 'getMessage'. -setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . lbsToChars . renderHtml - --- | Gets the message in the user's session, if available, and then clears the --- variable. --- --- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) -getMessage = do - mmsg <- fmap (fmap preEscapedString) $ lookupSession msgKey - deleteSession msgKey - return mmsg - --- | Bypass remaining handler code and output the given file. --- --- For some backends, this is more efficient than reading in the file to --- memory, since they can optimize file sending via a system call to sendfile. -sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = GHandler . lift . throwMEither . HCSendFile ct - --- | Bypass remaining handler code and output the given content with a 200 --- status code. -sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent W.status200 - . chooseRep - --- | Bypass remaining handler code and output the given content with the given --- status code. -sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a -sendResponseStatus s = GHandler . lift . throwMEither . HCContent s - . chooseRep - --- | Send a 201 "Created" response with the given route as the Location --- response header. -sendResponseCreated :: Route m -> GHandler s m a -sendResponseCreated url = do - r <- getUrlRender - GHandler $ lift $ throwMEither $ HCCreated $ r url - --- | Send a 'W.ResponseEnumerator'. Please note: this function is rarely --- necessary, and will /disregard/ any changes to response headers and session --- that you have already specified. This function short-circuits. It should be --- considered only for they specific needs. If you are not sure if you need it, --- you don't. -sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b -sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum - --- | Return a 404 not found page. Also denotes no handler available. -notFound :: Failure ErrorResponse m => m a -notFound = failure NotFound - --- | Return a 405 method not supported page. -badMethod :: (RequestReader m, Failure ErrorResponse m) => m a -badMethod = do - w <- waiRequest - failure $ BadMethod $ bsToChars $ W.requestMethod w - --- | Return a 403 permission denied page. -permissionDenied :: Failure ErrorResponse m => String -> m a -permissionDenied = failure . PermissionDenied - --- | Return a 400 invalid arguments page. -invalidArgs :: Failure ErrorResponse m => [String] -> m a -invalidArgs = failure . InvalidArgs - -------- Headers --- | Set the cookie on the client. -setCookie :: Int -- ^ minutes to timeout - -> String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setCookie a b = addHeader . AddCookie a b - --- | Unset the cookie on the client. -deleteCookie :: String -> GHandler sub master () -deleteCookie = addHeader . DeleteCookie - --- | Set the language in the user session. Will show up in 'languages' on the --- next request. -setLanguage :: String -> GHandler sub master () -setLanguage = setSession langKey - --- | Set an arbitrary response header. -setHeader :: String -> String -> GHandler sub master () -setHeader a = addHeader . Header a - --- | Set the Cache-Control header to indicate this response should be cached --- for the given number of seconds. -cacheSeconds :: Int -> GHandler s m () -cacheSeconds i = setHeader "Cache-Control" $ concat - [ "max-age=" - , show i - , ", public" - ] - --- | Set the Expires header to some date in 2037. In other words, this content --- is never (realistically) expired. -neverExpires :: GHandler s m () -neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" - --- | Set an Expires header in the past, meaning this content should not be --- cached. -alreadyExpired :: GHandler s m () -alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" - --- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () -expiresAt = setHeader "Expires" . formatRFC1123 - --- | Set a variable in the user's session. --- --- The session is handled by the clientsession package: it sets an encrypted --- and hashed cookie on the client. This ensures that all data is secure and --- not tampered with. -setSession :: String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . Map.insert k - --- | Unsets a session variable. See 'setSession'. -deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . Map.delete - --- | Internal use only, not to be confused with 'setHeader'. -addHeader :: Header -> GHandler sub master () -addHeader = GHandler . lift . lift . tell . (:) - -getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.status404 -getStatus (InternalError _) = W.status500 -getStatus (InvalidArgs _) = W.status400 -getStatus (PermissionDenied _) = W.status403 -getStatus (BadMethod _) = W.status405 - -getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.status301 -getRedirectStatus RedirectTemporary = W.status302 -getRedirectStatus RedirectSeeOther = W.status303 - --- | Different types of redirects. -data RedirectType = RedirectPermanent - | RedirectTemporary - | RedirectSeeOther - deriving (Show, Eq) - -localNoCurrent :: GHandler s m a -> GHandler s m a -localNoCurrent = - GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler - --- | Lookup for session data. -lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) -lookupSession n = GHandler $ do - m <- lift $ lift $ lift get - return $ Map.lookup n m - --- | Get all session variables. -getSession :: GHandler s m SessionMap -getSession = GHandler $ lift $ lift $ lift get - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Handler" - [ - ] - -#endif diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs deleted file mode 100644 index 8a5ea4a8..00000000 --- a/Yesod/Helpers/AtomFeed.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.AtomFeed --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Stable --- Portability : portable --- --- Generating atom news feeds. --- ---------------------------------------------------------- - --- | Generation of Atom newsfeeds. See --- <http://en.wikipedia.org/wiki/Atom_(standard)>. -module Yesod.Helpers.AtomFeed - ( AtomFeed (..) - , AtomFeedEntry (..) - , atomFeed - , atomLink - , RepAtom (..) - ) where - -import Yesod -import Data.Time.Clock (UTCTime) - -newtype RepAtom = RepAtom Content -instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (typeAtom, c) - -atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom -atomFeed = fmap RepAtom . hamletToContent . template - -data AtomFeed url = AtomFeed - { atomTitle :: String - , atomLinkSelf :: url - , atomLinkHome :: url - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry url] - } - -data AtomFeedEntry url = AtomFeedEntry - { atomEntryLink :: url - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: Html - } - -template :: AtomFeed url -> Hamlet url -template arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -<?xml version="1.0" encoding="utf-8"?> -%feed!xmlns="http://www.w3.org/2005/Atom" - %title $atomTitle.arg$ - %link!rel=self!href=@atomLinkSelf.arg@ - %link!href=@atomLinkHome.arg@ - %updated $formatW3.atomUpdated.arg$ - %id @atomLinkHome.arg@ - $forall atomEntries.arg entry - ^entryTemplate.entry^ -|] - -entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%entry - %id @atomEntryLink.arg@ - %link!href=@atomEntryLink.arg@ - %updated $formatW3.atomEntryUpdated.arg$ - %title $atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ -|] - --- | Generates a link tag in the head of a widget. -atomLink :: Route m - -> String -- ^ title - -> GWidget s m () -atomLink u title = addHamletHead -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ -|] diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs deleted file mode 100644 index 34807eb5..00000000 --- a/Yesod/Helpers/Sitemap.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Sitemap --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Stable --- Portability : portable --- --- Generating Google sitemap files. --- ---------------------------------------------------------- - --- | Generates XML sitemap files. --- --- See <http://www.sitemaps.org/>. -module Yesod.Helpers.Sitemap - ( sitemap - , robots - , SitemapUrl (..) - , SitemapChangeFreq (..) - ) where - -import Yesod -import Data.Time (UTCTime) - -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never - -showFreq :: SitemapChangeFreq -> String -showFreq Always = "always" -showFreq Hourly = "hourly" -showFreq Daily = "daily" -showFreq Weekly = "weekly" -showFreq Monthly = "monthly" -showFreq Yearly = "yearly" -showFreq Never = "never" - -data SitemapUrl url = SitemapUrl - { sitemapLoc :: url - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } - -template :: [SitemapUrl url] -> Hamlet url -template urls = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" - $forall urls url - %url - %loc @sitemapLoc.url@ - %lastmod $formatW3.sitemapLastMod.url$ - %changefreq $showFreq.sitemapChangeFreq.url$ - %priority $show.priority.url$ -|] - -sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml -sitemap = fmap RepXml . hamletToContent . template - --- | A basic robots file which just lists the "Sitemap: " line. -robots :: Route sub -- ^ sitemap url - -> GHandler sub master RepPlain -robots smurl = do - tm <- getRouteToMaster - render <- getUrlRender - return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 index 7a9048f5..00000000 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# 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. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , StaticRoute (..) - -- * Lookup files in filesystem - , fileLookupDir - , staticFiles - -- * Embed files - , mkEmbedFiles - , getStaticHandler - -- * Hashing - , base64md5 -#if TEST - , testSuite -#endif - ) where - -import System.Directory -import Control.Monad -import Data.Maybe (fromMaybe) - -import Yesod hiding (lift) -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Web.Routes - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | A function for looking up file contents. For serving from the file system, --- see 'fileLookupDir'. -data Static = Static - { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) - -- | Mapping from file extension to content type. See 'typeByExt'. - , staticTypes :: [(String, ContentType)] - } - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [String] [(String, String)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute - -instance YesodSubSite Static master where - getSubSite = Site - { handleSite = \_ (StaticRoute ps _) m -> - case m of - "GET" -> Just $ fmap chooseRep $ getStaticRoute ps - _ -> Nothing - , formatPathSegments = \(StaticRoute x y) -> (x, y) - , parsePathSegments = \x -> Right $ StaticRoute x [] - } - --- | Lookup files in a specific directory. --- --- If you are just using this in combination with the static subsite (you --- probably are), the handler itself checks that no unsafe paths are being --- requested. In particular, no path segments may begin with a single period, --- so hidden files and parent directories are safe. --- --- For the second argument to this function, you can just use 'typeByExt'. -fileLookupDir :: FilePath -> [(String, ContentType)] -> Static -fileLookupDir dir = Static $ \fp -> do - let fp' = dir ++ '/' : fp - exists <- doesFileExist fp' - if exists - then return $ Just $ Left fp' - else return Nothing - --- | Lookup files in a specific directory, and embed them into the haskell source. --- --- A variation of fileLookupDir which allows subsites distributed via cabal to include --- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler --- for dispatching static content for a subsite. -mkEmbedFiles :: FilePath -> Q Exp -mkEmbedFiles d = do - fs <- qRunIO $ getFileList d - clauses <- mapM (mkClause . intercalate "/") fs - defC <- defaultClause - return $ static $ clauses ++ [defC] - where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f - f = mkName "f" - fun clauses = FunD f clauses - defaultClause = do - b <- [| return Nothing |] - return $ Clause [WildP] (NormalB b) [] - - mkClause path = do - content <- qRunIO $ readFile $ d ++ '/':path - let pat = LitP $ StringL path - foldAppE = foldl1 AppE - content' = return $ LitE $ StringL $ content - body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] - return $ Clause [pat] body [] - --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" - -getStaticRoute :: [String] - -> GHandler Static master (ContentType, Content) -getStaticRoute fp' = do - Static fl ctypes <- getYesodSub - when (any isUnsafe fp') notFound - let fp = intercalate "/" fp' - content <- liftIO $ fl fp - case content of - Nothing -> notFound - Just (Left fp'') -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes - sendFile ctype fp'' - Just (Right bs) -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes - return (ctype, bs) - where - isUnsafe [] = True - isUnsafe ('.':_) = True - isUnsafe _ = False - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- lift f - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL hash, ListE []]] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs deleted file mode 100644 index 20a1cc28..00000000 --- a/Yesod/Internal.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Normal users should never need access to these. -module Yesod.Internal - ( -- * Error responses - ErrorResponse (..) - -- * Header - , Header (..) - -- * Cookie names - , langKey - -- * Widgets - , Location (..) - , UniqueList (..) - , Script (..) - , Stylesheet (..) - , Title (..) - , Head (..) - , Body (..) - , locationToHamlet - , runUniqueList - , toUnique - -- * UTF8 helpers - , bsToChars - , lbsToChars - , charsToBs - ) where - -import Text.Hamlet (Hamlet, hamlet, Html) -import Data.Monoid (Monoid (..)) -import Data.List (nub) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | 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 [String] - | PermissionDenied String - | BadMethod String - deriving (Show, Eq) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - deriving (Eq, Show) - -langKey :: String -langKey = "_LANG" - -data Location url = Local url | Remote String - deriving (Show, Eq) -locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [HAMLET|@url@|] -locationToHamlet (Remote s) = [HAMLET|$s$|] - -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -newtype Script url = Script { unScript :: Location url } - deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } - -newtype Head url = Head (Hamlet url) - deriving Monoid -newtype Body url = Body (Hamlet url) - deriving Monoid - -lbsToChars :: L.ByteString -> String -lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode - -bsToChars :: S.ByteString -> String -bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode - -charsToBs :: String -> S.ByteString -charsToBs = T.encodeUtf8 . T.pack diff --git a/Yesod/Request.hs b/Yesod/Request.hs deleted file mode 100644 index 48cc4236..00000000 --- a/Yesod/Request.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Request --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Stable --- Portability : portable --- --- | Provides a parsed version of the raw 'W.Request' data. --- ---------------------------------------------------------- -module Yesod.Request - ( - -- * Request datatype - RequestBodyContents - , Request (..) - , RequestReader (..) - , FileInfo (..) - -- * Convenience functions - , waiRequest - , languages - -- * Lookup parameters - , lookupGetParam - , lookupPostParam - , lookupCookie - , lookupFile - -- ** Multi-lookup - , lookupGetParams - , lookupPostParams - , lookupCookies - , lookupFiles - -- * Parameter type synonyms - , ParamName - , ParamValue - , ParamError - ) where - -import qualified Network.Wai as W -import qualified Data.ByteString.Lazy as BL -import "transformers" Control.Monad.IO.Class -import Control.Monad (liftM) -import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r -import Data.Maybe (listToMaybe) - -type ParamName = String -type ParamValue = String -type ParamError = String - --- | The reader monad specialized for 'Request'. -class Monad m => RequestReader m where - getRequest :: m Request -instance RequestReader ((->) Request) where - getRequest = id - --- | Get the list of supported languages supplied by the user. --- --- Languages are determined based on the following three (in descending order --- of preference): --- --- * The _LANG get parameter. --- --- * The _LANG cookie. --- --- * The _LANG user session variable. --- --- * Accept-Language HTTP header. --- --- This is handled by the parseWaiRequest function in Yesod.Dispatch (not --- exposed). -languages :: RequestReader m => m [String] -languages = reqLangs `liftM` getRequest - --- | Get the request\'s 'W.Request' value. -waiRequest :: RequestReader m => m W.Request -waiRequest = reqWaiRequest `liftM` getRequest - --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: String - , fileContentType :: String - , fileContent :: BL.ByteString - } - deriving (Eq, Show) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(ParamName, ParamValue)] - , reqCookies :: [(ParamName, ParamValue)] - -- | The POST parameters and submitted files. This is stored in an IO - -- thunk, which essentially means it will be computed once at most, but - -- only if requested. This allows avoidance of the potentially costly - -- parsing of POST bodies for pages which do not use them. - -- - -- Additionally, since the request body is not read until needed, you can - -- directly access the 'W.requestBody' record in 'reqWaiRequest' and - -- perform other forms of parsing. For example, when designing a web - -- service, you may want to accept JSON-encoded data. Just be aware that - -- if you do such parsing, the standard POST form parsing functions will - -- no longer work. - , reqRequestBody :: IO RequestBodyContents - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [String] - -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: String - } - -lookup' :: Eq a => a -> [(a, b)] -> [b] -lookup' a = map snd . filter (\x -> a == fst x) - --- | Lookup for GET parameters. -lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] -lookupGetParams pn = do - rr <- getRequest - return $ lookup' pn $ reqGetParams rr - --- | Lookup for GET parameters. -lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupGetParam = liftM listToMaybe . lookupGetParams - --- | Lookup for POST parameters. -lookupPostParams :: (MonadIO m, RequestReader m) - => ParamName - -> m [ParamValue] -lookupPostParams pn = do - rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - return $ lookup' pn pp - -lookupPostParam :: (MonadIO m, RequestReader m) - => ParamName - -> m (Maybe ParamValue) -lookupPostParam = liftM listToMaybe . lookupPostParams - --- | Lookup for POSTed files. -lookupFile :: (MonadIO m, RequestReader m) - => ParamName - -> m (Maybe FileInfo) -lookupFile = liftM listToMaybe . lookupFiles - --- | Lookup for POSTed files. -lookupFiles :: (MonadIO m, RequestReader m) - => ParamName - -> m [FileInfo] -lookupFiles pn = do - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr - return $ lookup' pn files - --- | Lookup for cookie data. -lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupCookie = liftM listToMaybe . lookupCookies - --- | Lookup for cookie data. -lookupCookies :: RequestReader m => ParamName -> m [ParamValue] -lookupCookies pn = do - rr <- getRequest - return $ lookup' pn $ reqCookies rr diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs deleted file mode 100644 index 8a4c4cb8..00000000 --- a/Yesod/Widget.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} --- | Widgets combine HTML with JS and CSS dependencies with a unique identifier --- generator, allowing you to create truly modular HTML components. -module Yesod.Widget - ( -- * Datatype - GWidget (..) - , liftHandler - -- * Creating - -- ** Head of page - , setTitle - , addHamletHead - , addHtmlHead - -- ** Body - , addHamlet - , addHtml - , addWidget - , addSubWidget - -- ** CSS - , addCassius - , addStylesheet - , addStylesheetRemote - , addStylesheetEither - -- ** Javascript - , addJulius - , addScript - , addScriptRemote - , addScriptEither - -- * Utilities - , extractBody - , newIdent - ) where - -import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) -import Control.Applicative (Applicative) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class (lift) -import Yesod.Internal - -import Control.Monad.IO.Peel (MonadPeelIO) - --- | A generic widget, allowing specification of both the subsite and master --- site datatypes. This is basically a large 'WriterT' stack keeping track of --- dependencies along with a 'StateT' to track unique identifiers. -newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO) -type GWInner sub master = - WriterT (Body (Route master)) ( - WriterT (Last Title) ( - WriterT (UniqueList (Script (Route master))) ( - WriterT (UniqueList (Stylesheet (Route master))) ( - WriterT (Maybe (Cassius (Route master))) ( - WriterT (Maybe (Julius (Route master))) ( - WriterT (Head (Route master)) ( - StateT Int ( - GHandler sub master - )))))))) -instance Monoid (GWidget sub master ()) where - mempty = return () - mappend x y = x >> y - -instance HamletValue (GWidget s m ()) where - newtype HamletMonad (GWidget s m ()) a = - GWidget' { runGWidget' :: GWidget s m a } - type HamletUrl (GWidget s m ()) = Route m - toHamletValue = runGWidget' - htmlToHamletMonad = GWidget' . addHtml - urlToHamletMonad url params = GWidget' $ - addHamlet $ \r -> preEscapedString (r url params) - fromHamletValue = GWidget' -instance Monad (HamletMonad (GWidget s m ())) where - return = GWidget' . return - x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y - --- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' --- monad. -liftHandler :: GHandler sub master a -> GWidget sub master a -liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift - -addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do master <- liftHandler getYesod - let sr = fromSubRoute sub master - i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT - $ unGWidget w - let ((((((((a, - body), - title), - scripts), - stylesheets), - style), - jscript), - h), - i') = w' - GWidget $ do - tell body - lift $ tell title - lift $ lift $ tell scripts - lift $ lift $ lift $ tell stylesheets - lift $ lift $ lift $ lift $ tell style - lift $ lift $ lift $ lift $ lift $ tell jscript - lift $ lift $ lift $ lift $ lift $ lift $ tell h - lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' - return a - --- | Set the page title. Calling 'setTitle' multiple times overrides previously --- set values. -setTitle :: Html -> GWidget sub master () -setTitle = GWidget . lift . tell . Last . Just . Title - --- | Add a 'Hamlet' to the head tag. -addHamletHead :: Hamlet (Route master) -> GWidget sub master () -addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head - --- | Add a 'Html' to the head tag. -addHtmlHead :: Html -> GWidget sub master () -addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const - --- | Add a 'Hamlet' to the body tag. -addHamlet :: Hamlet (Route master) -> GWidget sub master () -addHamlet = GWidget . tell . Body - --- | Add a 'Html' to the body tag. -addHtml :: Html -> GWidget sub master () -addHtml = GWidget . tell . Body . const - --- | Add another widget. This is defined as 'id', by can help with types, and --- makes widget blocks look more consistent. -addWidget :: GWidget s m () -> GWidget s m () -addWidget = id - --- | Get a unique identifier. -newIdent :: GWidget sub master String -newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do - i <- get - let i' = i + 1 - put i' - return $ "w" ++ show i' - --- | Add some raw CSS to the style tag. -addCassius :: Cassius (Route master) -> GWidget sub master () -addCassius = GWidget . lift . lift . lift . lift . tell . Just - --- | Link to the specified local stylesheet. -addStylesheet :: Route master -> GWidget sub master () -addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local - --- | Link to the specified remote stylesheet. -addStylesheetRemote :: String -> GWidget sub master () -addStylesheetRemote = - GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote - -addStylesheetEither :: Either (Route master) String -> GWidget sub master () -addStylesheetEither = either addStylesheet addStylesheetRemote - -addScriptEither :: Either (Route master) String -> GWidget sub master () -addScriptEither = either addScript addScriptRemote - --- | Link to the specified local script. -addScript :: Route master -> GWidget sub master () -addScript = GWidget . lift . lift . tell . toUnique . Script . Local - --- | Link to the specified remote script. -addScriptRemote :: String -> GWidget sub master () -addScriptRemote = - GWidget . lift . lift . tell . toUnique . Script . Remote - --- | Include raw Javascript in the page's script tag. -addJulius :: Julius (Route master) -> GWidget sub master () -addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just - --- | Pull out the HTML tag contents and return it. Useful for performing some --- manipulations. It can be easier to use this sometimes than 'wrapWidget'. -extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m)) -extractBody (GWidget w) = - GWidget $ mapWriterT (fmap go) w - where - go ((), Body h) = (h, Body mempty) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs deleted file mode 100644 index ee094a15..00000000 --- a/Yesod/Yesod.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | The basic typeclass for a Yesod application. -module Yesod.Yesod - ( -- * Type classes - Yesod (..) - , YesodSite (..) - , YesodSubSite (..) - -- ** Breadcrumbs - , YesodBreadcrumbs (..) - , breadcrumbs - -- * Utitlities - , maybeAuthorized - , widgetToPageContent - , defaultLayoutJson - , jsonToRepJson - , redirectToPost - -- * Defaults - , defaultErrorHandler - -- * Data types - , AuthResult (..) - -- * Misc - , yesodVersion -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Handler hiding (testSuite) -import qualified Data.ByteString.UTF8 as BSU -#else -import Yesod.Content -import Yesod.Handler -#endif - -import qualified Paths_yesod -import Data.Version (showVersion) -import Yesod.Widget -import Yesod.Request -import Yesod.Hamlet -import qualified Network.Wai as W -import Yesod.Internal -import Web.ClientSession (getKey, defaultKeyFile) -import qualified Web.ClientSession as CS -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State hiding (get) -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Web.Routes -import qualified Data.JSON.Types as J - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class Eq (Route y) => YesodSite y where - getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) -type Method = String - --- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as the mkYesodSub creates instances appropriately. -class Eq (Route s) => YesodSubSite s y where - getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite _ = getSubSite - --- | Define settings for a Yesod applications. The only required setting is --- 'approot'; other than that, there are intelligent defaults. -class Eq (Route a) => Yesod a where - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - -- - -- If you want to be lazy, you can supply an empty string under the - -- following conditions: - -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - approot :: a -> String - - -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO CS.Key - encryptKey _ = getKey defaultKeyFile - - -- | Whether or not to use client sessions. - -- - -- FIXME: A better API would be to have 'encryptKey' return a Maybe, but - -- that would be a breaking change. Please include in Yesod 0.7. - enableClientSessions :: a -> Bool - enableClientSessions _ = True - - -- | 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 -> GHandler sub a ChooseRep - errorHandler = defaultErrorHandler - - -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [HAMLET| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %body - $maybe mmsg msg - %p.message $msg$ - ^pageBody.p^ -|] - - -- | Gets called at the beginning of each request. Useful for logging. - onRequest :: GHandler sub a () - onRequest = return () - - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe String - urlRenderOverride _ _ = Nothing - - -- | Determine if a request is authorized or not. - -- - -- Return 'Nothing' is the request is authorized, 'Just' a message if - -- unauthorized. If authentication is required, you should use a redirect; - -- the Auth helper provides this functionality automatically. - isAuthorized :: Route a - -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult - isAuthorized _ _ = return Authorized - - -- | Determines whether the current request is a write request. By default, - -- this assumes you are following RESTful principles, and determines this - -- from request method. In particular, all except the following request - -- methods are considered write: GET HEAD OPTIONS TRACE. - -- - -- This function is used to determine if a request is authorized; see - -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool - isWriteRequest _ = do - wai <- waiRequest - return $ not $ W.requestMethod wai `elem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - - -- | The default route for authentication. - -- - -- Used in particular by 'isAuthorized', but library users can do whatever - -- they want with it. - authRoute :: a -> Maybe (Route a) - authRoute _ = Nothing - - -- | A function used to split a raw PATH_INFO value into path pieces. It - -- returns a 'Left' value when you should redirect to the given path, and a - -- 'Right' value on successful parse. - -- - -- By default, it splits paths on slashes, and ensures the following are true: - -- - -- * No double slashes - -- - -- * If the last path segment has a period, there is no trailing slash. - -- - -- * Otherwise, ensures there /is/ a trailing slash. - splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ s = - if corrected == s - then Right $ filter (not . null) - $ decodePathInfo - $ S8.unpack s - else Left corrected - where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s - - -- | Remove double slashes - rds :: String -> String - rds [] = [] - rds [x] = [x] - rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - - -- | Add a trailing slash if it is missing. Empty string is left alone. - ats :: String -> String - ats [] = [] - ats t = - if last t == '/' || dbs (reverse t) - then t - else t ++ "/" - - -- | Remove a trailing slash if the last piece has a period. - rts :: String -> String - rts [] = [] - rts t = - if last t == '/' && dbs (tail $ reverse t) - then init t - else t - - -- | Is there a period before a slash here? - dbs :: String -> Bool - dbs ('/':_) = False - dbs (_:'.':_) = True - dbs (_:x) = dbs x - dbs [] = False - - - -- | Join the pieces of a path together into an absolute URL. This should - -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> [(String, String)] -> String - joinPath _ ar pieces qs = - ar ++ '/' : encodePathInfo (fixSegs pieces) qs - where - fixSegs [] = [] - fixSegs [x] - | anyButLast (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash - fixSegs (x:xs) = x : fixSegs xs - anyButLast _ [] = False - anyButLast _ [_] = False - anyButLast p (x:xs) = p x || anyButLast p xs - - -- | This function is used to store some static content to be served as an - -- external file. The most common case of this is stashing CSS and - -- JavaScript content in an external file; the "Yesod.Widget" module uses - -- this feature. - -- - -- The return value is 'Nothing' if no storing was performed; this is the - -- default implementation. A 'Just' 'Left' gives the absolute URL of the - -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is - -- necessary when you are serving the content outside the context of a - -- Yesod application, such as via memcached. - addStaticContent :: String -- ^ filename extension - -> String -- ^ mime-type - -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) - addStaticContent _ _ _ = return Nothing - - -- | Whether or not to tie a session to a specific IP address. Defaults to - -- 'True'. - sessionIpAddress :: a -> Bool - sessionIpAddress _ = True - -data AuthResult = Authorized | AuthenticationRequired | Unauthorized String - deriving (Eq, Show, Read) - --- | A type-safe, concise method of creating breadcrumbs for pages. For each --- resource, you declare the title of the page and the parent resource (if --- present). -class YesodBreadcrumbs y where - -- | Returns the title and the parent resource, if available. If you return - -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) - --- | Gets the title of the current page and the hierarchy of parent pages, --- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) -breadcrumbs = do - x' <- getCurrentRoute - tm <- getRouteToMaster - let x = fmap tm x' - case x of - Nothing -> return ("Not found", []) - Just y -> do - (title, next) <- breadcrumb y - z <- go [] next - return (title, z) - where - go back Nothing = return back - go back (Just this) = do - (title, next) <- breadcrumb this - go ((this, title) : back) next - --- | Provide both an HTML and JSON representation for a piece of data, using --- the default layout for the HTML output ('defaultLayout'). -defaultLayoutJson :: Yesod master - => GWidget sub master () - -> J.Value - -> GHandler sub master RepHtmlJson -defaultLayoutJson w json = do - RepHtml html' <- defaultLayout w - return $ RepHtmlJson html' $ toContent json - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: J.Value -> GHandler sub master RepJson -jsonToRepJson = return . RepJson . toContent - -applyLayout' :: Yesod master - => Html -- ^ title - -> Hamlet (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do - setTitle title - addHamlet body - --- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = bsToChars $ W.pathInfo r - applyLayout' "Not Found" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Not Found -%p $path'$ -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Permission denied -%p $msg$ -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Invalid Arguments -%ul - $forall ia msg - %li $msg$ -|] -defaultErrorHandler (InternalError e) = - applyLayout' "Internal Server Error" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Internal Server Error -%p $e$ -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Method Not Supported -%p Method "$m$" not supported -|] - --- | Return the same URL if the user is authorized to see it. --- --- Built on top of 'isAuthorized'. This is useful for building page that only --- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a - => Route a - -> Bool -- ^ is this a write request? - -> GHandler s a (Maybe (Route a)) -maybeAuthorized r isWrite = do - x <- isAuthorized r isWrite - return $ if x == Authorized then Just r else Nothing - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent (GWidget w) = do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - Last mTitle), - scripts'), - stylesheets'), - style), - jscript), - Head head') = w' - let title = maybe mempty unTitle mTitle - let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' - let stylesheets = map (locationToHamlet . unStylesheet) - $ runUniqueList stylesheets' - let cssToHtml (Css b) = Html b - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = Html b - jelper :: Julius url -> Hamlet url - jelper = fmap jsToHtml - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s - return $ renderLoc x - - let head'' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ - $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ - $nothing - %script ^jelper.j^ -^head'^ -|] - return $ PageContent title head'' body - -#if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Yesod" - [ testProperty "join/split path" propJoinSplitPath - , testCase "join/split path [\".\"]" caseJoinSplitPathDquote - , testCase "utf8 split path" caseUtf8SplitPath - , testCase "utf8 join path" caseUtf8JoinPath - ] - -data TmpYesod = TmpYesod -data TmpRoute = TmpRoute deriving Eq -type instance Route TmpYesod = TmpRoute -instance Yesod TmpYesod where approot _ = "" - -propJoinSplitPath :: [String] -> Bool -propJoinSplitPath ss = - splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - == Right ss' - where - ss' = filter (not . null) ss - -caseJoinSplitPathDquote :: Assertion -caseJoinSplitPathDquote = do - splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."] - splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."] - joinPath TmpYesod "" ["z."] [] @?= "/z./" - x @?= Right ss - where - x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - ss' = filter (not . null) ss - ss = ["a."] - -caseUtf8SplitPath :: Assertion -caseUtf8SplitPath = do - Right ["שלום"] @=? - splitPath TmpYesod (BSU.fromString "/שלום/") - Right ["page", "Fooé"] @=? - splitPath TmpYesod (BSU.fromString "/page/Fooé/") - Right ["\156"] @=? - splitPath TmpYesod (BSU.fromString "/\156/") - Right ["ð"] @=? - splitPath TmpYesod (BSU.fromString "/%C3%B0/") - -caseUtf8JoinPath :: Assertion -caseUtf8JoinPath = do - "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] -#endif - --- | Redirect to a POST resource. --- --- This is not technically a redirect; instead, it returns an HTML page with a --- POST form, and some Javascript to automatically submit the form. This can be --- useful when you need to post a plain link somewhere that needs to cause --- changes on the server. -redirectToPost :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -!!! -%html - %head - %title Redirecting... - %body!onload="document.getElementById('form').submit()" - %form#form!method=post!action=@dest@ - %noscript - %p Javascript has been disabled; please click on the button below to be redirected. - %input!type=submit!value=Continue -|] >>= sendResponse - -yesodVersion :: String -yesodVersion = showVersion Paths_yesod.version diff --git a/blog.hs b/blog.hs deleted file mode 100644 index 722e0515..00000000 --- a/blog.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -import Yesod -import Yesod.Helpers.Auth -import Yesod.Helpers.Crud -import Database.Persist.Sqlite -import Data.Time (Day) - -share2 mkPersist mkIsForm [$persist| -Entry - title String "label=Entry title" "tooltip=Make it something cool" - posted JqueryDay Desc - content NicHtml - deriving -|] -instance Item Entry where - itemTitle = entryTitle - -getAuth = const $ Auth - { authIsOpenIdEnabled = False - , authRpxnowApiKey = Nothing - , authEmailSettings = Nothing - -- | client id, secret and requested permissions - , authFacebook = Just (clientId, secret, ["email"]) - } - where - clientId = "134280699924829" - secret = "a7685e10c8977f5435e599aaf1d232eb" - -data Blog = Blog Connection -type EntryCrud = Crud Blog Entry -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -/auth AuthR Auth getAuth -|] -instance Yesod Blog where - approot _ = "http://localhost:3000" - defaultLayout p = do - mcreds <- maybeCreds - admin <- maybeAuthorized $ AdminR CrudListR - hamletToContent [$hamlet| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666} - %body - %p - %a!href=@RootR@ Homepage - $maybe admin a - \ | $ - %a!href=@a@ Admin - \ | $ - $maybe mcreds c - Welcome $ - $maybe credsDisplayName.c dn - $dn$ - $nothing - $credsIdent.c$ - \ $ - %a!href=@AuthR.Logout@ Logout - $nothing - %a!href=@AuthR.StartFacebookR@ Facebook Connect - ^pageBody.p^ - %p - Powered by Yesod Web Framework -|] - isAuthorized AdminR{} = do - mc <- maybeCreds - let x = (mc >>= credsEmail) == Just "michael@snoyman.com" - return $ if x then Nothing else Just "Permission denied" - isAuthorized _ = return Nothing -instance YesodAuth Blog where - defaultDest _ = RootR - defaultLoginRoute _ = RootR -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = do - Blog conn <- getYesod - runSqlite db conn - -getRootR = do - entries <- runDB $ select [] [EntryPostedDesc] - applyLayoutW $ do - setTitle $ string "Blog tutorial homepage" - addBody [$hamlet| -%h1 All Entries -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -|] - -getEntryR :: EntryId -> Handler Blog RepHtml -getEntryR eid = do - entry <- runDB (get eid) >>= maybe notFound return - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.unJqueryDay.entryPosted.entry$ -#content $unNicHtml.entryContent.entry$ -|] -main = withSqlite "blog.db3" $ \conn -> do - flip runSqlite conn $ initialize (undefined :: Entry) - toWaiApp (Blog conn) >>= basicHandler 3000 diff --git a/blog2.hs b/blog2.hs deleted file mode 100644 index 3a58325f..00000000 --- a/blog2.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -import Yesod -import Yesod.Helpers.Crud -import Yesod.Form.Jquery -import Yesod.Form.Nic -import Database.Persist.Sqlite -import Database.Persist.TH -import Data.Time (Day) - -share2 mkToForm mkPersist [$persist| -Entry - title String id=thetitle - day Day Desc toFormField=YesodJquery.jqueryDayField name=day - content Html' toFormField=YesodNic.nicHtmlField - deriving -|] - -instance Item Entry where - itemTitle = entryTitle - -data Blog = Blog { pool :: Pool Connection } - -type EntryCrud = Crud Blog Entry - -mkYesod "Blog" [$parseRoutes| -/ RootR GET -/entry/#EntryId EntryR GET -/admin AdminR EntryCrud defaultCrud -|] - -instance Yesod Blog where - approot _ = "http://localhost:3000" -instance YesodJquery Blog -instance YesodNic Blog - -instance YesodPersist Blog where - type YesodDB Blog = SqliteReader - runDB db = fmap pool getYesod>>= runSqlite db - -getRootR = do - entries <- runDB $ selectList [] [EntryDayDesc] 0 0 - applyLayoutW $ do - setTitle $ string "Yesod Blog Tutorial Homepage" - addBody [$hamlet| -%h1 Archive -%ul - $forall entries entry - %li - %a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$ -%p - %a!href=@AdminR.CrudListR@ Admin -|] - -getEntryR entryid = do - entry <- runDB $ get404 entryid - applyLayoutW $ do - setTitle $ string $ entryTitle entry - addBody [$hamlet| -%h1 $entryTitle.entry$ -%h2 $show.entryDay.entry$ -$entryContent.entry$ -|] - -withBlog f = withSqlite ":memory:" 8 $ \p -> do - flip runSqlite p $ do - initialize (undefined :: Entry) - f $ Blog p - -main = withBlog $ basicHandler 3000 diff --git a/freeform.hs b/freeform.hs deleted file mode 100644 index 3f8b263a..00000000 --- a/freeform.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-} -import Yesod -import Control.Applicative - -data FreeForm = FreeForm -mkYesod "FreeForm" [$parseRoutes| -/ RootR GET -|] -instance Yesod FreeForm where approot _ = "" - -data Person = Person String Int String - deriving Show - -getRootR = do - ((merr, mperson, form), enctype) <- runFormMonadGet $ do - (name, namef) <- stringField "Name" Nothing - (age, agef) <- intField "Age" $ Just 25 - (color, colorf) <- stringField "Color" Nothing - let (merr, mperson) = - case Person <$> name <*> age <*> color of - FormSuccess p -> (Nothing, Just p) - FormFailure e -> (Just e, Nothing) - FormMissing -> (Nothing, Nothing) - let form = [$hamlet| -Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^. -|] - return (merr, mperson, form) - defaultLayout [$hamlet| -$maybe merr err - %ul!style=color:red - $forall err e - %li $e$ -$maybe mperson person - %p Last person: $show.person$ -%form!method=get!action=@RootR@!enctype=$enctype$ - %p ^form^ - %input!type=submit!value=Submit -|] - -main = basicHandler 3000 FreeForm diff --git a/haddock.sh b/haddock.sh deleted file mode 100755 index 337c58c7..00000000 --- a/haddock.sh +++ /dev/null @@ -1,2 +0,0 @@ -cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html' -scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/ diff --git a/helloworld.hs b/helloworld.hs deleted file mode 100644 index 2a3f8723..00000000 --- a/helloworld.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} -import Yesod -data HelloWorld = HelloWorld -mkYesod "HelloWorld" [$parseRoutes|/ Home GET|] -instance Yesod HelloWorld where approot _ = "" -getHome = return $ RepPlain $ toContent "Hello World!" -main = basicHandler 3000 HelloWorld diff --git a/mail.hs b/mail.hs deleted file mode 100644 index 8e39e0e2..00000000 --- a/mail.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Yesod.Mail -import qualified Data.ByteString.Lazy.Char8 as L -import System.Environment - -main = do - [dest] <- getArgs - let p1 = Part "text/html" None Inline $ L.pack "<h1>Hello World!!!</h1>" - lbs <- L.readFile "mail.hs" - let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs - let mail = Mail - [("To", dest), ("Subject", "mail quine")] - "Plain stuff. Mime-clients should not show it." - [p1, p2] - renderSendMail mail diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 index e3fe7bc8..00000000 --- a/runtests.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Framework (defaultMain) - -import qualified Yesod.Content -import qualified Yesod.Json -import qualified Yesod.Dispatch -import qualified Yesod.Helpers.Static -import qualified Yesod.Yesod -import qualified Yesod.Handler - -main :: IO () -main = defaultMain - [ Yesod.Content.testSuite - , Yesod.Json.testSuite - , Yesod.Dispatch.testSuite - , Yesod.Helpers.Static.testSuite - , Yesod.Yesod.testSuite - , Yesod.Handler.testSuite - ] diff --git a/test/.ignored b/test/.ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/test/bar/baz b/test/bar/baz deleted file mode 100644 index e69de29b..00000000 diff --git a/test/foo b/test/foo deleted file mode 100644 index e69de29b..00000000 diff --git a/test/tmp/ignored b/test/tmp/ignored deleted file mode 100644 index e69de29b..00000000 diff --git a/yesod.cabal b/yesod.cabal index 5aaaf0f4..37bc6cf4 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -20,90 +20,28 @@ flag test description: Build the executable to run unit tests default: False -flag ghc7 - library - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.3 && < 0.4 - , wai-extra >= 0.3 && < 0.4 - , bytestring >= 0.9.1.4 && < 0.10 - , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.12 - , template-haskell - , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.6 && < 0.7 - , blaze-builder >= 0.2.1 && < 0.3 - , transformers >= 0.2 && < 0.3 - , clientsession >= 0.4.0 && < 0.5 - , pureMD5 >= 1.1.0.0 && < 2.2 - , random >= 1.0.0.2 && < 1.1 - , cereal >= 0.2 && < 0.4 - , base64-bytestring >= 0.1 && < 0.2 - , old-locale >= 1.0.0.2 && < 1.1 - , neither >= 0.2 && < 0.3 - , network >= 2.2.1.5 && < 2.4 - , email-validate >= 0.2.5 && < 0.3 - , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.2.3 && < 0.3 - , data-default >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 - , containers >= 0.2 && < 0.5 + build-depends: base >= 4 && < 5 + , yesod-core >= 0.7 && < 0.8 , monad-peel >= 0.1 && < 0.2 - , enumerator >= 0.4 && < 0.5 - , cookie >= 0.0 && < 0.1 - , json-enumerator >= 0.0 && < 0.1 - , json-types >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.3 + , wai >= 0.3 && < 0.4 + , hamlet >= 0.7 && < 0.8 exposed-modules: Yesod - Yesod.Content - Yesod.Dispatch - Yesod.Hamlet - Yesod.Handler - Yesod.Request - Yesod.Widget - Yesod.Yesod - Yesod.Helpers.AtomFeed - Yesod.Helpers.Sitemap - Yesod.Helpers.Static - other-modules: Yesod.Internal - Paths_yesod ghc-options: -Wall executable yesod - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - build-depends: parsec >= 2.1 && < 4 + build-depends: parsec >= 2.1 && < 4 + , text >= 0.11 && < 0.12 + , bytestring >= 0.9 && < 0.10 + , time >= 1.1.4 && < 1.3 + , template-haskell + , directory >= 1.0 && < 1.2 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen extensions: TemplateHaskell -executable runtests - if flag(ghc7) - build-depends: base >= 4.3 && < 5 - cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - if flag(test) - 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 - source-repository head type: git location: git://github.com/snoyberg/yesod.git From 80020fc4d86cd28c9e803173496a9bb50416aba6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 26 Dec 2010 11:06:14 +0200 Subject: [PATCH 555/624] Added warp and warpDebug --- Yesod.hs | 27 +++++++++++++++++++++++++++ yesod.cabal | 1 + 2 files changed, 28 insertions(+) diff --git a/Yesod.hs b/Yesod.hs index 9ff8202c..a0da8aef 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -8,6 +8,9 @@ module Yesod , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Widget + -- * Running your application + , warp + , warpDebug -- * Commonly referenced functions/datatypes , Application , lift @@ -48,10 +51,14 @@ import Text.Julius import Yesod.Request import Yesod.Widget import Network.Wai (Application) +import qualified Network.Wai as W import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Peel (MonadPeelIO) +import Network.Wai.Handler.Warp (run) +import System.IO (stderr, hPutStrLn) + showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -60,3 +67,23 @@ readIntegral s = case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing + +-- | A convenience method to run an application using the Warp webserver on the +-- specified port. Automatically calls 'toWaiApp'. +warp :: (Yesod a, YesodSite a) => Int -> a -> IO () +warp port a = toWaiApp a >>= run port + +-- | Same as 'warp', but also sends a message to stderr for each request, and +-- an \"application launched\" message as well. Can be useful for development. +warpDebug :: (Yesod a, YesodSite a) => Int -> a -> IO () +warpDebug port a = do + hPutStrLn stderr $ "Application launched, listening on port " ++ show port + toWaiApp a >>= run port . debugMiddleware + where + debugMiddleware app req = do + hPutStrLn stderr $ concat + [ show $ W.requestMethod req + , " " + , show $ W.pathInfo req + ] + app req diff --git a/yesod.cabal b/yesod.cabal index 37bc6cf4..acaa9e48 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -27,6 +27,7 @@ library , transformers >= 0.2 && < 0.3 , wai >= 0.3 && < 0.4 , hamlet >= 0.7 && < 0.8 + , warp >= 0.3 && < 0.4 exposed-modules: Yesod ghc-options: -Wall From 5445e3bb7eeadab0f5ef83fcea3bef4f2c4a1968 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 30 Dec 2010 06:37:32 +0200 Subject: [PATCH 556/624] Added all dependencies from scaffolded site --- Yesod.hs | 17 ++++++++--------- yesod.cabal | 7 +++++++ 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index a0da8aef..dd7360bc 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -8,6 +8,9 @@ module Yesod , module Yesod.Handler , module Yesod.Dispatch , module Yesod.Widget + , module Yesod.Form + , module Yesod.Json + , module Yesod.Persist -- * Running your application , warp , warpDebug @@ -50,7 +53,11 @@ import Text.Julius import Yesod.Request import Yesod.Widget +import Yesod.Form +import Yesod.Json +import Yesod.Persist import Network.Wai (Application) +import Network.Wai.Middleware.Debug import qualified Network.Wai as W import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) @@ -78,12 +85,4 @@ warp port a = toWaiApp a >>= run port warpDebug :: (Yesod a, YesodSite a) => Int -> a -> IO () warpDebug port a = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port - toWaiApp a >>= run port . debugMiddleware - where - debugMiddleware app req = do - hPutStrLn stderr $ concat - [ show $ W.requestMethod req - , " " - , show $ W.pathInfo req - ] - app req + toWaiApp a >>= run port . debug diff --git a/yesod.cabal b/yesod.cabal index acaa9e48..78b8f4e5 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -23,11 +23,18 @@ flag test library build-depends: base >= 4 && < 5 , yesod-core >= 0.7 && < 0.8 + , yesod-auth >= 0.3 && < 0.4 + , yesod-form >= 0.0 && < 0.1 + , yesod-json >= 0.0 && < 0.1 + , yesod-persistent >= 0.0 && < 0.1 + , yesod-static >= 0.0 && < 0.1 , monad-peel >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 , wai >= 0.3 && < 0.4 , hamlet >= 0.7 && < 0.8 , warp >= 0.3 && < 0.4 + , mime-mail >= 0.1 && < 0.2 + , hjsmin >= 0.0.5 && < 0.1 exposed-modules: Yesod ghc-options: -Wall From c2d7e49c316ef9b1c6cc28069e852cfc00444a71 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 19 Jan 2011 23:49:00 +0200 Subject: [PATCH 557/624] Newer deps --- yesod.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 78b8f4e5..efe13ed9 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -24,13 +24,14 @@ library build-depends: base >= 4 && < 5 , yesod-core >= 0.7 && < 0.8 , yesod-auth >= 0.3 && < 0.4 - , yesod-form >= 0.0 && < 0.1 , yesod-json >= 0.0 && < 0.1 , yesod-persistent >= 0.0 && < 0.1 , yesod-static >= 0.0 && < 0.1 + , yesod-form >= 0.0 && < 0.1 , monad-peel >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 , hamlet >= 0.7 && < 0.8 , warp >= 0.3 && < 0.4 , mime-mail >= 0.1 && < 0.2 From 98a0545f0ea3fdbd79aa977b566d81d4cb5b50d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Wed, 19 Jan 2011 23:49:13 +0200 Subject: [PATCH 558/624] Remove extensions from scaffolded cabal file --- scaffold/cabal.cg | 2 -- 1 file changed, 2 deletions(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index cbd36003..80f7e76e 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -35,7 +35,6 @@ executable simple-server , web-routes , hjsmin >= 0.0.4 && < 0.1 ghc-options: -Wall - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies executable devel-server if flag(production) @@ -54,5 +53,4 @@ executable fastcgi cpp-options: -DPRODUCTION main-is: fastcgi.hs ghc-options: -Wall -threaded - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies From e9eab1ee8e57e47fd75d166b4f26f00fc2561ed9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 21 Jan 2011 15:56:59 +0200 Subject: [PATCH 559/624] Scaffolded cabal is always threaded --- scaffold/cabal.cg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 80f7e76e..625b614d 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -34,7 +34,7 @@ executable simple-server , hamlet , web-routes , hjsmin >= 0.0.4 && < 0.1 - ghc-options: -Wall + ghc-options: -Wall -threaded executable devel-server if flag(production) @@ -42,7 +42,7 @@ executable devel-server else build-depends: wai-handler-devel >= 0.1.0 && < 0.2 main-is: devel-server.hs - ghc-options: -Wall -O2 + ghc-options: -Wall -O2 -threaded executable fastcgi if flag(production) From 3afb0f7442b0c8335a2b787f73dcaa480f3e7f3c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 31 Jan 2011 12:02:15 +0200 Subject: [PATCH 560/624] Fix up scaffolded site --- Yesod.hs | 5 ++--- scaffold.hs | 4 ++-- scaffold/Controller_hs.cg | 7 +++++-- scaffold/Root_hs.cg | 2 +- scaffold/Settings_hs.cg | 6 +++--- scaffold/cabal.cg | 30 ++++++++++++------------------ scaffold/default-layout_hamlet.cg | 16 ++++++++-------- scaffold/fastcgi_hs.cg | 6 ------ scaffold/favicon_ico.cg | Bin 1150 -> 1150 bytes scaffold/homepage_cassius.cg | 2 +- scaffold/homepage_hamlet.cg | 22 +++++++++++----------- scaffold/homepage_julius.cg | 2 +- scaffold/production_hs.cg | 6 ++++++ scaffold/simple-server_hs.cg | 6 ------ scaffold/sitearg_hs.cg | 20 +++++++++----------- scaffold/test_hs.cg | 11 +++++++++++ yesod.cabal | 2 +- 17 files changed, 73 insertions(+), 74 deletions(-) delete mode 100644 scaffold/fastcgi_hs.cg create mode 100644 scaffold/production_hs.cg delete mode 100644 scaffold/simple-server_hs.cg create mode 100644 scaffold/test_hs.cg diff --git a/Yesod.hs b/Yesod.hs index dd7360bc..d73cc3e6 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -58,7 +58,6 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug -import qualified Network.Wai as W import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Peel (MonadPeelIO) @@ -77,12 +76,12 @@ readIntegral s = -- | A convenience method to run an application using the Warp webserver on the -- specified port. Automatically calls 'toWaiApp'. -warp :: (Yesod a, YesodSite a) => Int -> a -> IO () +warp :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warp port a = toWaiApp a >>= run port -- | Same as 'warp', but also sends a message to stderr for each request, and -- an \"application launched\" message as well. Can be useful for development. -warpDebug :: (Yesod a, YesodSite a) => Int -> a -> IO () +warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warpDebug port a = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port toWaiApp a >>= run port . debug diff --git a/scaffold.hs b/scaffold.hs index cfca5303..b0da7867 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -63,8 +63,8 @@ main = do mkDir "cassius" mkDir "julius" - writeFile' "simple-server.hs" $(codegen "simple-server_hs") - writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") + writeFile' "test.hs" $(codegen "test_hs") + writeFile' "production.hs" $(codegen "production_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 96885c3d..8aafe2b2 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~ @@ -9,6 +11,7 @@ import Settings import Yesod.Helpers.Static import Yesod.Helpers.Auth import Database.Persist.GenericSql +import Data.ByteString (ByteString) -- Import all relevant handler modules here. import Handler.Root @@ -24,7 +27,7 @@ getFaviconR :: Handler () getFaviconR = sendFile "image/x-icon" "favicon.ico" getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent "User-agent: *" +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- This function allocates resources (such as a database connection pool), -- performs initialization and creates a WAI application. This is also the @@ -36,5 +39,5 @@ with~sitearg~ f = Settings.withConnectionPool $ \p -> do let h = ~sitearg~ s p toWaiApp h >>= f where - s = fileLookupDir Settings.staticdir typeByExt + s = static Settings.staticdir diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index 2c3f42f9..67cd987e 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -14,7 +14,7 @@ getRootR :: Handler RepHtml getRootR = do mu <- maybeAuth defaultLayout $ do - h2id <- newIdent + h2id <- lift newIdent setTitle "~project~ homepage" addWidget $(widgetFile "homepage") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index dad79c92..9becff92 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -24,7 +24,7 @@ import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~ -import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) +import Yesod (MonadPeelIO, addWidget, addCassius, addJulius) import Data.Monoid (mempty) import System.Directory (doesFileExist) @@ -139,9 +139,9 @@ widgetFile x = do -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself. -withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a +withConnectionPool :: MonadPeelIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool :: MonadPeelIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 625b614d..f8707e93 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -16,41 +16,35 @@ Flag production Description: Build the production executable. Default: False -executable simple-server +executable ~project~-test if flag(production) Buildable: False - main-is: simple-server.hs + main-is: test.hs build-depends: base >= 4 && < 5 - , yesod >= 0.6 && < 0.7 - , yesod-auth >= 0.2 && < 0.3 - , mime-mail >= 0.0 && < 0.1 + , yesod >= 0.7 && < 0.8 + , yesod-auth + , yesod-static + , mime-mail , wai-extra , directory , bytestring , text - , persistent >= 0.3.1.1 + , persistent , persistent-~lower~ , template-haskell , hamlet , web-routes - , hjsmin >= 0.0.4 && < 0.1 + , hjsmin + , transformers + , warp ghc-options: -Wall -threaded -executable devel-server - if flag(production) - Buildable: False - else - build-depends: wai-handler-devel >= 0.1.0 && < 0.2 - main-is: devel-server.hs - ghc-options: -Wall -O2 -threaded - -executable fastcgi +executable ~project~-production if flag(production) Buildable: True - build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 else Buildable: False cpp-options: -DPRODUCTION - main-is: fastcgi.hs + main-is: production.hs ghc-options: -Wall -threaded diff --git a/scaffold/default-layout_hamlet.cg b/scaffold/default-layout_hamlet.cg index 3bcfae41..f31acb19 100644 --- a/scaffold/default-layout_hamlet.cg +++ b/scaffold/default-layout_hamlet.cg @@ -1,10 +1,10 @@ !!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ +<html + <head + <title>#{pageTitle pc} + ^{pageHead pc} + <body + $maybe msg <- mmsg + <div #message>#{msg} + ^{pageBody pc} diff --git a/scaffold/fastcgi_hs.cg b/scaffold/fastcgi_hs.cg deleted file mode 100644 index d946d7c7..00000000 --- a/scaffold/fastcgi_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.FastCGI (run) - -main :: IO () -main = with~sitearg~ run - diff --git a/scaffold/favicon_ico.cg b/scaffold/favicon_ico.cg index 4613ed03a65f518e28cd421beb06f346bedf0e1e..9888b98f958ff23094403e2f8ce27894d1f186c3 100644 GIT binary patch literal 1150 zcmZQzU<5(|0R|wcz>vYhz#zuJz@P!dKp~(AL>x#lFaYJy!T<mN8DRL$oA07oSx3(W z1nmB_XU~%;m^iWY#EDmC6cwE~R9=2+x3BN6ukYXg5GGbHNF7N3pFe*YK)9*t-0BS* z9%PfE|J=FPjxhDtufI2~tv$0D#wV2qxgjy};H}@k|1guP7pA_j@c5A%H{Kh;_@vMe zAAVBv^xW}x{rdYPg#pZto}NpyJv?^&Z*RY_3?@b_{qp5EDIcGmKN1oS-bqP0e3e*z zFm*F$Uhe_f4Rm{MY3a$mAoE~ygy@eSe+q)qUvTiAcb`B1;+Z@5X6u0i&q4|5gUK&l zdb=8A_w3o%J3(T{j=k`iJo)M*m^?oE+qd7GVPSh;dU@^q_2R`>S&&*#8U}>}C_TXR z-o5)#7sf`Wf$231TbO5L967&l-_tOV+DDH*tFB#pzW`Yuhz&|-ad8Lkf%F5@t}(Lw ziWPS%K=DymcV>N5)c(g;uDr8AmItwcY2O}XPiyOWjQ9rm3n;!E7^ZK5anp^g_w#=S hhKE4>7Ks0$;Xm~Z3?TdyhW9fte1_uZ#~Bzv7y!I9`)dFI literal 1150 zcmai!--{Aa6vuBE1--NoL@%*DMlV4SK@YvvbI>1A&%MMFkx;b$VAM=knRM14tGhdn zKgLy=5mzPMY}H+Vu&V{pO1TjD=7Wf6r+Z!QAk#oIeCOPI=6udMocV#!IeacHA$+}o zo}EYNDnjTc7ItCJnI9X3@ICbb07$KV|JU`z1{-_7V*QpAa;xoT`|fl){U=V%jmKkM zUP?ZfL-t`y4ghcTK{L>TeNS~3Wum?8R@Qb<J$NvgOmu4YsNJ}q@Yx$p$q$5`^A^{f zCpoBUTpf5*<o9X+^cu-A7!0nYBLTJ~xMq~2mbWtsM|o=Nd-cbJ4>{lUXuR5r9uw(Z zGsh>fWFUNI)74OObbpxffv_6U<R!0MApEWv4%2uo%bU(-Nc*NX$?Octyvw`kS6UqP z@s>5s`ecrsqt5O6m+})Dt7SRk8z{T?G;>sPm8acq=T<GnDbI}NsHMEHW;1~;m<E$q z1dBNY+}kjGW-Cgr{C1ujjYbzzK4wfgVtLjK2FE)1<t7BOEk$H+WaD7PxqLWR#3CG% z8KyRz9l{lOCs?dDaK}mtv&b*5-Ldk_z~Ca7m!p2+qumG$7ymCudawtR->db;L;6h= z3dKjxV7&NYJ3n2lp<X*8#mQDeG7pEtOQfz^KTb}TMXB)8wjS$xcJ^nKpVtf|4v#xu z@2DBAJ?X2_YTw%wvktRI_?gJ$UXXW1Gxjw?<I4#3bO`CO@J~dM9<S%ZE<F{FDPF|P JGD3ea`xmCx5C#AM diff --git a/scaffold/homepage_cassius.cg b/scaffold/homepage_cassius.cg index c2873e00..2ac20924 100644 --- a/scaffold/homepage_cassius.cg +++ b/scaffold/homepage_cassius.cg @@ -1,5 +1,5 @@ h1 text-align: center -h2#$h2id$ +h2##{h2id} color: #990 diff --git a/scaffold/homepage_hamlet.cg b/scaffold/homepage_hamlet.cg index 55bf9683..727f0eb6 100644 --- a/scaffold/homepage_hamlet.cg +++ b/scaffold/homepage_hamlet.cg @@ -1,13 +1,13 @@ -%h1 Hello -%h2#$h2id$ You do not have Javascript enabled. -$maybe mu u - %p - You are logged in as $userIdent.snd.u$. $ - %a!href=@AuthR.LogoutR@ Logout - \. +<h1>Hello +<h2 ##{h2id}>You do not have Javascript enabled. +$maybe u <- mu + <p + You are logged in as #{userIdent $ snd u}. # + <a href=@{AuthR LogoutR}>Logout + . $nothing - %p - You are not logged in. $ - %a!href=@AuthR.LoginR@ Login now - \. + <p + You are not logged in. # + <a href=@{AuthR LoginR}>Login now + . diff --git a/scaffold/homepage_julius.cg b/scaffold/homepage_julius.cg index 281c89aa..9b38774d 100644 --- a/scaffold/homepage_julius.cg +++ b/scaffold/homepage_julius.cg @@ -1,4 +1,4 @@ window.onload = function(){ - document.getElementById("%h2id%").innerHTML = "<i>Added from JavaScript.</i>"; + document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>"; } diff --git a/scaffold/production_hs.cg b/scaffold/production_hs.cg new file mode 100644 index 00000000..3ca59728 --- /dev/null +++ b/scaffold/production_hs.cg @@ -0,0 +1,6 @@ +import Controller (with~sitearg~) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = with~sitearg~ $ run 3000 + diff --git a/scaffold/simple-server_hs.cg b/scaffold/simple-server_hs.cg deleted file mode 100644 index 9a630481..00000000 --- a/scaffold/simple-server_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.SimpleServer (run) - -main :: IO () -main = putStrLn "Loaded" >> with~sitearg~ (run 3000) - diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index f83f8335..e678fff7 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -22,7 +22,6 @@ import Yesod.Helpers.Auth.Email import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L -import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model @@ -94,11 +93,7 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ format s - where - format = formatPathSegments ss - ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) - ss = getSubSite + Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. @@ -126,7 +121,8 @@ instance Yesod ~sitearg~ where -- How to run database actions. instance YesodPersist ~sitearg~ where type YesodDB ~sitearg~ = SqlPersist - runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db + runDB db = liftIOHandler + $ fmap connPool getYesod >>= Settings.runConnectionPool db instance YesodAuth ~sitearg~ where type AuthId ~sitearg~ = UserId @@ -179,17 +175,19 @@ instance YesodAuthEmail ~sitearg~ where , "" , "Thank you" ] + , partHeaders = [] } htmlPart = Part { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing , partContent = renderHtml [~qq~hamlet| -%p Please confirm your email address by clicking on the link below. -%p - %a!href=$verurl$ $verurl$ -%p Thank you +<p>Please confirm your email address by clicking on the link below. +<p> + <a href=#{verurl} #{verurl} +<p>Thank you |] + , partHeaders = [] } getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg new file mode 100644 index 00000000..5b0089f9 --- /dev/null +++ b/scaffold/test_hs.cg @@ -0,0 +1,11 @@ +import Controller (with~sitearg~) +import System.IO (hPutStrLn, stderr) +import Network.Wai.Middleware.Debug (debug) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = do + let port = 3000 + hPutStrLn stderr $ "Application launched, listening on port " ++ show port + with~sitearg~ $ run port . debug + diff --git a/yesod.cabal b/yesod.cabal index efe13ed9..618397ed 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -35,7 +35,7 @@ library , hamlet >= 0.7 && < 0.8 , warp >= 0.3 && < 0.4 , mime-mail >= 0.1 && < 0.2 - , hjsmin >= 0.0.5 && < 0.1 + , hjsmin >= 0.0.12 && < 0.1 exposed-modules: Yesod ghc-options: -Wall From 3afd3cff39539e1906494d1c76ae288d4b326303 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 1 Feb 2011 08:13:26 +0200 Subject: [PATCH 561/624] develServer --- Yesod.hs | 57 ++++++++++++++++++++++++++++++++++++- scaffold/cabal.cg | 8 ++++++ scaffold/devel-server_hs.cg | 19 ++----------- yesod.cabal | 2 ++ 4 files changed, 68 insertions(+), 18 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index d73cc3e6..6230a186 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module simply re-exports from other modules for your convenience. module Yesod ( -- * Re-exports from yesod-core @@ -14,6 +14,7 @@ module Yesod -- * Running your application , warp , warpDebug + , develServer -- * Commonly referenced functions/datatypes , Application , lift @@ -58,6 +59,7 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug +import Network.Wai.Handler.DevelServer (runQuit) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Peel (MonadPeelIO) @@ -65,6 +67,12 @@ import Control.Monad.IO.Peel (MonadPeelIO) import Network.Wai.Handler.Warp (run) import System.IO (stderr, hPutStrLn) +import qualified Data.Text.Lazy.IO as TIO +import qualified Data.Attoparsec.Text.Lazy as A +import Control.Applicative ((<|>)) +import Data.Maybe (mapMaybe) +import Data.Char (isSpace) + showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -85,3 +93,50 @@ warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warpDebug port a = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port toWaiApp a >>= run port . debug + +-- | Run a development server, where your code changes are automatically +-- reloaded. +develServer :: Int -- ^ port number + -> String -- ^ module name holding the code + -> String -- ^ name of function providing a with-application + -> IO () +develServer port modu func = do + mapM_ putStrLn + [ "Starting your server process. Code changes will be automatically" + , "loaded as you save your files. Type \"quit\" to exit." + , "You can view your app at http://localhost:" ++ show port ++ "/" + , "" + ] + runQuit port modu func determineHamletDeps + +data TempType = Hamlet | Cassius | Julius | Widget + deriving Show + +-- | Determine which Hamlet files a Haskell file depends upon. +determineHamletDeps :: FilePath -> IO [FilePath] +determineHamletDeps x = do + y <- TIO.readFile x + let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y + case z of + A.Fail{} -> return [] + A.Done _ r -> return $ mapMaybe go r + where + go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go _ = Nothing + parser = do + typ <- (A.string "$(hamletFile " >> return Hamlet) + <|> (A.string "$(cassiusFile " >> return Cassius) + <|> (A.string "$(juliusFile " >> return Julius) + <|> (A.string "$(widgetFile " >> return Widget) + <|> (A.string "$(Settings.hamletFile " >> return Hamlet) + <|> (A.string "$(Settings.cassiusFile " >> return Cassius) + <|> (A.string "$(Settings.juliusFile " >> return Julius) + <|> (A.string "$(Settings.widgetFile " >> return Widget) + A.skipWhile isSpace + _ <- A.char '"' + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.char '"' + A.skipWhile isSpace + _ <- A.char ')' + return $ Just (typ, y) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index f8707e93..db4f82fe 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -48,3 +48,11 @@ executable ~project~-production main-is: production.hs ghc-options: -Wall -threaded +executable ~project~-devel + if flag(production) + Buildable: False + else + build-depends: wai-handler-devel >= 0.2 && < 0.3 + main-is: devel-server.hs + ghc-options: -Wall -O2 + diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg index 9235a5c6..c0dfa02b 100644 --- a/scaffold/devel-server_hs.cg +++ b/scaffold/devel-server_hs.cg @@ -1,20 +1,5 @@ -import Network.Wai.Handler.DevelServer (run) -import Control.Concurrent (forkIO) +import Yesod (develServer) main :: IO () -main = do - mapM_ putStrLn - [ "Starting your server process. Code changes will be automatically" - , "loaded as you save your files. Type \"quit\" to exit." - , "You can view your app at http://localhost:3000/" - , "" - ] - _ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"] - go - where - go = do - x <- getLine - case x of - 'q':_ -> putStrLn "Quitting, goodbye!" - _ -> go +main = develServer 3000 "Controller" "with~sitearg~" diff --git a/yesod.cabal b/yesod.cabal index 618397ed..20c8c2d5 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -36,6 +36,8 @@ library , warp >= 0.3 && < 0.4 , mime-mail >= 0.1 && < 0.2 , hjsmin >= 0.0.12 && < 0.1 + , wai-handler-devel >= 0.2 && < 0.3 + , attoparsec-text >= 0.8 && < 0.9 exposed-modules: Yesod ghc-options: -Wall From 2d6ef1f95412d5c8e40770509839523be47799c6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 1 Feb 2011 23:00:36 +0200 Subject: [PATCH 562/624] scaffold.hs checks for valid entries --- scaffold.hs | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index b0da7867..b10b79a4 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -18,6 +18,15 @@ qq = "" qq = "$" #endif +prompt :: (String -> Bool) -> IO String +prompt f = do + s <- getLine + if f s + then return s + else do + putStrLn "That was not a valid entry, please try again: " + prompt f + main :: IO () main = do putStr $(codegen "welcome") @@ -26,7 +35,14 @@ main = do putStr $(codegen "project-name") hFlush stdout - project <- getLine + let validPN c + | 'A' <= c && c <= 'Z' = True + | 'a' <= c && c <= 'z' = True + | '0' <= c && c <= '9' = True + validPN '-' = True + validPN '_' = True + validPN _ = False + project <- prompt $ all validPN putStr $(codegen "dir-name") hFlush stdout @@ -35,11 +51,12 @@ main = do putStr $(codegen "site-arg") hFlush stdout - sitearg <- getLine + let isUpperAZ c = 'A' <= c && c <= 'Z' + sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) putStr $(codegen "database") hFlush stdout - backendS <- getLine + backendS <- prompt $ flip elem ["s", "p"] let pconn1 = $(codegen "pconn1") let pconn2 = $(codegen "pconn2") let (lower, upper, connstr1, connstr2) = From fb3e6fa73fb2a32be4c7675cef854303d13527b7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 4 Feb 2011 12:01:17 +0200 Subject: [PATCH 563/624] devel executable builds threaded --- scaffold/cabal.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index db4f82fe..e168a1a9 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -54,5 +54,5 @@ executable ~project~-devel else build-depends: wai-handler-devel >= 0.2 && < 0.3 main-is: devel-server.hs - ghc-options: -Wall -O2 + ghc-options: -Wall -O2 -threaded From b2fbdb4f65eafb939c2719c7344a8d21f75f9048 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sat, 5 Feb 2011 21:52:39 +0200 Subject: [PATCH 564/624] GHC7 fixes --- Yesod.hs | 7 +++++++ scaffold/Model_hs.cg | 2 +- scaffold/cabal.cg | 2 -- yesod.cabal | 21 +++++++++++++++------ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 6230a186..ef68df43 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | This module simply re-exports from other modules for your convenience. module Yesod ( -- * Re-exports from yesod-core @@ -59,7 +60,9 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug +#if !GHC7 import Network.Wai.Handler.DevelServer (runQuit) +#endif import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Peel (MonadPeelIO) @@ -100,6 +103,9 @@ develServer :: Int -- ^ port number -> String -- ^ module name holding the code -> String -- ^ name of function providing a with-application -> IO () +#if GHC7 +develServer = error "Unfortunately, the hint package has not yet been ported to GHC 7, and therefore wai-handler-devel has not either. Once this situation is addressed, a new version of Yesod will be released." +#else develServer port modu func = do mapM_ putStrLn [ "Starting your server process. Code changes will be automatically" @@ -108,6 +114,7 @@ develServer port modu func = do , "" ] runQuit port modu func determineHamletDeps +#endif data TempType = Hamlet | Cassius | Julius | Widget deriving Show diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index d97260a5..4c31eee7 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell #-} module Model where import Yesod diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index e168a1a9..179849aa 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -51,8 +51,6 @@ executable ~project~-production executable ~project~-devel if flag(production) Buildable: False - else - build-depends: wai-handler-devel >= 0.2 && < 0.3 main-is: devel-server.hs ghc-options: -Wall -O2 -threaded diff --git a/yesod.cabal b/yesod.cabal index 20c8c2d5..2cf68f7a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,13 +16,16 @@ build-type: Simple homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg -flag test - description: Build the executable to run unit tests - default: False +flag ghc7 library - build-depends: base >= 4 && < 5 - , yesod-core >= 0.7 && < 0.8 + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + , wai-handler-devel >= 0.2 && < 0.3 + build-depends: yesod-core >= 0.7 && < 0.8 , yesod-auth >= 0.3 && < 0.4 , yesod-json >= 0.0 && < 0.1 , yesod-persistent >= 0.0 && < 0.1 @@ -36,12 +39,16 @@ library , warp >= 0.3 && < 0.4 , mime-mail >= 0.1 && < 0.2 , hjsmin >= 0.0.12 && < 0.1 - , wai-handler-devel >= 0.2 && < 0.3 , attoparsec-text >= 0.8 && < 0.9 exposed-modules: Yesod ghc-options: -Wall executable yesod + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 build-depends: parsec >= 2.1 && < 4 , text >= 0.11 && < 0.12 , bytestring >= 0.9 && < 0.10 @@ -52,6 +59,8 @@ executable yesod main-is: scaffold.hs other-modules: CodeGen extensions: TemplateHaskell + if flag(ghc7) + cpp-options: -DGHC7 source-repository head type: git From 4ee1a95a1fada0a9e96fe3c9cc3d33de5fa5ae22 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 7 Feb 2011 22:40:17 +0200 Subject: [PATCH 565/624] production flag for disabling wai-handler-devel dependency --- Yesod.hs | 6 +++++- yesod.cabal | 11 +++++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index ef68df43..c82e5c50 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,7 +15,9 @@ module Yesod -- * Running your application , warp , warpDebug +#if !PRODUCTION , develServer +#endif -- * Commonly referenced functions/datatypes , Application , lift @@ -60,7 +62,7 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug -#if !GHC7 +#if !GHC7 && !PRODUCTION import Network.Wai.Handler.DevelServer (runQuit) #endif import Control.Monad.Trans.Class (lift) @@ -97,6 +99,7 @@ warpDebug port a = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port toWaiApp a >>= run port . debug +#if !PRODUCTION -- | Run a development server, where your code changes are automatically -- reloaded. develServer :: Int -- ^ port number @@ -115,6 +118,7 @@ develServer port modu func = do ] runQuit port modu func determineHamletDeps #endif +#endif data TempType = Hamlet | Cassius | Julius | Widget deriving Show diff --git a/yesod.cabal b/yesod.cabal index 2cf68f7a..95b3741e 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.7.0 +version: 0.7.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -18,13 +18,20 @@ extra-source-files: scaffold/*.cg flag ghc7 +flag production + Description: Skip the wai-handler-devel and hint dependencies. + Default: False + library if flag(ghc7) build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - , wai-handler-devel >= 0.2 && < 0.3 + if flag(production) + cpp-options: -DPRODUCTION + else + build-depends: wai-handler-devel >= 0.2 && < 0.3 build-depends: yesod-core >= 0.7 && < 0.8 , yesod-auth >= 0.3 && < 0.4 , yesod-json >= 0.0 && < 0.1 From 3afbdb7d228d23e1dad6a94fb4eeb830361459d8 Mon Sep 17 00:00:00 2001 From: Ian Duncan <iand675@gmail.com> Date: Mon, 14 Feb 2011 01:07:24 -0600 Subject: [PATCH 566/624] Removed GHC 7 error message from development server mode compilation since hint works with GHC 7 correctly now. --- Yesod.hs | 8 +++----- yesod.cabal | 8 ++++---- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index c82e5c50..deaccfb9 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -62,7 +62,7 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug -#if !GHC7 && !PRODUCTION +#if !PRODUCTION import Network.Wai.Handler.DevelServer (runQuit) #endif import Control.Monad.Trans.Class (lift) @@ -106,9 +106,7 @@ develServer :: Int -- ^ port number -> String -- ^ module name holding the code -> String -- ^ name of function providing a with-application -> IO () -#if GHC7 -develServer = error "Unfortunately, the hint package has not yet been ported to GHC 7, and therefore wai-handler-devel has not either. Once this situation is addressed, a new version of Yesod will be released." -#else + develServer port modu func = do mapM_ putStrLn [ "Starting your server process. Code changes will be automatically" @@ -117,7 +115,7 @@ develServer port modu func = do , "" ] runQuit port modu func determineHamletDeps -#endif + #endif data TempType = Hamlet | Cassius | Julius | Widget diff --git a/yesod.cabal b/yesod.cabal index 95b3741e..a75961b2 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -23,15 +23,15 @@ flag production Default: False library + if flag(production) + cpp-options: -DPRODUCTION + else + build-depends: wai-handler-devel >= 0.2 && < 0.3 if flag(ghc7) build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - if flag(production) - cpp-options: -DPRODUCTION - else - build-depends: wai-handler-devel >= 0.2 && < 0.3 build-depends: yesod-core >= 0.7 && < 0.8 , yesod-auth >= 0.3 && < 0.4 , yesod-json >= 0.0 && < 0.1 From 4344f269d64f197e305af6b31a75e7ee0100100c Mon Sep 17 00:00:00 2001 From: Michael <michael@snoyman.com> Date: Mon, 14 Feb 2011 11:23:06 +0200 Subject: [PATCH 567/624] Version bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index a75961b2..9b30d864 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.7.0.1 +version: 0.7.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From c3b8b49082d04b38b4f8234c36725862f6117005 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sun, 13 Feb 2011 16:35:55 -0800 Subject: [PATCH 568/624] add QuasiQuotes for hamlet --- scaffold/Root_hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index 67cd987e..d281f767 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module Handler.Root where import ~sitearg~ From c6aeba555d03af52b11c3a8534991460b93dfdf3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 15 Feb 2011 08:28:28 +0200 Subject: [PATCH 569/624] Some version bumps --- yesod.cabal | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 9b30d864..3ad00a7f 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -32,21 +32,21 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: yesod-core >= 0.7 && < 0.8 + build-depends: yesod-core >= 0.7.0.1 && < 0.8 , yesod-auth >= 0.3 && < 0.4 - , yesod-json >= 0.0 && < 0.1 - , yesod-persistent >= 0.0 && < 0.1 + , yesod-json >= 0.0.0.1 && < 0.1 + , yesod-persistent >= 0.0.0.1 && < 0.1 , yesod-static >= 0.0 && < 0.1 - , yesod-form >= 0.0 && < 0.1 + , yesod-form >= 0.0.0.1 && < 0.1 , monad-peel >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 , wai >= 0.3 && < 0.4 - , wai-extra >= 0.3 && < 0.4 - , hamlet >= 0.7 && < 0.8 - , warp >= 0.3 && < 0.4 - , mime-mail >= 0.1 && < 0.2 + , wai-extra >= 0.3.2 && < 0.4 + , hamlet >= 0.7.1 && < 0.8 + , warp >= 0.3.2.1 && < 0.4 + , mime-mail >= 0.1.0.1 && < 0.2 , hjsmin >= 0.0.12 && < 0.1 - , attoparsec-text >= 0.8 && < 0.9 + , attoparsec-text >= 0.8.2.1 && < 0.9 exposed-modules: Yesod ghc-options: -Wall From d5c0e5381ae38c20e6f6cf19120ad914d050db39 Mon Sep 17 00:00:00 2001 From: Ian Duncan <iand675@gmail.com> Date: Thu, 17 Feb 2011 10:48:13 -0600 Subject: [PATCH 570/624] Added StaticFiles scaffold file and relevant code necessary to generate it with the scaffolding tool. --- scaffold.hs | 7 +++++-- scaffold/StaticFiles_hs.cg | 11 +++++++++++ scaffold/sitearg_hs.cg | 1 + 3 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 scaffold/StaticFiles_hs.cg diff --git a/scaffold.hs b/scaffold.hs index b10b79a4..4cd75d07 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -79,7 +79,8 @@ main = do mkDir "hamlet" mkDir "cassius" mkDir "julius" - + mkDir "static" + writeFile' "test.hs" $(codegen "test_hs") writeFile' "production.hs" $(codegen "production_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") @@ -90,6 +91,7 @@ main = do writeFile' "Handler/Root.hs" $(codegen "Root_hs") writeFile' "Model.hs" $(codegen "Model_hs") writeFile' "Settings.hs" $(codegen "Settings_hs") + writeFile' "StaticFiles.hs" $(codegen "StaticFiles_hs") writeFile' "cassius/default-layout.cassius" $(codegen "default-layout_cassius") writeFile' "hamlet/default-layout.hamlet" @@ -97,8 +99,9 @@ main = do writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet") writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") writeFile' "julius/homepage.julius" $(codegen "homepage_julius") - + S.writeFile (dir ++ "/favicon.ico") $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) + \ No newline at end of file diff --git a/scaffold/StaticFiles_hs.cg b/scaffold/StaticFiles_hs.cg new file mode 100644 index 00000000..40178be5 --- /dev/null +++ b/scaffold/StaticFiles_hs.cg @@ -0,0 +1,11 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module StaticFiles where +import Yesod +import Yesod.Helpers.Static + +-- | This generates easy references to files in the static directory at compile time. +-- The upside to this is that you have compile-time verification that referenced files +-- exist. However, any files added to your static directory during run-time can't be +-- accessed this way. You'll have to use their FilePath or URL to access them. +$(staticFiles "static") + diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index e678fff7..84203aeb 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -25,6 +25,7 @@ import qualified Data.ByteString.Lazy as L import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model +import StaticFiles import Data.Maybe (isJust) import Control.Monad (join, unless) import Network.Mail.Mime From 3251f8b6bc06ede86b6ec22d841eaf71111d6acb Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 24 Mar 2011 08:48:19 +0200 Subject: [PATCH 571/624] Call devel-server as separate executable --- Yesod.hs | 63 +++++++++++------------------------------------------ yesod.cabal | 13 ++--------- 2 files changed, 15 insertions(+), 61 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index deaccfb9..a9053991 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,9 +15,7 @@ module Yesod -- * Running your application , warp , warpDebug -#if !PRODUCTION , develServer -#endif -- * Commonly referenced functions/datatypes , Application , lift @@ -62,9 +60,6 @@ import Yesod.Json import Yesod.Persist import Network.Wai (Application) import Network.Wai.Middleware.Debug -#if !PRODUCTION -import Network.Wai.Handler.DevelServer (runQuit) -#endif import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Peel (MonadPeelIO) @@ -72,12 +67,6 @@ import Control.Monad.IO.Peel (MonadPeelIO) import Network.Wai.Handler.Warp (run) import System.IO (stderr, hPutStrLn) -import qualified Data.Text.Lazy.IO as TIO -import qualified Data.Attoparsec.Text.Lazy as A -import Control.Applicative ((<|>)) -import Data.Maybe (mapMaybe) -import Data.Char (isSpace) - showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -99,7 +88,6 @@ warpDebug port a = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port toWaiApp a >>= run port . debug -#if !PRODUCTION -- | Run a development server, where your code changes are automatically -- reloaded. develServer :: Int -- ^ port number @@ -107,45 +95,20 @@ develServer :: Int -- ^ port number -> String -- ^ name of function providing a with-application -> IO () -develServer port modu func = do +develServer port modu func = mapM_ putStrLn - [ "Starting your server process. Code changes will be automatically" - , "loaded as you save your files. Type \"quit\" to exit." - , "You can view your app at http://localhost:" ++ show port ++ "/" + [ "Due to issues with GHC 7.0.2, you must now run the devel server" + , "separately. To do so, ensure you have installed the " + , "wai-handler-devel package >= 0.2.1 and run:" + , concat + [ " wai-handler-devel " + , show port + , " " + , modu + , " " + , func + , " --yesod" + ] , "" ] - runQuit port modu func determineHamletDeps -#endif - -data TempType = Hamlet | Cassius | Julius | Widget - deriving Show - --- | Determine which Hamlet files a Haskell file depends upon. -determineHamletDeps :: FilePath -> IO [FilePath] -determineHamletDeps x = do - y <- TIO.readFile x - let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y - case z of - A.Fail{} -> return [] - A.Done _ r -> return $ mapMaybe go r - where - go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" - go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" - go _ = Nothing - parser = do - typ <- (A.string "$(hamletFile " >> return Hamlet) - <|> (A.string "$(cassiusFile " >> return Cassius) - <|> (A.string "$(juliusFile " >> return Julius) - <|> (A.string "$(widgetFile " >> return Widget) - <|> (A.string "$(Settings.hamletFile " >> return Hamlet) - <|> (A.string "$(Settings.cassiusFile " >> return Cassius) - <|> (A.string "$(Settings.juliusFile " >> return Julius) - <|> (A.string "$(Settings.widgetFile " >> return Widget) - A.skipWhile isSpace - _ <- A.char '"' - y <- A.many1 $ A.satisfy (/= '"') - _ <- A.char '"' - A.skipWhile isSpace - _ <- A.char ')' - return $ Just (typ, y) diff --git a/yesod.cabal b/yesod.cabal index 3ad00a7f..b1aff4e2 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.7.1 +version: 0.7.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -18,21 +18,13 @@ extra-source-files: scaffold/*.cg flag ghc7 -flag production - Description: Skip the wai-handler-devel and hint dependencies. - Default: False - library - if flag(production) - cpp-options: -DPRODUCTION - else - build-depends: wai-handler-devel >= 0.2 && < 0.3 if flag(ghc7) build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: yesod-core >= 0.7.0.1 && < 0.8 + build-depends: yesod-core >= 0.7.0.2 && < 0.8 , yesod-auth >= 0.3 && < 0.4 , yesod-json >= 0.0.0.1 && < 0.1 , yesod-persistent >= 0.0.0.1 && < 0.1 @@ -46,7 +38,6 @@ library , warp >= 0.3.2.1 && < 0.4 , mime-mail >= 0.1.0.1 && < 0.2 , hjsmin >= 0.0.12 && < 0.1 - , attoparsec-text >= 0.8.2.1 && < 0.9 exposed-modules: Yesod ghc-options: -Wall From 3132bd5c8009dd186855879dfdd3f0dc35ca6c9a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 31 Mar 2011 21:43:41 +0200 Subject: [PATCH 572/624] Add a missing > --- scaffold/sitearg_hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 84203aeb..2ec44f42 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -185,7 +185,7 @@ instance YesodAuthEmail ~sitearg~ where , partContent = renderHtml [~qq~hamlet| <p>Please confirm your email address by clicking on the link below. <p> - <a href=#{verurl} #{verurl} + <a href=#{verurl}>#{verurl} <p>Thank you |] , partHeaders = [] From 66ff0968985fef80ca3caf5cf16ab81e82405057 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 31 Mar 2011 22:56:34 +0200 Subject: [PATCH 573/624] Version bumps --- full-test.sh | 7 +++++++ input-mini | 5 +++++ input-postgres | 5 +++++ input-sqlite | 5 +++++ scaffold/StaticFiles_hs.cg | 2 +- scaffold/cabal.cg | 2 +- yesod.cabal | 8 ++++---- 7 files changed, 28 insertions(+), 6 deletions(-) create mode 100755 full-test.sh create mode 100644 input-mini create mode 100644 input-postgres create mode 100644 input-sqlite diff --git a/full-test.sh b/full-test.sh new file mode 100755 index 00000000..30978f1e --- /dev/null +++ b/full-test.sh @@ -0,0 +1,7 @@ +#!/bin/sh + +cabal clean && cabal install && rm -rf foobar && \ + yesod < input-sqlite && cd foobar && cabal install && cd .. && \ + yesod < input-postgres && cd foobar && cabal install && cd .. && \ + # yesod < input-mini && cd foobar && cabal install && cd .. && \ + rm -rf foobar diff --git a/input-mini b/input-mini new file mode 100644 index 00000000..61f2e8be --- /dev/null +++ b/input-mini @@ -0,0 +1,5 @@ +Michael +foobar + +Foobar +m diff --git a/input-postgres b/input-postgres new file mode 100644 index 00000000..0bd04d5a --- /dev/null +++ b/input-postgres @@ -0,0 +1,5 @@ +Michael +foobar + +Foobar +p diff --git a/input-sqlite b/input-sqlite new file mode 100644 index 00000000..af3132a8 --- /dev/null +++ b/input-sqlite @@ -0,0 +1,5 @@ +Michael +foobar + +Foobar +s diff --git a/scaffold/StaticFiles_hs.cg b/scaffold/StaticFiles_hs.cg index 40178be5..1de80de6 100644 --- a/scaffold/StaticFiles_hs.cg +++ b/scaffold/StaticFiles_hs.cg @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} module StaticFiles where -import Yesod + import Yesod.Helpers.Static -- | This generates easy references to files in the static directory at compile time. diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 179849aa..808d7331 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -30,7 +30,7 @@ executable ~project~-test , bytestring , text , persistent - , persistent-~lower~ + , persistent-~lower~ >= 0.4 && < 0.5 , template-haskell , hamlet , web-routes diff --git a/yesod.cabal b/yesod.cabal index b1aff4e2..33f74f03 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.7.2 +version: 0.7.3 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -34,10 +34,10 @@ library , transformers >= 0.2 && < 0.3 , wai >= 0.3 && < 0.4 , wai-extra >= 0.3.2 && < 0.4 - , hamlet >= 0.7.1 && < 0.8 - , warp >= 0.3.2.1 && < 0.4 + , hamlet >= 0.7.3 && < 0.8 + , warp >= 0.3.3 && < 0.4 , mime-mail >= 0.1.0.1 && < 0.2 - , hjsmin >= 0.0.12 && < 0.1 + , hjsmin >= 0.0.13 && < 0.1 exposed-modules: Yesod ghc-options: -Wall From fe38853ff02c8ae543ce183d230bf0273de3e504 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 31 Mar 2011 23:58:40 +0200 Subject: [PATCH 574/624] Mini scaffolded site --- full-test.sh | 2 +- scaffold.hs | 28 ++++---- scaffold/Settings_hs.cg | 2 +- scaffold/database.cg | 5 +- scaffold/devel-server_hs.cg | 4 +- scaffold/mini-Controller_hs.cg | 40 ++++++++++++ scaffold/mini-Root_hs.cg | 18 ++++++ scaffold/mini-Settings_hs.cg | 108 +++++++++++++++++++++++++++++++ scaffold/mini-cabal.cg | 51 +++++++++++++++ scaffold/mini-homepage_hamlet.cg | 2 + scaffold/mini-sitearg_hs.cg | 107 ++++++++++++++++++++++++++++++ 11 files changed, 348 insertions(+), 19 deletions(-) create mode 100644 scaffold/mini-Controller_hs.cg create mode 100644 scaffold/mini-Root_hs.cg create mode 100644 scaffold/mini-Settings_hs.cg create mode 100644 scaffold/mini-cabal.cg create mode 100644 scaffold/mini-homepage_hamlet.cg create mode 100644 scaffold/mini-sitearg_hs.cg diff --git a/full-test.sh b/full-test.sh index 30978f1e..23f3837f 100755 --- a/full-test.sh +++ b/full-test.sh @@ -3,5 +3,5 @@ cabal clean && cabal install && rm -rf foobar && \ yesod < input-sqlite && cd foobar && cabal install && cd .. && \ yesod < input-postgres && cd foobar && cabal install && cd .. && \ - # yesod < input-mini && cd foobar && cabal install && cd .. && \ + yesod < input-mini && cd foobar && cabal install && cd .. && \ rm -rf foobar diff --git a/scaffold.hs b/scaffold.hs index 4cd75d07..a91d1f46 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -10,6 +10,7 @@ import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT +import Control.Monad (when) qq :: String #if GHC7 @@ -56,13 +57,14 @@ main = do putStr $(codegen "database") hFlush stdout - backendS <- prompt $ flip elem ["s", "p"] + backendS <- prompt $ flip elem ["s", "p", "m"] let pconn1 = $(codegen "pconn1") let pconn2 = $(codegen "pconn2") - let (lower, upper, connstr1, connstr2) = + let (lower, upper, connstr1, connstr2, importDB) = case backendS of - "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3") - "p" -> ("postgresql", "Postgresql", pconn1, pconn2) + "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3", "import Database.Persist.Sqlite\n") + "p" -> ("postgresql", "Postgresql", pconn1, pconn2, "import Database.Persist.Postgresql\n") + "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "FIXME connstr2", "") _ -> error $ "Invalid backend: " ++ backendS putStrLn "That's it! I'm creating your files now..." @@ -80,23 +82,23 @@ main = do mkDir "cassius" mkDir "julius" mkDir "static" - + writeFile' "test.hs" $(codegen "test_hs") writeFile' "production.hs" $(codegen "production_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") - writeFile' (project ++ ".cabal") $(codegen "cabal") + writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") - writeFile' (sitearg ++ ".hs") $(codegen "sitearg_hs") - writeFile' "Controller.hs" $(codegen "Controller_hs") - writeFile' "Handler/Root.hs" $(codegen "Root_hs") - writeFile' "Model.hs" $(codegen "Model_hs") - writeFile' "Settings.hs" $(codegen "Settings_hs") + writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini-sitearg_hs") else $(codegen "sitearg_hs") + writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini-Controller_hs") else $(codegen "Controller_hs") + writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini-Root_hs") else $(codegen "Root_hs") + when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model_hs") + writeFile' "Settings.hs" $ if backendS == "m" then $(codegen "mini-Settings_hs") else $(codegen "Settings_hs") writeFile' "StaticFiles.hs" $(codegen "StaticFiles_hs") writeFile' "cassius/default-layout.cassius" $(codegen "default-layout_cassius") writeFile' "hamlet/default-layout.hamlet" $(codegen "default-layout_hamlet") - writeFile' "hamlet/homepage.hamlet" $(codegen "homepage_hamlet") + writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet") writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") writeFile' "julius/homepage.julius" $(codegen "homepage_julius") @@ -104,4 +106,4 @@ main = do $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) - \ No newline at end of file + diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 9becff92..54cefe74 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -23,7 +23,7 @@ import qualified Text.Hamlet as H import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax -import Database.Persist.~upper~ +~importDB~ import Yesod (MonadPeelIO, addWidget, addCassius, addJulius) import Data.Monoid (mempty) import System.Directory (doesFileExist) diff --git a/scaffold/database.cg b/scaffold/database.cg index 25c13784..198c20ac 100644 --- a/scaffold/database.cg +++ b/scaffold/database.cg @@ -3,4 +3,7 @@ This tool will build in either SQLite or PostgreSQL support for you. If you want to use a different backend, you'll have to make changes manually. If you're not sure, stick with SQLite: it has no dependencies. -So, what'll it be? s for sqlite, p for postgresql: +We also have a new option: a mini project. This is a site with minimal +dependencies. In particular: no database, no authentication. + +So, what'll it be? s for sqlite, p for postgresql, m for mini: diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg index c0dfa02b..71ff4eb2 100644 --- a/scaffold/devel-server_hs.cg +++ b/scaffold/devel-server_hs.cg @@ -1,5 +1,3 @@ -import Yesod (develServer) - main :: IO () -main = develServer 3000 "Controller" "with~sitearg~" +main = putStrLn "Please run: wai-handler-devel 3000 Controller with~sitearg~ --yesod" diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini-Controller_hs.cg new file mode 100644 index 00000000..3711043c --- /dev/null +++ b/scaffold/mini-Controller_hs.cg @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( with~sitearg~ + ) where + +import ~sitearg~ +import Settings +import Yesod.Helpers.Static +import Data.ByteString (ByteString) +import Network.Wai (Application) + +-- Import all relevant handler modules here. +import Handler.Root + +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in ~sitearg~.hs. Please see +-- the comments there for more details. +mkYesodDispatch "~sitearg~" resources~sitearg~ + +-- Some default handlers that ship with the Yesod site template. You will +-- very rarely need to modify this. +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" "favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +with~sitearg~ :: (Application -> IO a) -> IO a +with~sitearg~ f = do + let h = ~sitearg~ s + toWaiApp h >>= f + where + s = static Settings.staticdir diff --git a/scaffold/mini-Root_hs.cg b/scaffold/mini-Root_hs.cg new file mode 100644 index 00000000..cf292a14 --- /dev/null +++ b/scaffold/mini-Root_hs.cg @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module Handler.Root where + +import ~sitearg~ + +-- This is a handler function for the GET request method on the RootR +-- resource pattern. All of your resource patterns are defined in +-- ~sitearg~.hs; look for the line beginning with mkYesodData. +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. +getRootR :: Handler RepHtml +getRootR = do + defaultLayout $ do + h2id <- lift newIdent + setTitle "~project~ homepage" + addWidget $(widgetFile "homepage") diff --git a/scaffold/mini-Settings_hs.cg b/scaffold/mini-Settings_hs.cg new file mode 100644 index 00000000..e7866795 --- /dev/null +++ b/scaffold/mini-Settings_hs.cg @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Settings are centralized, as much as possible, into this file. This +-- includes database connection settings, static file locations, etc. +-- In addition, you can configure a number of different aspects of Yesod +-- by overriding methods in the Yesod typeclass. That instance is +-- declared in the ~project~.hs file. +module Settings + ( hamletFile + , cassiusFile + , juliusFile + , widgetFile + , approot + , staticroot + , staticdir + ) where + +import qualified Text.Hamlet as H +import qualified Text.Cassius as H +import qualified Text.Julius as H +import Language.Haskell.TH.Syntax +import Yesod.Widget (addWidget, addCassius, addJulius) +import Data.Monoid (mempty) +import System.Directory (doesFileExist) + +-- | The base URL for your application. This will usually be different for +-- development and production. Yesod automatically constructs URLs for you, +-- so this value must be accurate to create valid links. +approot :: String +#ifdef PRODUCTION +-- You probably want to change this. If your domain name was "yesod.com", +-- you would probably want it to be: +-- > approot = "http://www.yesod.com" +-- Please note that there is no trailing slash. +approot = "http://localhost:3000" +#else +approot = "http://localhost:3000" +#endif + +-- | The location of static files on your system. This is a file system +-- path. The default value works properly with your scaffolded site. +staticdir :: FilePath +staticdir = "static" + +-- | The base URL for your static files. As you can see by the default +-- value, this can simply be "static" appended to your application root. +-- A powerful optimization can be serving static files from a separate +-- domain name. This allows you to use a web server optimized for static +-- files, more easily set expires and cache values, and avoid possibly +-- costly transference of cookies on static files. For more information, +-- please see: +-- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain +-- +-- If you change the resource pattern for StaticR in ~project~.hs, you will +-- have to make a corresponding change here. +-- +-- To see how this value is used, see urlRenderOverride in ~project~.hs +staticroot :: String +staticroot = approot ++ "/static" + +-- The rest of this file contains settings which rarely need changing by a +-- user. + +-- The following three functions are used for calling HTML, CSS and +-- Javascript templates from your Haskell code. During development, +-- the "Debug" versions of these functions are used so that changes to +-- the templates are immediately reflected in an already running +-- application. When making a production compile, the non-debug version +-- is used for increased performance. +-- +-- You can see an example of how to call these functions in Handler/Root.hs +-- +-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer +-- used; to get the same auto-loading effect, it is recommended that you +-- use the devel server. + +toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath +toHamletFile x = "hamlet/" ++ x ++ ".hamlet" +toCassiusFile x = "cassius/" ++ x ++ ".cassius" +toJuliusFile x = "julius/" ++ x ++ ".julius" + +hamletFile :: FilePath -> Q Exp +hamletFile = H.hamletFile . toHamletFile + +cassiusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +cassiusFile = H.cassiusFile . toCassiusFile +#else +cassiusFile = H.cassiusFileDebug . toCassiusFile +#endif + +juliusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +juliusFile = H.juliusFile . toJuliusFile +#else +juliusFile = H.juliusFileDebug . toJuliusFile +#endif + +widgetFile :: FilePath -> Q Exp +widgetFile x = do + let h = unlessExists toHamletFile hamletFile + let c = unlessExists toCassiusFile cassiusFile + let j = unlessExists toJuliusFile juliusFile + [|addWidget $h >> addCassius $c >> addJulius $j|] + where + unlessExists tofn f = do + e <- qRunIO $ doesFileExist $ tofn x + if e then f x else [|mempty|] diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg new file mode 100644 index 00000000..4b1df7c1 --- /dev/null +++ b/scaffold/mini-cabal.cg @@ -0,0 +1,51 @@ +name: ~project~ +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: ~name~ +maintainer: ~name~ +synopsis: The greatest Yesod web application ever. +description: I'm sure you can say something clever here if you try. +category: Web +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://~project~.yesodweb.com/ + +Flag production + Description: Build the production executable. + Default: False + +executable ~project~-test + if flag(production) + Buildable: False + main-is: test.hs + build-depends: base >= 4 && < 5 + , yesod-core >= 0.7 && < 0.8 + , yesod-static + , wai-extra + , directory + , bytestring + , text + , template-haskell + , hamlet + , web-routes + , transformers + , wai + , warp + ghc-options: -Wall -threaded + +executable ~project~-production + if flag(production) + Buildable: True + else + Buildable: False + cpp-options: -DPRODUCTION + main-is: production.hs + ghc-options: -Wall -threaded + +executable ~project~-devel + if flag(production) + Buildable: False + main-is: devel-server.hs + ghc-options: -Wall -O2 -threaded diff --git a/scaffold/mini-homepage_hamlet.cg b/scaffold/mini-homepage_hamlet.cg new file mode 100644 index 00000000..34432b74 --- /dev/null +++ b/scaffold/mini-homepage_hamlet.cg @@ -0,0 +1,2 @@ +<h1>Hello +<h2 ##{h2id}>You do not have Javascript enabled. diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg new file mode 100644 index 00000000..945ca84e --- /dev/null +++ b/scaffold/mini-sitearg_hs.cg @@ -0,0 +1,107 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module ~sitearg~ + ( ~sitearg~ (..) + , ~sitearg~Route (..) + , resources~sitearg~ + , Handler + , Widget + , module Yesod.Handler + , module Yesod.Widget + , module Yesod.Dispatch + , module Yesod.Core + , module Yesod.Content + , module Settings + , StaticRoute (..) + , lift + , liftIO + ) where + +import Yesod.Handler +import Yesod.Widget +import Yesod.Dispatch +import Yesod.Core +import Yesod.Content +import Yesod.Helpers.Static +import qualified Settings +import System.Directory +import qualified Data.ByteString.Lazy as L +import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) +import StaticFiles +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) + +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data ~sitearg~ = ~sitearg~ + { getStatic :: Static -- ^ Settings for static file serving. + } + +-- | A useful synonym; most of the handler functions in your application +-- will need to be of this type. +type Handler = GHandler ~sitearg~ ~sitearg~ + +-- | A useful synonym; most of the widgets functions in your application +-- will need to be of this type. +type Widget = GWidget ~sitearg~ ~sitearg~ + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://docs.yesodweb.com/book/web-routes-quasi/ +-- +-- This function does three things: +-- +-- * Creates the route datatype ~sitearg~Route. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route ~sitearg~ = ~sitearg~Route +-- * Creates the value resources~sitearg~ which contains information on the +-- resources declared below. This is used in Controller.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- ~sitearg~. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the ~sitearg~Route datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "~sitearg~" [parseRoutes| +/static StaticR Static getStatic + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET +|] + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod ~sitearg~ where + approot _ = Settings.approot + + defaultLayout widget = do + mmsg <- getMessage + pc <- widgetToPageContent $ do + widget + addCassius $(Settings.cassiusFile "default-layout") + hamletToRepHtml $(Settings.hamletFile "default-layout") + + -- This is done to provide an optimization for serving static files from + -- a separate domain. Please see the staticroot setting in Settings.hs + urlRenderOverride a (StaticR s) = + Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + urlRenderOverride _ _ = Nothing + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent ext' _ content = do + let fn = base64md5 content ++ '.' : ext' + let statictmp = Settings.staticdir ++ "/tmp/" + liftIO $ createDirectoryIfMissing True statictmp + let fn' = statictmp ++ fn + exists <- liftIO $ doesFileExist fn' + unless exists $ liftIO $ L.writeFile fn' content + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) From 9b36dc2bf66dcd108d44609f9978f95218ffa55a Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 8 Apr 2011 00:35:25 +0300 Subject: [PATCH 575/624] Scaffolded site: yesod 0.8 --- Yesod.hs | 11 +++-------- full-test.sh | 6 +++--- scaffold/Model_hs.cg | 16 ++++++++-------- scaffold/Settings_hs.cg | 18 ++++++++++-------- scaffold/cabal.cg | 6 ++++-- scaffold/mini-Settings_hs.cg | 10 ++++++---- scaffold/mini-cabal.cg | 3 ++- scaffold/mini-sitearg_hs.cg | 13 ++++++------- scaffold/sitearg_hs.cg | 21 ++++++++++++--------- yesod.cabal | 26 +++++++++++++------------- 10 files changed, 67 insertions(+), 63 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index a9053991..9e8b9072 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -3,12 +3,7 @@ -- | This module simply re-exports from other modules for your convenience. module Yesod ( -- * Re-exports from yesod-core - module Yesod.Request - , module Yesod.Content - , module Yesod.Core - , module Yesod.Handler - , module Yesod.Dispatch - , module Yesod.Widget + module Yesod.Core , module Yesod.Form , module Yesod.Json , module Yesod.Persist @@ -20,7 +15,7 @@ module Yesod , Application , lift , liftIO - , MonadPeelIO + , MonadControlIO -- * Utilities , showIntegral , readIntegral @@ -62,7 +57,7 @@ import Network.Wai (Application) import Network.Wai.Middleware.Debug import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) -import Control.Monad.IO.Peel (MonadPeelIO) +import Control.Monad.IO.Control (MonadControlIO) import Network.Wai.Handler.Warp (run) import System.IO (stderr, hPutStrLn) diff --git a/full-test.sh b/full-test.sh index 23f3837f..809d00cb 100755 --- a/full-test.sh +++ b/full-test.sh @@ -1,7 +1,7 @@ #!/bin/sh cabal clean && cabal install && rm -rf foobar && \ - yesod < input-sqlite && cd foobar && cabal install && cd .. && \ - yesod < input-postgres && cd foobar && cabal install && cd .. && \ - yesod < input-mini && cd foobar && cabal install && cd .. && \ + runghc scaffold.hs < input-sqlite && cd foobar && cabal install && cd .. && \ + runghc scaffold.hs < input-postgres && cd foobar && cabal install && cd .. && \ + runghc scaffold.hs < input-mini && cd foobar && cabal install && cd .. && \ rm -rf foobar diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 4c31eee7..97fbb96a 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -2,21 +2,21 @@ module Model where import Yesod -import Database.Persist.TH (share2) -import Database.Persist.GenericSql (mkMigrate) +import Database.Persist.TH (share, mkMigrate) +import Data.Text (Text) -- You can define all of your database entities here. You can find more -- information on persistent and how to declare entities at: --- http://docs.yesodweb.com/book/persistent/ -share2 mkPersist (mkMigrate "migrateAll") [~qq~persist| +-- http://www.yesodweb.com/book/persistent/ +share [mkPersist, mkMigrate "migrateAll"] [~qq~persist| User - ident String - password String Maybe Update + ident Text + password Text Maybe Update UniqueUser ident Email - email String + email Text user UserId Maybe Update - verkey String Maybe Update + verkey Text Maybe Update UniqueEmail email |] diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 54cefe74..28604294 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -24,14 +25,15 @@ import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax ~importDB~ -import Yesod (MonadPeelIO, addWidget, addCassius, addJulius) -import Data.Monoid (mempty) +import Yesod (MonadControlIO, addWidget, addCassius, addJulius) +import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) +import Data.Text (Text) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you, -- so this value must be accurate to create valid links. -approot :: String +approot :: Text #ifdef PRODUCTION -- You probably want to change this. If your domain name was "yesod.com", -- you would probably want it to be: @@ -60,12 +62,12 @@ staticdir = "static" -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in ~sitearg~.hs -staticroot :: String -staticroot = approot ++ "/static" +staticroot :: Text +staticroot = approot `mappend` "/static" -- | The database connection string. The meaning of this string is backend- -- specific. -connStr :: String +connStr :: Text #ifdef PRODUCTION connStr = "~connstr2~" #else @@ -139,9 +141,9 @@ widgetFile x = do -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself. -withConnectionPool :: MonadPeelIO m => (ConnectionPool -> m a) -> m a +withConnectionPool :: MonadControlIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadPeelIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 808d7331..88382fcc 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -21,7 +21,7 @@ executable ~project~-test Buildable: False main-is: test.hs build-depends: base >= 4 && < 5 - , yesod >= 0.7 && < 0.8 + , yesod >= 0.8 && < 0.9 , yesod-auth , yesod-static , mime-mail @@ -30,13 +30,15 @@ executable ~project~-test , bytestring , text , persistent - , persistent-~lower~ >= 0.4 && < 0.5 + , persistent-template + , persistent-~lower~ >= 0.5 && < 0.6 , template-haskell , hamlet , web-routes , hjsmin , transformers , warp + , blaze-builder ghc-options: -Wall -threaded executable ~project~-production diff --git a/scaffold/mini-Settings_hs.cg b/scaffold/mini-Settings_hs.cg index e7866795..b3909933 100644 --- a/scaffold/mini-Settings_hs.cg +++ b/scaffold/mini-Settings_hs.cg @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -20,13 +21,14 @@ import qualified Text.Cassius as H import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Yesod.Widget (addWidget, addCassius, addJulius) -import Data.Monoid (mempty) +import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) +import Data.Text (Text) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you, -- so this value must be accurate to create valid links. -approot :: String +approot :: Text #ifdef PRODUCTION -- You probably want to change this. If your domain name was "yesod.com", -- you would probably want it to be: @@ -55,8 +57,8 @@ staticdir = "static" -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in ~project~.hs -staticroot :: String -staticroot = approot ++ "/static" +staticroot :: Text +staticroot = approot `mappend` "/static" -- The rest of this file contains settings which rarely need changing by a -- user. diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 4b1df7c1..6d253ba7 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -21,7 +21,7 @@ executable ~project~-test Buildable: False main-is: test.hs build-depends: base >= 4 && < 5 - , yesod-core >= 0.7 && < 0.8 + , yesod-core >= 0.8 && < 0.9 , yesod-static , wai-extra , directory @@ -33,6 +33,7 @@ executable ~project~-test , transformers , wai , warp + , blaze-builder ghc-options: -Wall -threaded executable ~project~-production diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index 945ca84e..81984903 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module ~sitearg~ ( ~sitearg~ (..) , ~sitearg~Route (..) @@ -16,11 +17,7 @@ module ~sitearg~ , liftIO ) where -import Yesod.Handler -import Yesod.Widget -import Yesod.Dispatch import Yesod.Core -import Yesod.Content import Yesod.Helpers.Static import qualified Settings import System.Directory @@ -30,6 +27,8 @@ import StaticFiles import Control.Monad (unless) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Blaze.ByteString.Builder.Char.Utf8 (fromText) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -90,7 +89,7 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + Just $ uncurry (joinPath a $ fromText Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- This function creates static content files in the static folder @@ -98,10 +97,10 @@ instance Yesod ~sitearg~ where -- expiration dates to be set far in the future without worry of -- users receiving stale content. addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : ext' + let fn = base64md5 content ++ '.' : T.unpack ext' let statictmp = Settings.staticdir ++ "/tmp/" liftIO $ createDirectoryIfMissing True statictmp let fn' = statictmp ++ fn exists <- liftIO $ doesFileExist fn' unless exists $ liftIO $ L.writeFile fn' content - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) + return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 2ec44f42..13c18945 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module ~sitearg~ ( ~sitearg~ (..) , ~sitearg~Route (..) @@ -32,6 +33,8 @@ import Network.Mail.Mime import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding import Text.Jasmine (minifym) +import qualified Data.Text as T +import Blaze.ByteString.Builder.Char.Utf8 (fromText) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -94,7 +97,7 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + Just $ uncurry (joinPath a $ fromText Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. @@ -105,7 +108,7 @@ instance Yesod ~sitearg~ where -- expiration dates to be set far in the future without worry of -- users receiving stale content. addStaticContent ext' _ content = do - let fn = base64md5 content ++ '.' : ext' + let fn = base64md5 content ++ '.' : T.unpack ext' let content' = if ext' == "js" then case minifym content of @@ -117,7 +120,7 @@ instance Yesod ~sitearg~ where let fn' = statictmp ++ fn exists <- liftIO $ doesFileExist fn' unless exists $ liftIO $ L.writeFile fn' content' - return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], []) + return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) -- How to run database actions. instance YesodPersist ~sitearg~ where @@ -140,8 +143,8 @@ instance YesodAuth ~sitearg~ where Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - showAuthId _ = showIntegral - readAuthId _ = readIntegral + showAuthId _ = T.pack . show + readAuthId _ = read . T.unpack authPlugins = [ authOpenId , authEmail @@ -150,8 +153,8 @@ instance YesodAuth ~sitearg~ where instance YesodAuthEmail ~sitearg~ where type AuthEmailId ~sitearg~ = EmailId - showAuthEmailId _ = showIntegral - readAuthEmailId _ = readIntegral + showAuthEmailId _ = T.pack . show + readAuthEmailId _ = read . T.unpack addUnverified email verkey = runDB $ insert $ Email email Nothing $ Just verkey @@ -169,10 +172,10 @@ instance YesodAuthEmail ~sitearg~ where , partEncoding = None , partFilename = Nothing , partContent = Data.Text.Lazy.Encoding.encodeUtf8 - $ Data.Text.Lazy.pack $ unlines + $ Data.Text.Lazy.unlines [ "Please confirm your email address by clicking on the link below." , "" - , verurl + , Data.Text.Lazy.fromChunks [verurl] , "" , "Thank you" ] diff --git a/yesod.cabal b/yesod.cabal index 33f74f03..c4782011 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.7.3 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -24,19 +24,19 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: yesod-core >= 0.7.0.2 && < 0.8 - , yesod-auth >= 0.3 && < 0.4 - , yesod-json >= 0.0.0.1 && < 0.1 - , yesod-persistent >= 0.0.0.1 && < 0.1 - , yesod-static >= 0.0 && < 0.1 - , yesod-form >= 0.0.0.1 && < 0.1 - , monad-peel >= 0.1 && < 0.2 + build-depends: yesod-core >= 0.8 && < 0.9 + , yesod-auth >= 0.4 && < 0.5 + , yesod-json >= 0.1 && < 0.2 + , yesod-persistent >= 0.1 && < 0.2 + , yesod-static >= 0.1 && < 0.2 + , yesod-form >= 0.1 && < 0.2 + , monad-control >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3 - , wai >= 0.3 && < 0.4 - , wai-extra >= 0.3.2 && < 0.4 - , hamlet >= 0.7.3 && < 0.8 - , warp >= 0.3.3 && < 0.4 - , mime-mail >= 0.1.0.1 && < 0.2 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4 && < 0.5 + , hamlet >= 0.8 && < 0.9 + , warp >= 0.4 && < 0.5 + , mime-mail >= 0.3 && < 0.4 , hjsmin >= 0.0.13 && < 0.1 exposed-modules: Yesod ghc-options: -Wall From b236e1f913110e429aaed2292b5f01491d7ab7d0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 8 Apr 2011 00:47:53 +0300 Subject: [PATCH 576/624] Scaffolded site puts routes/entities in separate files --- scaffold.hs | 4 +++- scaffold/Model_hs.cg | 17 ++++------------- scaffold/entities.cg | 10 ++++++++++ scaffold/mini-routes.cg | 7 +++++++ scaffold/mini-sitearg_hs.cg | 13 +------------ scaffold/routes.cg | 8 ++++++++ scaffold/sitearg_hs.cg | 10 +--------- 7 files changed, 34 insertions(+), 35 deletions(-) create mode 100644 scaffold/entities.cg create mode 100644 scaffold/mini-routes.cg create mode 100644 scaffold/routes.cg diff --git a/scaffold.hs b/scaffold.hs index a91d1f46..b411231c 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -10,7 +10,7 @@ import Control.Applicative ((<$>)) import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT -import Control.Monad (when) +import Control.Monad (when, unless) qq :: String #if GHC7 @@ -99,8 +99,10 @@ main = do writeFile' "hamlet/default-layout.hamlet" $(codegen "default-layout_hamlet") writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet") + writeFile' "routes" $ if backendS == "m" then $(codegen "mini-routes") else $(codegen "routes") writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") writeFile' "julius/homepage.julius" $(codegen "homepage_julius") + unless (backendS == "m") $ writeFile' "entities" $(codegen "entities") S.writeFile (dir ++ "/favicon.ico") $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 97fbb96a..79fad3e9 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -5,18 +5,9 @@ import Yesod import Database.Persist.TH (share, mkMigrate) import Data.Text (Text) --- You can define all of your database entities here. You can find more --- information on persistent and how to declare entities at: +-- You can define all of your database entities in the entities file. +-- You can find more information on persistent and how to declare entities +-- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist, mkMigrate "migrateAll"] [~qq~persist| -User - ident Text - password Text Maybe Update - UniqueUser ident -Email - email Text - user UserId Maybe Update - verkey Text Maybe Update - UniqueEmail email -|] +share [mkPersist, mkMigrate "migrateAll"] $(persistFile "entities") diff --git a/scaffold/entities.cg b/scaffold/entities.cg new file mode 100644 index 00000000..0fafb17a --- /dev/null +++ b/scaffold/entities.cg @@ -0,0 +1,10 @@ +User + ident Text + password Text Maybe Update + UniqueUser ident +Email + email Text + user UserId Maybe Update + verkey Text Maybe Update + UniqueEmail email + diff --git a/scaffold/mini-routes.cg b/scaffold/mini-routes.cg new file mode 100644 index 00000000..f8eb4921 --- /dev/null +++ b/scaffold/mini-routes.cg @@ -0,0 +1,7 @@ +/static StaticR Static getStatic + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET + diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index 81984903..b2e68221 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -6,11 +6,7 @@ module ~sitearg~ , resources~sitearg~ , Handler , Widget - , module Yesod.Handler - , module Yesod.Widget - , module Yesod.Dispatch , module Yesod.Core - , module Yesod.Content , module Settings , StaticRoute (..) , lift @@ -65,14 +61,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" [parseRoutes| -/static StaticR Static getStatic - -/favicon.ico FaviconR GET -/robots.txt RobotsR GET - -/ RootR GET -|] +mkYesodData "~sitearg~" $(parseRoutesFile "routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. diff --git a/scaffold/routes.cg b/scaffold/routes.cg new file mode 100644 index 00000000..88b05c1c --- /dev/null +++ b/scaffold/routes.cg @@ -0,0 +1,8 @@ +/static StaticR Static getStatic +/auth AuthR Auth getAuth + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ RootR GET + diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 13c18945..8ab1ac81 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -72,15 +72,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" [~qq~parseRoutes| -/static StaticR Static getStatic -/auth AuthR Auth getAuth - -/favicon.ico FaviconR GET -/robots.txt RobotsR GET - -/ RootR GET -|] +mkYesodData "~sitearg~" $(parseRoutesFile "routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. From da4f679f3644c10a960e4720d9feca62cbc94585 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 14 Apr 2011 17:43:10 +0300 Subject: [PATCH 577/624] Use readKey/showKey --- scaffold/sitearg_hs.cg | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 8ab1ac81..3ce995ee 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -135,8 +135,8 @@ instance YesodAuth ~sitearg~ where Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - showAuthId _ = T.pack . show - readAuthId _ = read . T.unpack + showAuthId _ = showKey (undefined :: YesodDB ~sitearg~ IO a) . fromPersistKey + readAuthId _ = fmap toPersistKey . readKey (undefined :: YesodDB ~sitearg~ IO a) authPlugins = [ authOpenId , authEmail @@ -145,8 +145,8 @@ instance YesodAuth ~sitearg~ where instance YesodAuthEmail ~sitearg~ where type AuthEmailId ~sitearg~ = EmailId - showAuthEmailId _ = T.pack . show - readAuthEmailId _ = read . T.unpack + showAuthEmailId _ = showKey (undefined :: YesodDB ~sitearg~ IO a) . fromPersistKey + readAuthEmailId _ = fmap toPersistKey . readKey (undefined :: YesodDB ~sitearg~ IO a) addUnverified email verkey = runDB $ insert $ Email email Nothing $ Just verkey From adbc9e1868104bccd44e822c25525c077acb1f90 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Apr 2011 07:56:08 +0300 Subject: [PATCH 578/624] Export toHtml --- Yesod.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 9e8b9072..b1546520 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -30,6 +30,7 @@ module Yesod , string , preEscapedString , cdata + , toHtml -- ** Julius , julius , Julius @@ -40,16 +41,11 @@ module Yesod , renderCassius ) where -import Yesod.Content -import Yesod.Dispatch import Yesod.Core -import Yesod.Handler hiding (runHandler) import Text.Hamlet import Text.Cassius import Text.Julius -import Yesod.Request -import Yesod.Widget import Yesod.Form import Yesod.Json import Yesod.Persist From 254795cb40ee42310292570a8fe633bab94bba9e Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Apr 2011 12:36:19 +0300 Subject: [PATCH 579/624] Various scaffolding tweaks --- scaffold.hs | 2 +- scaffold/Model_hs.cg | 1 - scaffold/mini-sitearg_hs.cg | 3 +-- scaffold/sitearg_hs.cg | 9 +-------- 4 files changed, 3 insertions(+), 12 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index b411231c..c89098dd 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -13,7 +13,7 @@ import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) qq :: String -#if GHC7 +#if __GLASGOW_HASKELL__ >= 700 qq = "" #else qq = "$" diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index 79fad3e9..eec15f98 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -2,7 +2,6 @@ module Model where import Yesod -import Database.Persist.TH (share, mkMigrate) import Data.Text (Text) -- You can define all of your database entities in the entities file. diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index b2e68221..d71aec4d 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -24,7 +24,6 @@ import Control.Monad (unless) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -78,7 +77,7 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a $ fromText Settings.staticroot) $ renderRoute s + Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- This function creates static content files in the static folder diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index 3ce995ee..d632a659 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -34,7 +34,6 @@ import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding import Text.Jasmine (minifym) import qualified Data.Text as T -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -89,7 +88,7 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a $ fromText Settings.staticroot) $ renderRoute s + Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. @@ -135,9 +134,6 @@ instance YesodAuth ~sitearg~ where Nothing -> do fmap Just $ insert $ User (credsIdent creds) Nothing - showAuthId _ = showKey (undefined :: YesodDB ~sitearg~ IO a) . fromPersistKey - readAuthId _ = fmap toPersistKey . readKey (undefined :: YesodDB ~sitearg~ IO a) - authPlugins = [ authOpenId , authEmail ] @@ -145,9 +141,6 @@ instance YesodAuth ~sitearg~ where instance YesodAuthEmail ~sitearg~ where type AuthEmailId ~sitearg~ = EmailId - showAuthEmailId _ = showKey (undefined :: YesodDB ~sitearg~ IO a) . fromPersistKey - readAuthEmailId _ = fmap toPersistKey . readKey (undefined :: YesodDB ~sitearg~ IO a) - addUnverified email verkey = runDB $ insert $ Email email Nothing $ Just verkey sendVerifyEmail email _ verurl = liftIO $ renderSendMail Mail From 46ebf76c011cf944b3630737c986dc562f994b2c Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Apr 2011 06:51:12 +0300 Subject: [PATCH 580/624] Main is not a valid foundation datatype name --- scaffold.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold.hs b/scaffold.hs index c89098dd..1bf4b627 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -53,7 +53,7 @@ main = do putStr $(codegen "site-arg") hFlush stdout let isUpperAZ c = 'A' <= c && c <= 'Z' - sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) + sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main" putStr $(codegen "database") hFlush stdout From dade68afc7913d8dae35889d719f2a2634a76c42 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Apr 2011 15:19:33 +0300 Subject: [PATCH 581/624] yesod build --- Scaffold/Build.hs | 118 ++++++++++++++++++++++++++++++++++++++++++++++ scaffold.hs | 15 ++++++ yesod.cabal | 6 ++- 3 files changed, 138 insertions(+), 1 deletion(-) create mode 100644 Scaffold/Build.hs diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs new file mode 100644 index 00000000..7e35b669 --- /dev/null +++ b/Scaffold/Build.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scaffold.Build + ( build + ) where + +import qualified Distribution.Simple.Build as B +import Distribution.PackageDescription.Parse +import Distribution.Verbosity (normal) +import System.Directory (getDirectoryContents, doesDirectoryExist) +import Data.List (isSuffixOf) +import Distribution.PackageDescription (packageDescription) +import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) +import Distribution.Simple.Setup (defaultBuildFlags) +import Distribution.Simple.Configure (getPersistBuildConfig, localBuildInfoFile) +import Distribution.Simple.LocalBuildInfo +import qualified Data.Attoparsec.Text.Lazy as A +import qualified Data.Text.Lazy.IO as TIO +import Control.Applicative ((<|>)) +import Data.Char (isSpace) +import Data.Maybe (mapMaybe) +import Data.Monoid (mappend) +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) + +build :: IO () +build = do + {- + cabal <- defaultPackageDesc normal + gpd <- readPackageDescription normal cabal + putStrLn $ showPackageDescription $ packageDescription gpd + -} + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + let deps = fixDeps $ zip hss deps' + touchDeps deps + + lbi <- getPersistBuildConfig "dist" + B.build + (localPkgDescr lbi) + lbi + defaultBuildFlags + [] + +type Deps = Map.Map FilePath (Set.Set FilePath) + +touchDeps :: Deps -> IO () +touchDeps = + mapM_ go . Map.toList + where + go (x, ys) = do + fs <- getFileStatus x + flip mapM_ (Set.toList ys) $ \y -> do + fs' <- getFileStatus y + if modificationTime fs' < modificationTime fs + then do + putStrLn $ "Touching " ++ y ++ " because of " ++ x + setFileTimes y (accessTime fs') (modificationTime fs) + else return () + +fixDeps :: [(FilePath, [FilePath])] -> Deps +fixDeps = + Map.unionsWith mappend . map go + where + go :: (FilePath, [FilePath]) -> Deps + go (x, ys) = Map.fromList $ map (\y -> (y, Set.singleton x)) ys + +findHaskellFiles :: FilePath -> IO [FilePath] +findHaskellFiles path = do + contents <- getDirectoryContents path + fmap concat $ mapM go contents + where + go ('.':_) = return [] + go "dist" = return [] + go x = do + let y = path ++ '/' : x + d <- doesDirectoryExist y + if d + then findHaskellFiles y + else if ".hs" `isSuffixOf` x || ".lhs" `isSuffixOf` x + then return [y] + else return [] + +data TempType = Hamlet | Cassius | Lucius | Julius | Widget | Verbatim + deriving Show + +determineHamletDeps :: FilePath -> IO [FilePath] +determineHamletDeps x = do + y <- TIO.readFile x + let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y + case z of + A.Fail{} -> return [] + A.Done _ r -> return $ mapMaybe go r + where + go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go (Just (Verbatim, f)) = Just f + go _ = Nothing + parser = do + ty <- (A.string "$(hamletFile " >> return Hamlet) + <|> (A.string "$(cassiusFile " >> return Cassius) + <|> (A.string "$(luciusFile " >> return Lucius) + <|> (A.string "$(juliusFile " >> return Julius) + <|> (A.string "$(widgetFile " >> return Widget) + <|> (A.string "$(Settings.hamletFile " >> return Hamlet) + <|> (A.string "$(Settings.cassiusFile " >> return Cassius) + <|> (A.string "$(Settings.luciusFile " >> return Lucius) + <|> (A.string "$(Settings.juliusFile " >> return Julius) + <|> (A.string "$(Settings.widgetFile " >> return Widget) + <|> (A.string "$(persistFile " >> return Verbatim) + <|> (A.string "$(parseRoutesFile " >> return Verbatim) + A.skipWhile isSpace + _ <- A.char '"' + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.char '"' + A.skipWhile isSpace + _ <- A.char ')' + return $ Just (ty, y) diff --git a/scaffold.hs b/scaffold.hs index 1bf4b627..8337a58d 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -11,6 +11,9 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) +import System.Environment (getArgs) + +import Scaffold.Build qq :: String #if __GLASGOW_HASKELL__ >= 700 @@ -30,6 +33,18 @@ prompt f = do main :: IO () main = do + args <- getArgs + case args of + ["init"] -> scaffold + ["build"] -> build + _ -> do + putStrLn "Usage: yesod <command>" + putStrLn "Available commands:" + putStrLn " init Scaffold a new site" + putStrLn " build Build project (performs TH dependency analysis)" + +scaffold :: IO () +scaffold = do putStr $(codegen "welcome") hFlush stdout name <- getLine diff --git a/yesod.cabal b/yesod.cabal index c4782011..391bbfda 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -53,10 +53,14 @@ executable yesod , time >= 1.1.4 && < 1.3 , template-haskell , directory >= 1.0 && < 1.2 + , Cabal >= 1.8 && < 1.11 + , unix-compat >= 0.2 && < 0.3 + , containers >= 0.2 && < 0.5 + , attoparsec-text >= 0.8.5 && < 0.9 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen - extensions: TemplateHaskell + Scaffold.Build if flag(ghc7) cpp-options: -DGHC7 From c55a122236285d4ee1bffc302430221019177967 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Apr 2011 16:38:14 +0300 Subject: [PATCH 582/624] yesod devel --- Network/Wai/Application/Devel.hs | 59 ++++++++++++++++++ Scaffold/Build.hs | 15 +++-- Scaffold/Devel.hs | 103 +++++++++++++++++++++++++++++++ scaffold.hs | 4 +- yesod.cabal | 5 ++ 5 files changed, 180 insertions(+), 6 deletions(-) create mode 100644 Network/Wai/Application/Devel.hs create mode 100644 Scaffold/Devel.hs diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs new file mode 100644 index 00000000..7a741367 --- /dev/null +++ b/Network/Wai/Application/Devel.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Application.Devel + ( -- * Types + AppHolder + , AppRunner + , WithAppRunner + -- * Functions + , initAppHolder + , swapApp + , swapAppSimple + , toApp + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar + ( MVar, newEmptyMVar, newMVar + , takeMVar, putMVar, readMVar + ) +import Network.Wai (Application, responseLBS) +import Network.HTTP.Types (status500) +import Data.ByteString.Lazy.Char8 () +import Control.Monad.IO.Class (liftIO) + +type AppHolder = MVar (Application, MVar ()) +type AppRunner = Application -> IO () +type WithAppRunner = AppRunner -> IO () + +initAppHolder :: IO AppHolder +initAppHolder = do + flag <- newEmptyMVar + newMVar (initApp, flag) + where + initApp _ = return + $ responseLBS status500 [("Content-Type", "text/plain")] + $ "No app has yet been loaded" + +swapAppSimple :: Application -> AppHolder -> IO () +swapAppSimple app = + swapApp war + where + war f = f app + +swapApp :: WithAppRunner -> AppHolder -> IO () +swapApp war ah = void $ forkIO $ war $ \app -> do + (_, oldFlag) <- takeMVar ah + -- allow the old app to cleanup + putMVar oldFlag () + -- now place the new app into the AppHolder, waiting for a termination + -- signal + flag <- newEmptyMVar + putMVar ah (app, flag) + takeMVar flag -- this causes execution to hang until we are terminated + where + void x = x >> return () + +toApp :: AppHolder -> Application +toApp ah req = do + (app, _) <- liftIO $ readMVar ah + app req diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index 7e35b669..d193440a 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -1,17 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} module Scaffold.Build ( build + , getDeps + , touchDeps + , findHaskellFiles ) where import qualified Distribution.Simple.Build as B -import Distribution.PackageDescription.Parse -import Distribution.Verbosity (normal) import System.Directory (getDirectoryContents, doesDirectoryExist) import Data.List (isSuffixOf) -import Distribution.PackageDescription (packageDescription) -import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) import Distribution.Simple.Setup (defaultBuildFlags) -import Distribution.Simple.Configure (getPersistBuildConfig, localBuildInfoFile) +import Distribution.Simple.Configure (getPersistBuildConfig) import Distribution.Simple.LocalBuildInfo import qualified Data.Attoparsec.Text.Lazy as A import qualified Data.Text.Lazy.IO as TIO @@ -44,6 +43,12 @@ build = do type Deps = Map.Map FilePath (Set.Set FilePath) +getDeps :: IO Deps +getDeps = do + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + return $ fixDeps $ zip hss deps' + touchDeps :: Deps -> IO () touchDeps = mapM_ go . Map.toList diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs new file mode 100644 index 00000000..015b81eb --- /dev/null +++ b/Scaffold/Devel.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Scaffold.Devel + ( devel + ) where + +import qualified Distribution.Simple.Build as B +import Distribution.Simple.Configure (configure) +import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags) +import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Verbosity (normal) +import Distribution.PackageDescription.Parse (readPackageDescription, readHookedBuildInfo) +import Distribution.PackageDescription (FlagName (FlagName), package, emptyHookedBuildInfo) +import Distribution.Simple.LocalBuildInfo (localPkgDescr) +import Scaffold.Build (getDeps, touchDeps, findHaskellFiles) +import System.Plugins (loadDynamic) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Application.Devel +import Network.Wai.Middleware.Debug (debug) +import Data.Dynamic (fromDynamic) +import Distribution.Text (display) +import Distribution.Simple.Install (install) +import Distribution.Simple.Register (register) +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (try, SomeException) +import System.PosixCompat.Files (modificationTime, getFileStatus) +import qualified Data.Map as Map +import System.Posix.Types (EpochTime) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Network.Wai (Application, Response (ResponseBuilder)) +import Network.HTTP.Types (status500) +import Control.Monad (when) + +devel :: IO () +devel = do + appHolder <- initAppHolder + _ <- forkIO $ run 3000 $ debug $ toApp appHolder + + cabal <- defaultPackageDesc normal + gpd <- readPackageDescription normal cabal + + mhpd <- defaultHookedPackageDesc + hooked <- + case mhpd of + Nothing -> return emptyHookedBuildInfo + Just fp -> readHookedBuildInfo normal fp + + lbi <- configure (gpd, hooked) (defaultConfigFlags defaultProgramConfiguration) + { configConfigurationsFlags = [(FlagName "devel", True)] + , configUserInstall = Flag True + } + + let myTry :: IO (Either String x) -> IO (Either String x) + myTry f = try f >>= \x -> return $ case x of + Left e -> Left $ show (e :: SomeException) + Right y -> y + let getNewApp :: IO (Either String WithAppRunner) + getNewApp = myTry $ do + deps <- getDeps + touchDeps deps + + B.build + (localPkgDescr lbi) + lbi + defaultBuildFlags + [] + + install (localPkgDescr lbi) lbi defaultCopyFlags + register (localPkgDescr lbi) lbi defaultRegisterFlags + + let pi' = display $ package $ localPkgDescr lbi + dyn <- loadDynamic (pi', "Controller", "withDevelApp") + return $ case fmap fromDynamic dyn of + Nothing -> Left "withDevelApp not found" + Just Nothing -> Left "Not a withApp" + Just (Just withApp) -> Right withApp + + loop Map.empty appHolder getNewApp + +type FileList = Map.Map FilePath EpochTime + +getFileList :: IO FileList +getFileList = do + files <- findHaskellFiles "." + deps <- getDeps + let files' = files ++ map fst (Map.toList deps) + fmap Map.fromList $ flip mapM files' $ \f -> do + fs <- getFileStatus f + return (f, modificationTime fs) + +loop :: FileList -> AppHolder -> IO (Either String WithAppRunner) -> IO () +loop oldList appHolder getNewApp = do + newList <- getFileList + when (newList /= oldList) $ do + res <- getNewApp + case res of + Left s -> swapAppSimple (errApp s) appHolder + Right x -> swapApp x appHolder + threadDelay 1000000 + loop newList appHolder getNewApp + +errApp :: String -> Application +errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s diff --git a/scaffold.hs b/scaffold.hs index 8337a58d..1ce4a593 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -13,7 +13,8 @@ import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) import System.Environment (getArgs) -import Scaffold.Build +import Scaffold.Build (build) +import Scaffold.Devel (devel) qq :: String #if __GLASGOW_HASKELL__ >= 700 @@ -37,6 +38,7 @@ main = do case args of ["init"] -> scaffold ["build"] -> build + ["devel"] -> devel _ -> do putStrLn "Usage: yesod <command>" putStrLn "Available commands:" diff --git a/yesod.cabal b/yesod.cabal index 391bbfda..1392c861 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -57,10 +57,15 @@ executable yesod , unix-compat >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5 , attoparsec-text >= 0.8.5 && < 0.9 + , http-types >= 0.6.1 && < 0.7 + , blaze-builder >= 0.2 && < 0.4 + , direct-plugins >= 1.1 && < 1.2 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen Scaffold.Build + Scaffold.Devel + Network.Wai.Application.Devel if flag(ghc7) cpp-options: -DGHC7 From 1aec06f73d7e4639a28e9517daaf69f2f78477eb Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Apr 2011 17:28:34 +0300 Subject: [PATCH 583/624] Scaffolded site uses yesod devel properly --- Scaffold/Build.hs | 2 ++ full-test.sh | 7 +++--- scaffold.hs | 4 +-- scaffold/Controller_hs.cg | 5 ++++ scaffold/cabal.cg | 46 ++++++++++++++++++++-------------- scaffold/mini-Controller_hs.cg | 6 +++++ scaffold/mini-cabal.cg | 43 ++++++++++++++++++------------- scaffold/production_hs.cg | 6 ----- scaffold/test_hs.cg | 9 +++++++ 9 files changed, 80 insertions(+), 48 deletions(-) delete mode 100644 scaffold/production_hs.cg diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index d193440a..3660fb63 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -6,6 +6,8 @@ module Scaffold.Build , findHaskellFiles ) where +-- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) + import qualified Distribution.Simple.Build as B import System.Directory (getDirectoryContents, doesDirectoryExist) import Data.List (isSuffixOf) diff --git a/full-test.sh b/full-test.sh index 809d00cb..e3207151 100755 --- a/full-test.sh +++ b/full-test.sh @@ -1,7 +1,6 @@ #!/bin/sh cabal clean && cabal install && rm -rf foobar && \ - runghc scaffold.hs < input-sqlite && cd foobar && cabal install && cd .. && \ - runghc scaffold.hs < input-postgres && cd foobar && cabal install && cd .. && \ - runghc scaffold.hs < input-mini && cd foobar && cabal install && cd .. && \ - rm -rf foobar + runghc scaffold.hs init < input-sqlite && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar && \ + runghc scaffold.hs init < input-postgres && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar && \ + runghc scaffold.hs init < input-mini && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar diff --git a/scaffold.hs b/scaffold.hs index 1ce4a593..d7097e1c 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -44,6 +44,7 @@ main = do putStrLn "Available commands:" putStrLn " init Scaffold a new site" putStrLn " build Build project (performs TH dependency analysis)" + putStrLn " devel Run project with the devel server" scaffold :: IO () scaffold = do @@ -100,8 +101,7 @@ scaffold = do mkDir "julius" mkDir "static" - writeFile' "test.hs" $(codegen "test_hs") - writeFile' "production.hs" $(codegen "production_hs") + writeFile' (project ++ ".hs") $(codegen "test_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 8aafe2b2..726a2309 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -4,6 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~ + , withDevelApp ) where import ~sitearg~ @@ -12,6 +13,7 @@ import Yesod.Helpers.Static import Yesod.Helpers.Auth import Database.Persist.GenericSql import Data.ByteString (ByteString) +import Data.Dynamic (Dynamic, toDyn) -- Import all relevant handler modules here. import Handler.Root @@ -41,3 +43,6 @@ with~sitearg~ f = Settings.withConnectionPool $ \p -> do where s = static Settings.staticdir +withDevelApp :: Dynamic +withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ()) + diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 88382fcc..83474931 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -16,10 +16,34 @@ Flag production Description: Build the production executable. Default: False -executable ~project~-test - if flag(production) +Flag devel + Description: Build for use with "yesod devel" + Default: False + +library + if flag(devel) + Buildable: True + else Buildable: False - main-is: test.hs + exposed-modules: Controller + other-modules: ~sitearg~ + Model + Settings + StaticFiles + Handler.Root + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded + + main-is: ~project~.hs + build-depends: base >= 4 && < 5 , yesod >= 0.8 && < 0.9 , yesod-auth @@ -39,20 +63,4 @@ executable ~project~-test , transformers , warp , blaze-builder - ghc-options: -Wall -threaded - -executable ~project~-production - if flag(production) - Buildable: True - else - Buildable: False - cpp-options: -DPRODUCTION - main-is: production.hs - ghc-options: -Wall -threaded - -executable ~project~-devel - if flag(production) - Buildable: False - main-is: devel-server.hs - ghc-options: -Wall -O2 -threaded diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini-Controller_hs.cg index 3711043c..b207c5dc 100644 --- a/scaffold/mini-Controller_hs.cg +++ b/scaffold/mini-Controller_hs.cg @@ -4,6 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~ + , withDevelApp ) where import ~sitearg~ @@ -11,6 +12,7 @@ import Settings import Yesod.Helpers.Static import Data.ByteString (ByteString) import Network.Wai (Application) +import Data.Dynamic (Dynamic, toDyn) -- Import all relevant handler modules here. import Handler.Root @@ -38,3 +40,7 @@ with~sitearg~ f = do toWaiApp h >>= f where s = static Settings.staticdir + +withDevelApp :: Dynamic +withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ()) + diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 6d253ba7..7e48ea42 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -16,10 +16,33 @@ Flag production Description: Build the production executable. Default: False -executable ~project~-test - if flag(production) +Flag devel + Description: Build for use with "yesod devel" + Default: False + +library + if flag(devel) + Buildable: True + else Buildable: False - main-is: test.hs + exposed-modules: Controller + other-modules: ~sitearg~ + Settings + StaticFiles + Handler.Root + +executable ~project~ + if flag(devel) + Buildable: False + + if flag(production) + cpp-options: -DPRODUCTION + ghc-options: -Wall -threaded -O2 + else + ghc-options: -Wall -threaded + + main-is: ~project~.hs + build-depends: base >= 4 && < 5 , yesod-core >= 0.8 && < 0.9 , yesod-static @@ -36,17 +59,3 @@ executable ~project~-test , blaze-builder ghc-options: -Wall -threaded -executable ~project~-production - if flag(production) - Buildable: True - else - Buildable: False - cpp-options: -DPRODUCTION - main-is: production.hs - ghc-options: -Wall -threaded - -executable ~project~-devel - if flag(production) - Buildable: False - main-is: devel-server.hs - ghc-options: -Wall -O2 -threaded diff --git a/scaffold/production_hs.cg b/scaffold/production_hs.cg deleted file mode 100644 index 3ca59728..00000000 --- a/scaffold/production_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller (with~sitearg~) -import Network.Wai.Handler.Warp (run) - -main :: IO () -main = with~sitearg~ $ run 3000 - diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index 5b0089f9..35527958 100644 --- a/scaffold/test_hs.cg +++ b/scaffold/test_hs.cg @@ -1,3 +1,11 @@ +{-# LANGUAGE CPP #-} +#if PRODUCTION +import Controller (with~sitearg~) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = with~sitearg~ $ run 3000 +#else import Controller (with~sitearg~) import System.IO (hPutStrLn, stderr) import Network.Wai.Middleware.Debug (debug) @@ -8,4 +16,5 @@ main = do let port = 3000 hPutStrLn stderr $ "Application launched, listening on port " ++ show port with~sitearg~ $ run port . debug +#endif From 44e22e9261cb4950a4baeca915ae1fa86c1147f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 18 Apr 2011 17:59:59 +0300 Subject: [PATCH 584/624] Build yesod threaded --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 1392c861..0129e616 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -60,7 +60,7 @@ executable yesod , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2 && < 0.4 , direct-plugins >= 1.1 && < 1.2 - ghc-options: -Wall + ghc-options: -Wall -threaded main-is: scaffold.hs other-modules: CodeGen Scaffold.Build From 97ec67a8ba63407f72e86ff6cf05228cce34563f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 19 Apr 2011 21:01:53 +0300 Subject: [PATCH 585/624] Better Lucius support, rearrange some files --- scaffold.hs | 14 ++++++++------ scaffold/Controller_hs.cg | 2 +- scaffold/Model_hs.cg | 2 +- scaffold/Settings_hs.cg | 17 ++++++++++++++--- scaffold/cabal.cg | 4 +++- scaffold/mini-Controller_hs.cg | 2 +- scaffold/mini-Settings_hs.cg | 17 ++++++++++++++--- scaffold/mini-cabal.cg | 4 +++- scaffold/mini-sitearg_hs.cg | 2 +- scaffold/sitearg_hs.cg | 2 +- 10 files changed, 47 insertions(+), 19 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index d7097e1c..70539c33 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -98,10 +98,12 @@ scaffold = do mkDir "Handler" mkDir "hamlet" mkDir "cassius" + mkDir "lucius" mkDir "julius" mkDir "static" + mkDir "config" - writeFile' (project ++ ".hs") $(codegen "test_hs") + writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") @@ -109,19 +111,19 @@ scaffold = do writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini-Controller_hs") else $(codegen "Controller_hs") writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini-Root_hs") else $(codegen "Root_hs") when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model_hs") - writeFile' "Settings.hs" $ if backendS == "m" then $(codegen "mini-Settings_hs") else $(codegen "Settings_hs") - writeFile' "StaticFiles.hs" $(codegen "StaticFiles_hs") + writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini-Settings_hs") else $(codegen "Settings_hs") + writeFile' "config/StaticFiles.hs" $(codegen "StaticFiles_hs") writeFile' "cassius/default-layout.cassius" $(codegen "default-layout_cassius") writeFile' "hamlet/default-layout.hamlet" $(codegen "default-layout_hamlet") writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet") - writeFile' "routes" $ if backendS == "m" then $(codegen "mini-routes") else $(codegen "routes") + writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini-routes") else $(codegen "routes") writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") writeFile' "julius/homepage.julius" $(codegen "homepage_julius") - unless (backendS == "m") $ writeFile' "entities" $(codegen "entities") + unless (backendS == "m") $ writeFile' "config/models" $(codegen "entities") - S.writeFile (dir ++ "/favicon.ico") + S.writeFile (dir ++ "/config/favicon.ico") $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 726a2309..324816ee 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -26,7 +26,7 @@ mkYesodDispatch "~sitearg~" resources~sitearg~ -- Some default handlers that ship with the Yesod site template. You will -- very rarely need to modify this. getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" "favicon.ico" +getFaviconR = sendFile "image/x-icon" "config/favicon.ico" getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg index eec15f98..ba2130ac 100644 --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -8,5 +8,5 @@ import Data.Text (Text) -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist, mkMigrate "migrateAll"] $(persistFile "entities") +share [mkPersist, mkMigrate "migrateAll"] $(persistFile "config/models") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 28604294..04845033 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -10,6 +10,7 @@ module Settings ( hamletFile , cassiusFile , juliusFile + , luciusFile , widgetFile , connStr , ConnectionPool @@ -23,9 +24,10 @@ module Settings import qualified Text.Hamlet as H import qualified Text.Cassius as H import qualified Text.Julius as H +import qualified Text.Lucius as H import Language.Haskell.TH.Syntax ~importDB~ -import Yesod (MonadControlIO, addWidget, addCassius, addJulius) +import Yesod (MonadControlIO, addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) import Data.Text (Text) @@ -104,10 +106,11 @@ connectionCount = 10 -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. -toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath +toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath toHamletFile x = "hamlet/" ++ x ++ ".hamlet" toCassiusFile x = "cassius/" ++ x ++ ".cassius" toJuliusFile x = "julius/" ++ x ++ ".julius" +toLuciusFile x = "lucius/" ++ x ++ ".lucius" hamletFile :: FilePath -> Q Exp hamletFile = H.hamletFile . toHamletFile @@ -119,6 +122,13 @@ cassiusFile = H.cassiusFile . toCassiusFile cassiusFile = H.cassiusFileDebug . toCassiusFile #endif +luciusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +luciusFile = H.luciusFile . toLuciusFile +#else +luciusFile = H.luciusFileDebug . toLuciusFile +#endif + juliusFile :: FilePath -> Q Exp #ifdef PRODUCTION juliusFile = H.juliusFile . toJuliusFile @@ -131,7 +141,8 @@ widgetFile x = do let h = unlessExists toHamletFile hamletFile let c = unlessExists toCassiusFile cassiusFile let j = unlessExists toJuliusFile juliusFile - [|addWidget $h >> addCassius $c >> addJulius $j|] + let l = unlessExists toLuciusFile luciusFile + [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] where unlessExists tofn f = do e <- qRunIO $ doesFileExist $ tofn x diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 83474931..16ad2f80 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -26,6 +26,7 @@ library else Buildable: False exposed-modules: Controller + hs-source-dirs: ., config other-modules: ~sitearg~ Model Settings @@ -42,7 +43,8 @@ executable ~project~ else ghc-options: -Wall -threaded - main-is: ~project~.hs + main-is: config/~project~.hs + hs-source-dirs: ., config build-depends: base >= 4 && < 5 , yesod >= 0.8 && < 0.9 diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini-Controller_hs.cg index b207c5dc..36999c82 100644 --- a/scaffold/mini-Controller_hs.cg +++ b/scaffold/mini-Controller_hs.cg @@ -25,7 +25,7 @@ mkYesodDispatch "~sitearg~" resources~sitearg~ -- Some default handlers that ship with the Yesod site template. You will -- very rarely need to modify this. getFaviconR :: Handler () -getFaviconR = sendFile "image/x-icon" "favicon.ico" +getFaviconR = sendFile "image/x-icon" "config/favicon.ico" getRobotsR :: Handler RepPlain getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) diff --git a/scaffold/mini-Settings_hs.cg b/scaffold/mini-Settings_hs.cg index b3909933..b48fe2e5 100644 --- a/scaffold/mini-Settings_hs.cg +++ b/scaffold/mini-Settings_hs.cg @@ -10,6 +10,7 @@ module Settings ( hamletFile , cassiusFile , juliusFile + , luciusFile , widgetFile , approot , staticroot @@ -19,8 +20,9 @@ module Settings import qualified Text.Hamlet as H import qualified Text.Cassius as H import qualified Text.Julius as H +import qualified Text.Lucius as H import Language.Haskell.TH.Syntax -import Yesod.Widget (addWidget, addCassius, addJulius) +import Yesod.Widget (addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) import Data.Text (Text) @@ -76,10 +78,11 @@ staticroot = approot `mappend` "/static" -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. -toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath +toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath toHamletFile x = "hamlet/" ++ x ++ ".hamlet" toCassiusFile x = "cassius/" ++ x ++ ".cassius" toJuliusFile x = "julius/" ++ x ++ ".julius" +toLuciusFile x = "lucius/" ++ x ++ ".lucius" hamletFile :: FilePath -> Q Exp hamletFile = H.hamletFile . toHamletFile @@ -91,6 +94,13 @@ cassiusFile = H.cassiusFile . toCassiusFile cassiusFile = H.cassiusFileDebug . toCassiusFile #endif +luciusFile :: FilePath -> Q Exp +#ifdef PRODUCTION +luciusFile = H.luciusFile . toLuciusFile +#else +luciusFile = H.luciusFileDebug . toLuciusFile +#endif + juliusFile :: FilePath -> Q Exp #ifdef PRODUCTION juliusFile = H.juliusFile . toJuliusFile @@ -103,7 +113,8 @@ widgetFile x = do let h = unlessExists toHamletFile hamletFile let c = unlessExists toCassiusFile cassiusFile let j = unlessExists toJuliusFile juliusFile - [|addWidget $h >> addCassius $c >> addJulius $j|] + let l = unlessExists toLuciusFile luciusFile + [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] where unlessExists tofn f = do e <- qRunIO $ doesFileExist $ tofn x diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 7e48ea42..485b71be 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -26,6 +26,7 @@ library else Buildable: False exposed-modules: Controller + hs-source-dirs: ., config other-modules: ~sitearg~ Settings StaticFiles @@ -41,7 +42,8 @@ executable ~project~ else ghc-options: -Wall -threaded - main-is: ~project~.hs + main-is: config/~project~.hs + hs-source-dirs: ., config build-depends: base >= 4 && < 5 , yesod-core >= 0.8 && < 0.9 diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index d71aec4d..e8995f54 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -60,7 +60,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" $(parseRoutesFile "routes") +mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index d632a659..a2329abe 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -71,7 +71,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- for our application to be in scope. However, the handler functions -- usually require access to the ~sitearg~Route datatype. Therefore, we -- split these actions into two functions and place them in separate files. -mkYesodData "~sitearg~" $(parseRoutesFile "routes") +mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. From 36966acc741bcad8081873ccdb1c78b45199c5fd Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 19 Apr 2011 21:36:50 +0300 Subject: [PATCH 586/624] Removed devel-server.hs --- scaffold.hs | 1 - scaffold/devel-server_hs.cg | 3 --- 2 files changed, 4 deletions(-) delete mode 100644 scaffold/devel-server_hs.cg diff --git a/scaffold.hs b/scaffold.hs index 70539c33..9e5473b1 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -104,7 +104,6 @@ scaffold = do mkDir "config" writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") - writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini-sitearg_hs") else $(codegen "sitearg_hs") diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg deleted file mode 100644 index 71ff4eb2..00000000 --- a/scaffold/devel-server_hs.cg +++ /dev/null @@ -1,3 +0,0 @@ -main :: IO () -main = putStrLn "Please run: wai-handler-devel 3000 Controller with~sitearg~ --yesod" - From b04e034b0decb80e5d6e249c0b11fa7d9216c600 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 29 Apr 2011 09:24:22 +0300 Subject: [PATCH 587/624] Ugly devel hack, but it (hopefully) works --- Network/Wai/Application/Devel.hs | 59 ----------------- Scaffold/Devel.hs | 105 ++++++++++++++++++++++--------- yesod.cabal | 5 +- 3 files changed, 79 insertions(+), 90 deletions(-) delete mode 100644 Network/Wai/Application/Devel.hs diff --git a/Network/Wai/Application/Devel.hs b/Network/Wai/Application/Devel.hs deleted file mode 100644 index 7a741367..00000000 --- a/Network/Wai/Application/Devel.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Application.Devel - ( -- * Types - AppHolder - , AppRunner - , WithAppRunner - -- * Functions - , initAppHolder - , swapApp - , swapAppSimple - , toApp - ) where - -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar - ( MVar, newEmptyMVar, newMVar - , takeMVar, putMVar, readMVar - ) -import Network.Wai (Application, responseLBS) -import Network.HTTP.Types (status500) -import Data.ByteString.Lazy.Char8 () -import Control.Monad.IO.Class (liftIO) - -type AppHolder = MVar (Application, MVar ()) -type AppRunner = Application -> IO () -type WithAppRunner = AppRunner -> IO () - -initAppHolder :: IO AppHolder -initAppHolder = do - flag <- newEmptyMVar - newMVar (initApp, flag) - where - initApp _ = return - $ responseLBS status500 [("Content-Type", "text/plain")] - $ "No app has yet been loaded" - -swapAppSimple :: Application -> AppHolder -> IO () -swapAppSimple app = - swapApp war - where - war f = f app - -swapApp :: WithAppRunner -> AppHolder -> IO () -swapApp war ah = void $ forkIO $ war $ \app -> do - (_, oldFlag) <- takeMVar ah - -- allow the old app to cleanup - putMVar oldFlag () - -- now place the new app into the AppHolder, waiting for a termination - -- signal - flag <- newEmptyMVar - putMVar ah (app, flag) - takeMVar flag -- this causes execution to hang until we are terminated - where - void x = x >> return () - -toApp :: AppHolder -> Application -toApp ah req = do - (app, _) <- liftIO $ readMVar ah - app req diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index 015b81eb..a3ae9ca4 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -13,28 +13,40 @@ import Distribution.PackageDescription.Parse (readPackageDescription, readHooked import Distribution.PackageDescription (FlagName (FlagName), package, emptyHookedBuildInfo) import Distribution.Simple.LocalBuildInfo (localPkgDescr) import Scaffold.Build (getDeps, touchDeps, findHaskellFiles) -import System.Plugins (loadDynamic) import Network.Wai.Handler.Warp (run) -import Network.Wai.Application.Devel import Network.Wai.Middleware.Debug (debug) -import Data.Dynamic (fromDynamic) import Distribution.Text (display) import Distribution.Simple.Install (install) import Distribution.Simple.Register (register) -import Control.Concurrent (forkIO, threadDelay) -import Control.Exception (try, SomeException) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Exception (try, SomeException, finally) import System.PosixCompat.Files (modificationTime, getFileStatus) import qualified Data.Map as Map import System.Posix.Types (EpochTime) import Blaze.ByteString.Builder.Char.Utf8 (fromString) -import Network.Wai (Application, Response (ResponseBuilder)) +import Network.Wai (Application, Response (ResponseBuilder), responseLBS) import Network.HTTP.Types (status500) -import Control.Monad (when) +import Control.Monad (when, forever) +import System.Process (runCommand, terminateProcess, getProcessExitCode, waitForProcess) +import qualified Data.IORef as I +import qualified Data.ByteString.Lazy.Char8 as L +import System.Directory (doesFileExist, removeFile) + +appMessage :: L.ByteString -> IO () +appMessage l = forever $ do + run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l + threadDelay 10000 + +swapApp :: I.IORef ThreadId -> IO ThreadId -> IO () +swapApp i f = do + I.readIORef i >>= killThread + f >>= I.writeIORef i devel :: IO () devel = do - appHolder <- initAppHolder - _ <- forkIO $ run 3000 $ debug $ toApp appHolder + e <- doesFileExist "dist/devel-flag" + when e $ removeFile "dist/devel-flag" + listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef cabal <- defaultPackageDesc normal gpd <- readPackageDescription normal cabal @@ -50,12 +62,15 @@ devel = do , configUserInstall = Flag True } - let myTry :: IO (Either String x) -> IO (Either String x) - myTry f = try f >>= \x -> return $ case x of - Left e -> Left $ show (e :: SomeException) - Right y -> y - let getNewApp :: IO (Either String WithAppRunner) + let myTry :: IO () -> IO () + myTry f = try f >>= \x -> case x of + Left e -> swapApp listenThread $ forkIO $ appMessage $ L.pack $ show (e :: SomeException) + Right y -> return y + let getNewApp :: IO () getNewApp = myTry $ do + putStrLn "Rebuilding app" + swapApp listenThread $ forkIO $ appMessage "Rebuilding your app, please wait" + deps <- getDeps touchDeps deps @@ -69,13 +84,50 @@ devel = do register (localPkgDescr lbi) lbi defaultRegisterFlags let pi' = display $ package $ localPkgDescr lbi - dyn <- loadDynamic (pi', "Controller", "withDevelApp") - return $ case fmap fromDynamic dyn of - Nothing -> Left "withDevelApp not found" - Just Nothing -> Left "Not a withApp" - Just (Just withApp) -> Right withApp + writeFile "dist/devel.hs" $ unlines + [ "{-# LANGUAGE PackageImports #-}" + , concat + [ "import \"" + , "haskellers" -- FIXME + , "\" Controller (withDevelApp)" + ] + , "import Data.Dynamic (fromDynamic)" + , "import Network.Wai.Handler.Warp (run)" + , "import Network.Wai.Middleware.Debug (debug)" + , "import Data.Maybe (fromJust)" + , "import Control.Concurrent (forkIO)" + , "import System.Directory (doesFileExist, removeFile)" + , "import Control.Concurrent (threadDelay)" + , "" + , "main :: IO ()" + , "main = do" + , " putStrLn \"Starting app\"" + , " forkIO $ (fromJust $ fromDynamic withDevelApp) $ run 3000" + , " loop" + , "" + , "loop :: IO ()" + , "loop = do" + , " threadDelay 100000" + , " e <- doesFileExist \"dist/devel-flag\"" + , " if e then removeFile \"dist/devel-flag\" else loop" + ] + swapApp listenThread $ forkIO $ do + putStrLn "Calling runghc..." + ph <- runCommand "runghc dist/devel.hs" + let forceType :: Either SomeException () -> () + forceType = const () + fmap forceType $ try sleepForever + writeFile "dist/devel-flag" "" + putStrLn "Terminating external process" + terminateProcess ph + putStrLn "Process terminated" + ec <- waitForProcess ph + putStrLn $ "Exit code: " ++ show ec - loop Map.empty appHolder getNewApp + loop Map.empty getNewApp + +sleepForever :: IO () +sleepForever = forever $ threadDelay 1000000 type FileList = Map.Map FilePath EpochTime @@ -88,16 +140,13 @@ getFileList = do fs <- getFileStatus f return (f, modificationTime fs) -loop :: FileList -> AppHolder -> IO (Either String WithAppRunner) -> IO () -loop oldList appHolder getNewApp = do +loop :: FileList -> IO () -> IO () +loop oldList getNewApp = do + putStrLn "Testing files..." newList <- getFileList - when (newList /= oldList) $ do - res <- getNewApp - case res of - Left s -> swapAppSimple (errApp s) appHolder - Right x -> swapApp x appHolder + when (newList /= oldList) getNewApp threadDelay 1000000 - loop newList appHolder getNewApp + loop newList getNewApp errApp :: String -> Application errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s diff --git a/yesod.cabal b/yesod.cabal index 0129e616..5914e099 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.0 +version: 0.8.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -59,13 +59,12 @@ executable yesod , attoparsec-text >= 0.8.5 && < 0.9 , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2 && < 0.4 - , direct-plugins >= 1.1 && < 1.2 + , process ghc-options: -Wall -threaded main-is: scaffold.hs other-modules: CodeGen Scaffold.Build Scaffold.Devel - Network.Wai.Application.Devel if flag(ghc7) cpp-options: -DGHC7 From fe592b6ad1d08d0ad9b15c2561b8e88379727b31 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 29 Apr 2011 16:36:30 +0300 Subject: [PATCH 588/624] Removed some debug --- Scaffold/Devel.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index a3ae9ca4..fa71aa69 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -31,6 +31,7 @@ import System.Process (runCommand, terminateProcess, getProcessExitCode, waitFor import qualified Data.IORef as I import qualified Data.ByteString.Lazy.Char8 as L import System.Directory (doesFileExist, removeFile) +import Distribution.Package (PackageName (..), pkgName) appMessage :: L.ByteString -> IO () appMessage l = forever $ do @@ -83,12 +84,12 @@ devel = do install (localPkgDescr lbi) lbi defaultCopyFlags register (localPkgDescr lbi) lbi defaultRegisterFlags - let pi' = display $ package $ localPkgDescr lbi + let PackageName pi' = pkgName $ package $ localPkgDescr lbi writeFile "dist/devel.hs" $ unlines [ "{-# LANGUAGE PackageImports #-}" , concat [ "import \"" - , "haskellers" -- FIXME + , pi' , "\" Controller (withDevelApp)" ] , "import Data.Dynamic (fromDynamic)" From b635e0f2ecfc659664afac0ed53bcec8e13dc4f8 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sun, 15 May 2011 09:03:39 -0700 Subject: [PATCH 589/624] generate html5boilerplate hamlet and css --- scaffold.hs | 26 +++--- scaffold/boilerplate-layout_hamlet.cg | 30 +++++++ scaffold/boilerplate_css.cg | 116 ++++++++++++++++++++++++++ 3 files changed, 159 insertions(+), 13 deletions(-) create mode 100644 scaffold/boilerplate-layout_hamlet.cg create mode 100644 scaffold/boilerplate_css.cg diff --git a/scaffold.hs b/scaffold.hs index 9e5473b1..d39313b7 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -46,14 +46,15 @@ main = do putStrLn " build Build project (performs TH dependency analysis)" putStrLn " devel Run project with the devel server" +puts :: String -> IO () +puts s = putStr s >> hFlush stdout + scaffold :: IO () scaffold = do - putStr $(codegen "welcome") - hFlush stdout + puts $(codegen "welcome") name <- getLine - putStr $(codegen "project-name") - hFlush stdout + puts $(codegen "project-name") let validPN c | 'A' <= c && c <= 'Z' = True | 'a' <= c && c <= 'z' = True @@ -62,19 +63,13 @@ scaffold = do validPN '_' = True validPN _ = False project <- prompt $ all validPN + let dir = project - putStr $(codegen "dir-name") - hFlush stdout - dirRaw <- getLine - let dir = if null dirRaw then project else dirRaw - - putStr $(codegen "site-arg") - hFlush stdout + puts $(codegen "site-arg") let isUpperAZ c = 'A' <= c && c <= 'Z' sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main" - putStr $(codegen "database") - hFlush stdout + puts $(codegen "database") backendS <- prompt $ flip elem ["s", "p", "m"] let pconn1 = $(codegen "pconn1") let pconn2 = $(codegen "pconn2") @@ -101,6 +96,7 @@ scaffold = do mkDir "lucius" mkDir "julius" mkDir "static" + mkDir "static/css" mkDir "config" writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") @@ -116,6 +112,10 @@ scaffold = do $(codegen "default-layout_cassius") writeFile' "hamlet/default-layout.hamlet" $(codegen "default-layout_hamlet") + writeFile' "hamlet/boilerplate-layout.hamlet" + $(codegen "boilerplate-layout_hamlet") + writeFile' "static/css/html5boilerplate.css" + $(codegen "boilerplate_css") writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet") writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini-routes") else $(codegen "routes") writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") diff --git a/scaffold/boilerplate-layout_hamlet.cg b/scaffold/boilerplate-layout_hamlet.cg new file mode 100644 index 00000000..4e59cda3 --- /dev/null +++ b/scaffold/boilerplate-layout_hamlet.cg @@ -0,0 +1,30 @@ +\<!doctype html>M +\<!--[if lt IE 7 ]> <html lang="en" class="no-js ie6"> <![endif]-->^M +\<!--[if IE 7 ]> <html lang="en" class="no-js ie7"> <![endif]-->^M +\<!--[if IE 8 ]> <html lang="en" class="no-js ie8"> <![endif]-->^M +\<!--[if IE 9 ]> <html lang="en" class="no-js ie9"> <![endif]-->^M +\<!--[if (gt IE 9)|!(IE)]><!--> +<html lang="en" class="no-js"><!--<![endif]-->^M + <head> + <meta charset="UTF-8"> + <meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1"> + <meta name="viewport" content="width=device-width, initial-scale=1.0"> + + <meta name="description" content=""> + <meta name="author" content=""> + + <title>#{pageTitle pc} + + <link rel="stylesheet" href=@{StaticR css_html5boilerplate_css}> + ^{pageHead pc} + + <!--[if lt IE 9]> + <script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> + <![endif]-->^M + + <script> + document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); + <body> + $maybe msg <- mmsg + <div #message>#{msg} + ^{pageBody pc} diff --git a/scaffold/boilerplate_css.cg b/scaffold/boilerplate_css.cg new file mode 100644 index 00000000..e24c3d37 --- /dev/null +++ b/scaffold/boilerplate_css.cg @@ -0,0 +1,116 @@ +/* HTML5 ✰ Boilerplate */ + +html, body, div, span, object, iframe, +h1, h2, h3, h4, h5, h6, p, blockquote, pre, +abbr, address, cite, code, del, dfn, em, img, ins, kbd, q, samp, +small, strong, sub, sup, var, b, i, dl, dt, dd, ol, ul, li, +fieldset, form, label, legend, +table, caption, tbody, tfoot, thead, tr, th, td, +article, aside, canvas, details, figcaption, figure, +footer, header, hgroup, menu, nav, section, summary, +time, mark, audio, video { + margin: 0; + padding: 0; + border: 0; + font-size: 100%; + font: inherit; + vertical-align: baseline; +} + +article, aside, details, figcaption, figure, +footer, header, hgroup, menu, nav, section { + display: block; +} + +blockquote, q { quotes: none; } +blockquote:before, blockquote:after, +q:before, q:after { content: ''; content: none; } +ins { background-color: #ff9; color: #000; text-decoration: none; } +mark { background-color: #ff9; color: #000; font-style: italic; font-weight: bold; } +del { text-decoration: line-through; } +abbr[title], dfn[title] { border-bottom: 1px dotted; cursor: help; } +table { border-collapse: collapse; border-spacing: 0; } +hr { display: block; height: 1px; border: 0; border-top: 1px solid #ccc; margin: 1em 0; padding: 0; } +input, select { vertical-align: middle; } + +body { font:13px/1.231 sans-serif; *font-size:small; } +select, input, textarea, button { font:99% sans-serif; } +pre, code, kbd, samp { font-family: monospace, sans-serif; } + +html { overflow-y: scroll; } +a:hover, a:active { outline: none; } +ul, ol { margin-left: 2em; } +ol { list-style-type: decimal; } +nav ul, nav li { margin: 0; list-style:none; list-style-image: none; } +small { font-size: 85%; } +strong, th { font-weight: bold; } +td { vertical-align: top; } + +sub, sup { font-size: 75%; line-height: 0; position: relative; } +sup { top: -0.5em; } +sub { bottom: -0.25em; } + +pre { white-space: pre; white-space: pre-wrap; word-wrap: break-word; padding: 15px; } +textarea { overflow: auto; } +.ie6 legend, .ie7 legend { margin-left: -7px; } +input[type="radio"] { vertical-align: text-bottom; } +input[type="checkbox"] { vertical-align: bottom; } +.ie7 input[type="checkbox"] { vertical-align: baseline; } +.ie6 input { vertical-align: text-bottom; } +label, input[type="button"], input[type="submit"], input[type="image"], button { cursor: pointer; } +button, input, select, textarea { margin: 0; } +input:valid, textarea:valid { } +input:invalid, textarea:invalid { border-radius: 1px; -moz-box-shadow: 0px 0px 5px red; -webkit-box-shadow: 0px 0px 5px red; box-shadow: 0px 0px 5px red; } +.no-boxshadow input:invalid, .no-boxshadow textarea:invalid { background-color: #f0dddd; } + +::-moz-selection{ background: #FF5E99; color:#fff; text-shadow: none; } +::selection { background:#FF5E99; color:#fff; text-shadow: none; } +a:link { -webkit-tap-highlight-color: #FF5E99; } + +button { width: auto; overflow: visible; } +.ie7 img { -ms-interpolation-mode: bicubic; } + +body, select, input, textarea { color: #444; } +h1, h2, h3, h4, h5, h6 { font-weight: bold; } +a, a:active, a:visited { color: #607890; } +a:hover { color: #036; } + +.ir { display: block; text-indent: -999em; overflow: hidden; background-repeat: no-repeat; text-align: left; direction: ltr; } +.hidden { display: none; visibility: hidden; } +.visuallyhidden { border: 0; clip: rect(0 0 0 0); height: 1px; margin: -1px; overflow: hidden; padding: 0; position: absolute; width: 1px; } +.visuallyhidden.focusable:active, +.visuallyhidden.focusable:focus { clip: auto; height: auto; margin: 0; overflow: visible; position: static; width: auto; } +.invisible { visibility: hidden; } +.clearfix:before, .clearfix:after { content: "\0020"; display: block; height: 0; overflow: hidden; } +.clearfix:after { clear: both; } +.clearfix { zoom: 1; } + + +@media all and (orientation:portrait) { + +} + +@media all and (orientation:landscape) { + +} + +@media screen and (max-device-width: 480px) { + + /* html { -webkit-text-size-adjust:none; -ms-text-size-adjust:none; } */ +} + + +@media print { + * { background: transparent !important; color: black !important; text-shadow: none !important; filter:none !important; + -ms-filter: none !important; } + a, a:visited { color: #444 !important; text-decoration: underline; } + a[href]:after { content: " (" attr(href) ")"; } + abbr[title]:after { content: " (" attr(title) ")"; } + .ir a:after, a[href^="javascript:"]:after, a[href^="#"]:after { content: ""; } + pre, blockquote { border: 1px solid #999; page-break-inside: avoid; } + thead { display: table-header-group; } + tr, img { page-break-inside: avoid; } + @page { margin: 0.5cm; } + p, h2, h3 { orphans: 3; widows: 3; } + h2, h3{ page-break-after: avoid; } +} From 350f0e947c0848cc99c2ef099b3be627c1a024e5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 16 May 2011 22:04:35 +0300 Subject: [PATCH 590/624] Messages files support in yesod build --- Scaffold/Build.hs | 56 +++++++++++++++++++++++----------------- Scaffold/Devel.hs | 1 - scaffold/favicon_ico.cg | Bin 1150 -> 1150 bytes yesod.cabal | 10 +++---- 4 files changed, 38 insertions(+), 29 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index 3660fb63..24ea56a3 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -23,6 +23,7 @@ import Data.Monoid (mappend) import qualified Data.Map as Map import qualified Data.Set as Set import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) +import Data.Text (unpack) build :: IO () build = do @@ -56,7 +57,7 @@ touchDeps = mapM_ go . Map.toList where go (x, ys) = do - fs <- getFileStatus x + fs <- getFileStatus x -- FIXME ignore exceptions flip mapM_ (Set.toList ys) $ \y -> do fs' <- getFileStatus y if modificationTime fs' < modificationTime fs @@ -88,38 +89,47 @@ findHaskellFiles path = do then return [y] else return [] -data TempType = Hamlet | Cassius | Lucius | Julius | Widget | Verbatim +data TempType = Hamlet | Verbatim | Messages FilePath deriving Show determineHamletDeps :: FilePath -> IO [FilePath] determineHamletDeps x = do - y <- TIO.readFile x + y <- TIO.readFile x -- FIXME catch IO exceptions let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y case z of A.Fail{} -> return [] - A.Done _ r -> return $ mapMaybe go r + A.Done _ r -> return $ concatMap go r where - go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" - go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" - go (Just (Verbatim, f)) = Just f - go _ = Nothing + go (Just (Hamlet, f)) = [f, "hamlet/" ++ f ++ ".hamlet"] + go (Just (Verbatim, f)) = [f] + go (Just (Messages f, _)) = [f] + go Nothing = [] parser = do ty <- (A.string "$(hamletFile " >> return Hamlet) - <|> (A.string "$(cassiusFile " >> return Cassius) - <|> (A.string "$(luciusFile " >> return Lucius) - <|> (A.string "$(juliusFile " >> return Julius) - <|> (A.string "$(widgetFile " >> return Widget) + <|> (A.string "$(ihamletFile " >> return Hamlet) + <|> (A.string "$(whamletFile " >> return Hamlet) + <|> (A.string "$(html " >> return Hamlet) + <|> (A.string "$(widgetFile " >> return Hamlet) <|> (A.string "$(Settings.hamletFile " >> return Hamlet) - <|> (A.string "$(Settings.cassiusFile " >> return Cassius) - <|> (A.string "$(Settings.luciusFile " >> return Lucius) - <|> (A.string "$(Settings.juliusFile " >> return Julius) - <|> (A.string "$(Settings.widgetFile " >> return Widget) + <|> (A.string "$(Settings.widgetFile " >> return Hamlet) <|> (A.string "$(persistFile " >> return Verbatim) <|> (A.string "$(parseRoutesFile " >> return Verbatim) - A.skipWhile isSpace - _ <- A.char '"' - y <- A.many1 $ A.satisfy (/= '"') - _ <- A.char '"' - A.skipWhile isSpace - _ <- A.char ')' - return $ Just (ty, y) + <|> (do + A.string "\nmkMessage \"" + A.skipWhile (/= '"') + A.string "\" \"" + x <- A.many1 $ A.satisfy (/= '"') + A.string "\" \"" + y <- A.many1 $ A.satisfy (/= '"') + A.string "\"" + return $ Messages $ concat [x, "/", y, ".msg"]) + case ty of + Messages{} -> return $ Just (ty, "") + _ -> do + A.skipWhile isSpace + _ <- A.char '"' + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.char '"' + A.skipWhile isSpace + _ <- A.char ')' + return $ Just (ty, y) diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index fa71aa69..e6c50345 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -143,7 +143,6 @@ getFileList = do loop :: FileList -> IO () -> IO () loop oldList getNewApp = do - putStrLn "Testing files..." newList <- getFileList when (newList /= oldList) getNewApp threadDelay 1000000 diff --git a/scaffold/favicon_ico.cg b/scaffold/favicon_ico.cg index 9888b98f958ff23094403e2f8ce27894d1f186c3..283cccf089c024071d661928a493e978865c2f21 100644 GIT binary patch literal 1150 zcmZQzU<5(|0R|wcz>vYhz#zuJz@P!dKp~(AL>x#lFaYJy!T<mN89?~shYx%c!aOhc z1=v5B9OZd+a)STaMYZ`$?_54_3{!)T2I*f?p0i?ZLGtE_aeil~B?q6Jk{WV+=b{-U zUp{~0!KW7__v6P8Hkg_##}2woP7XOfBQxUAlE&hN_pV(wfXNX<zkB^sbkpR{c98wk zb7J<M-n%{E&!0bx#OMX7`3ZE(p|#6WCME`+nwcNBd;9#U6(BP~a>(w)W!~#&Ph{3~ z*H5077It)ANy^qmKtDXZeM5^_{a244cAAtFbaGZs%>D&sshek)rffccXpa}jZbJ5d z`tY8A>x{m}zDSR&)3c)X&n`~hI<GQg-S&mkN<X}ND?~{D<2yGsrX&R)pA_$RenDmK zilr@Oa~4!(tzFz&Hs|TX`%3u2@%y)L>_^rtOX>8teE>>7yB5wY*}Zg50m%OOwYe)U z9Nq7R&;ECBUW?33kJ{fC;(U8nZrtumNA|m&*|)=YQA5GfB~3+(w=bSi^6BFTK5XF* za@VDUd%W7*&0bCjcfGl^p=9CPS1(0D;l8@BapJPpl7&k;s%AcY^gte){%=6HFR92` z(dA|Nd{T_hg`M-JR>0zG8!-Ms_Al?Mnt6EZniy<;cy#NAR*R$IyIwz=$1^jd_TM;t z+zw{X={;M6R&-X)T+>%KW$o0C&fTjPWWnTM^ya?S?lwn*552xNj~7?wEl0NF)$?bP zYbUpNuIj0szIkSM`{sEQ>R|d{^wb#tQxhV*FHBF3ICym3iX@mgjJ|W_qS5*pJ<Y2p zw{@?d-PZ^cfAF7y0fhh5L-0QkZ4bdefb<V}28N&W85ll-a6bdX<MTj#oPpsm5FdZc GzyJWoUd7G; literal 1150 zcmZQzU<5(|0R|wcz>vYhz#zuJz@P!dKp~(AL>x#lFaYJy!T<mN8DRL$oA07oSx3(W z1nmB_XU~%;m^iWY#EDmC6cwE~R9=2+x3BN6ukYXg5GGbHNF7N3pFe*YK)9*t-0BS* z9%PfE|J=FPjxhDtufI2~tv$0D#wV2qxgjy};H}@k|1guP7pA_j@c5A%H{Kh;_@vMe zAAVBv^xW}x{rdYPg#pZto}NpyJv?^&Z*RY_3?@b_{qp5EDIcGmKN1oS-bqP0e3e*z zFm*F$Uhe_f4Rm{MY3a$mAoE~ygy@eSe+q)qUvTiAcb`B1;+Z@5X6u0i&q4|5gUK&l zdb=8A_w3o%J3(T{j=k`iJo)M*m^?oE+qd7GVPSh;dU@^q_2R`>S&&*#8U}>}C_TXR z-o5)#7sf`Wf$231TbO5L967&l-_tOV+DDH*tFB#pzW`Yuhz&|-ad8Lkf%F5@t}(Lw ziWPS%K=DymcV>N5)c(g;uDr8AmItwcY2O}XPiyOWjQ9rm3n;!E7^ZK5anp^g_w#=S hhKE4>7Ks0$;Xm~Z3?TdyhW9fte1_uZ#~Bzv7y!I9`)dFI diff --git a/yesod.cabal b/yesod.cabal index 5914e099..50a94401 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.0.1 +version: 0.8.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -13,7 +13,7 @@ category: Web, Yesod stability: Stable cabal-version: >= 1.6 build-type: Simple -homepage: http://docs.yesodweb.com/ +homepage: http://www.yesodweb.com/ extra-source-files: scaffold/*.cg flag ghc7 @@ -24,8 +24,8 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: yesod-core >= 0.8 && < 0.9 - , yesod-auth >= 0.4 && < 0.5 + build-depends: yesod-core >= 0.8.1 && < 0.9 + , yesod-auth >= 0.4 && < 0.6 , yesod-json >= 0.1 && < 0.2 , yesod-persistent >= 0.1 && < 0.2 , yesod-static >= 0.1 && < 0.2 @@ -34,7 +34,7 @@ library , transformers >= 0.2 && < 0.3 , wai >= 0.4 && < 0.5 , wai-extra >= 0.4 && < 0.5 - , hamlet >= 0.8 && < 0.9 + , hamlet >= 0.8.1 && < 0.9 , warp >= 0.4 && < 0.5 , mime-mail >= 0.3 && < 0.4 , hjsmin >= 0.0.13 && < 0.1 From c916ae568e53f56d1ef11f7c7a87456e664ddf36 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 23 May 2011 15:50:42 +0300 Subject: [PATCH 591/624] Reference config/routes properly. --- scaffold/Root_hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg index d281f767..418fde85 100644 --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -5,7 +5,7 @@ import ~sitearg~ -- This is a handler function for the GET request method on the RootR -- resource pattern. All of your resource patterns are defined in --- ~sitearg~.hs; look for the line beginning with mkYesodData. +-- config/routes -- -- The majority of the code you will write in Yesod lives in these handler -- functions. You can spread them across multiple files if you are so From 580fefca9c15e44437ec19de8df224d34f554b09 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Mon, 23 May 2011 15:58:39 +0300 Subject: [PATCH 592/624] Less yesod build crashes --- Scaffold/Build.hs | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index 24ea56a3..2c7d4e95 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -9,7 +9,7 @@ module Scaffold.Build -- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) import qualified Distribution.Simple.Build as B -import System.Directory (getDirectoryContents, doesDirectoryExist) +import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import Data.List (isSuffixOf) import Distribution.Simple.Setup (defaultBuildFlags) import Distribution.Simple.Configure (getPersistBuildConfig) @@ -22,8 +22,10 @@ import Data.Maybe (mapMaybe) import Data.Monoid (mappend) import qualified Data.Map as Map import qualified Data.Set as Set -import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) +import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes, FileStatus) import Data.Text (unpack) +import Control.Monad (filterM) +import Control.Exception (SomeException, try) build :: IO () build = do @@ -57,15 +59,25 @@ touchDeps = mapM_ go . Map.toList where go (x, ys) = do - fs <- getFileStatus x -- FIXME ignore exceptions + (_, mod1) <- getFileStatus' x flip mapM_ (Set.toList ys) $ \y -> do - fs' <- getFileStatus y - if modificationTime fs' < modificationTime fs + (access, mod2) <- getFileStatus' y + if mod2 < mod1 then do putStrLn $ "Touching " ++ y ++ " because of " ++ x - setFileTimes y (accessTime fs') (modificationTime fs) + _ <- try' $ setFileTimes y access mod1 + return () else return () +try' :: IO x -> IO (Either SomeException x) +try' = try + +getFileStatus' fp = do + efs <- try' $ getFileStatus fp + case efs of + Left _ -> return (0, 0) + Right fs -> return (accessTime fs, modificationTime fs) + fixDeps :: [(FilePath, [FilePath])] -> Deps fixDeps = Map.unionsWith mappend . map go @@ -98,7 +110,7 @@ determineHamletDeps x = do let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y case z of A.Fail{} -> return [] - A.Done _ r -> return $ concatMap go r + A.Done _ r -> filterM doesFileExist $ concatMap go r where go (Just (Hamlet, f)) = [f, "hamlet/" ++ f ++ ".hamlet"] go (Just (Verbatim, f)) = [f] From de91f350f5410e45b9fd0653cfabba389f2548a8 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Mon, 30 May 2011 20:28:10 -0700 Subject: [PATCH 593/624] DRY scaffolding --- scaffold/Settings_hs.cg | 48 +++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index 04845033..d4d35ac0 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -35,15 +35,16 @@ import Data.Text (Text) -- | The base URL for your application. This will usually be different for -- development and production. Yesod automatically constructs URLs for you, -- so this value must be accurate to create valid links. +-- Please note that there is no trailing slash. approot :: Text +approot = #ifdef PRODUCTION -- You probably want to change this. If your domain name was "yesod.com", -- you would probably want it to be: --- > approot = "http://www.yesod.com" --- Please note that there is no trailing slash. -approot = "http://localhost:3000" +-- > "http://yesod.com" + "http://localhost:3000" #else -approot = "http://localhost:3000" + "http://localhost:3000" #endif -- | The location of static files on your system. This is a file system @@ -70,10 +71,11 @@ staticroot = approot `mappend` "/static" -- | The database connection string. The meaning of this string is backend- -- specific. connStr :: Text +connStr = #ifdef PRODUCTION -connStr = "~connstr2~" + "~connstr2~" #else -connStr = "~connstr1~" + "~connstr1~" #endif -- | Your application will keep a connection pool and take connections from @@ -106,42 +108,43 @@ connectionCount = 10 -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. -toHamletFile, toCassiusFile, toJuliusFile, toLuciusFile :: String -> FilePath -toHamletFile x = "hamlet/" ++ x ++ ".hamlet" -toCassiusFile x = "cassius/" ++ x ++ ".cassius" -toJuliusFile x = "julius/" ++ x ++ ".julius" -toLuciusFile x = "lucius/" ++ x ++ ".lucius" +-- | expects a root folder for each type, e.g: hamlet/ lucius/ julius/ +globFile :: String -> String -> FilePath +globFile kind x = kind ++ "/" ++ x ++ "." ++ kind hamletFile :: FilePath -> Q Exp -hamletFile = H.hamletFile . toHamletFile +hamletFile = H.hamletFile . globFile "hamlet" cassiusFile :: FilePath -> Q Exp +cassiusFile = #ifdef PRODUCTION -cassiusFile = H.cassiusFile . toCassiusFile + H.cassiusFile . globFile "cassius" #else -cassiusFile = H.cassiusFileDebug . toCassiusFile + H.cassiusFileDebug . globFile "cassius" #endif luciusFile :: FilePath -> Q Exp +luciusFile = #ifdef PRODUCTION -luciusFile = H.luciusFile . toLuciusFile + H.luciusFile . globFile "lucius" #else -luciusFile = H.luciusFileDebug . toLuciusFile + H.luciusFileDebug . globFile "lucius" #endif juliusFile :: FilePath -> Q Exp +juliusFile = #ifdef PRODUCTION -juliusFile = H.juliusFile . toJuliusFile + H.juliusFile . globFile "julius" #else -juliusFile = H.juliusFileDebug . toJuliusFile + H.juliusFileDebug . globFile "julius" #endif widgetFile :: FilePath -> Q Exp widgetFile x = do - let h = unlessExists toHamletFile hamletFile - let c = unlessExists toCassiusFile cassiusFile - let j = unlessExists toJuliusFile juliusFile - let l = unlessExists toLuciusFile luciusFile + let h = unlessExists (globFile "hamlet") hamletFile + let c = unlessExists (globFile "cassius") cassiusFile + let j = unlessExists (globFile "julius") juliusFile + let l = unlessExists (globFile "lucius") luciusFile [|addWidget $h >> addCassius $c >> addJulius $j >> addLucius $l|] where unlessExists tofn f = do @@ -157,4 +160,3 @@ withConnectionPool = with~upper~Pool connStr connectionCount runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool - From 1cdb2495bcade8cc0ac499c25fe917a2411c2dca Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 7 Jun 2011 09:34:31 +0300 Subject: [PATCH 594/624] Minor scaffolding fixes --- scaffold/cabal.cg | 2 +- scaffold/mini-sitearg_hs.cg | 2 +- scaffold/sitearg_hs.cg | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 16ad2f80..b2b32641 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -49,7 +49,7 @@ executable ~project~ build-depends: base >= 4 && < 5 , yesod >= 0.8 && < 0.9 , yesod-auth - , yesod-static + , yesod-static >= 0.1 && < 0.2 , mime-mail , wai-extra , directory diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index e8995f54..2d94cc5d 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -18,7 +18,7 @@ import Yesod.Helpers.Static import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L -import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) +import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile) import StaticFiles import Control.Monad (unless) import Control.Monad.Trans.Class (lift) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index a2329abe..a2232864 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -24,7 +24,7 @@ import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L import Database.Persist.GenericSql -import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) +import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile) import Model import StaticFiles import Data.Maybe (isJust) From 96bbe094864df9fe98458b581f992b4a94c6a6b3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 7 Jun 2011 09:46:55 +0300 Subject: [PATCH 595/624] More scaffolding fixes --- scaffold.hs | 1 - scaffold/cabal.cg | 3 +-- scaffold/mini-cabal.cg | 1 - 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index d39313b7..8d232725 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -60,7 +60,6 @@ scaffold = do | 'a' <= c && c <= 'z' = True | '0' <= c && c <= '9' = True validPN '-' = True - validPN '_' = True validPN _ = False project <- prompt $ all validPN let dir = project diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index b2b32641..84d0e91f 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -48,7 +48,7 @@ executable ~project~ build-depends: base >= 4 && < 5 , yesod >= 0.8 && < 0.9 - , yesod-auth + , yesod-auth >= 0.4 && < 0.5 , yesod-static >= 0.1 && < 0.2 , mime-mail , wai-extra @@ -60,7 +60,6 @@ executable ~project~ , persistent-~lower~ >= 0.5 && < 0.6 , template-haskell , hamlet - , web-routes , hjsmin , transformers , warp diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 485b71be..7e69d651 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -54,7 +54,6 @@ executable ~project~ , text , template-haskell , hamlet - , web-routes , transformers , wai , warp From 674b02f35fe6552c1c43e68b61893810022d4915 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Tue, 7 Jun 2011 09:47:29 +0300 Subject: [PATCH 596/624] Version bump --- yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod.cabal b/yesod.cabal index 50a94401..72c7f8d1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.1 +version: 0.8.2 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> From 7c785bb769560c0ac356057df58ce62c1850ddc1 Mon Sep 17 00:00:00 2001 From: alios <alios@alios.org> Date: Sat, 11 Jun 2011 20:22:49 +0200 Subject: [PATCH 597/624] added a .ghci to scaffold created projects to expand the search path to config dir --- scaffold.hs | 1 + scaffold/dotghci.cg | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 scaffold/dotghci.cg diff --git a/scaffold.hs b/scaffold.hs index 8d232725..9df2a419 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -100,6 +100,7 @@ scaffold = do writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") + writeFile' ".ghci" $(codegen "dotghci") writeFile' "LICENSE" $(codegen "LICENSE") writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini-sitearg_hs") else $(codegen "sitearg_hs") writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini-Controller_hs") else $(codegen "Controller_hs") diff --git a/scaffold/dotghci.cg b/scaffold/dotghci.cg new file mode 100644 index 00000000..44fa6f76 --- /dev/null +++ b/scaffold/dotghci.cg @@ -0,0 +1,2 @@ +:set -i.:config:dist/build/autogen + From 046815d9e19ad2303f95f393b12b80885e0b14e7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Thu, 9 Jun 2011 15:11:03 +0300 Subject: [PATCH 598/624] yesod-auth upper bounds --- yesod.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod.cabal b/yesod.cabal index 72c7f8d1..bb964045 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.8.2 +version: 0.8.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> @@ -25,7 +25,7 @@ library else build-depends: base >= 4 && < 4.3 build-depends: yesod-core >= 0.8.1 && < 0.9 - , yesod-auth >= 0.4 && < 0.6 + , yesod-auth >= 0.4 && < 0.5 , yesod-json >= 0.1 && < 0.2 , yesod-persistent >= 0.1 && < 0.2 , yesod-static >= 0.1 && < 0.2 From 97086f2bdd8b7a605d96981b7d5c7eb8c4cc736f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 26 Jun 2011 08:17:44 +0300 Subject: [PATCH 599/624] Fix a URL in a comment --- scaffold/sitearg_hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index a2232864..a80a3acb 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -54,7 +54,7 @@ type Widget = GWidget ~sitearg~ ~sitearg~ -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: --- http://docs.yesodweb.com/book/web-routes-quasi/ +-- http://www.yesodweb.com/book/handler -- -- This function does three things: -- From 0a65be849ef83c9f3b094136fe7ffae75ab1542e Mon Sep 17 00:00:00 2001 From: Max Cantor <mxcantor@gmail.com> Date: Thu, 30 Jun 2011 01:54:02 -0700 Subject: [PATCH 600/624] added touch command --- scaffold.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/scaffold.hs b/scaffold.hs index 9df2a419..49f68ea2 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -13,7 +13,7 @@ import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) import System.Environment (getArgs) -import Scaffold.Build (build) +import Scaffold.Build (build, touch) import Scaffold.Devel (devel) qq :: String @@ -38,12 +38,14 @@ main = do case args of ["init"] -> scaffold ["build"] -> build + ["touch"] -> touch ["devel"] -> devel _ -> do putStrLn "Usage: yesod <command>" putStrLn "Available commands:" putStrLn " init Scaffold a new site" putStrLn " build Build project (performs TH dependency analysis)" + putStrLn " touch Touch any files with altered TH dependencies but do not build" putStrLn " devel Run project with the devel server" puts :: String -> IO () From e626c141a4313da8ce3730ffe1d6c5844c048c44 Mon Sep 17 00:00:00 2001 From: Max Cantor <mxcantor@gmail.com> Date: Thu, 30 Jun 2011 01:55:09 -0700 Subject: [PATCH 601/624] added touch command --- Scaffold/Build.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index 2c7d4e95..e479b6a0 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Scaffold.Build ( build + , touch , getDeps , touchDeps , findHaskellFiles @@ -27,6 +28,14 @@ import Data.Text (unpack) import Control.Monad (filterM) import Control.Exception (SomeException, try) +-- | Touch any files with altered dependencies but do not build +touch :: IO () +touch = do + hss <- findHaskellFiles "." + deps' <- mapM determineHamletDeps hss + let deps = fixDeps $ zip hss deps' + touchDeps deps + build :: IO () build = do {- From aef96b15423ffeb59288189e014dc14a0c2fd353 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Thu, 7 Jul 2011 16:56:26 -0700 Subject: [PATCH 602/624] refer to book, not docs --- README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README b/README index c738f600..f98ab5ec 100644 --- a/README +++ b/README @@ -1,3 +1,3 @@ After installing, type "yesod init" to start a new project. -Learn more at http://docs.yesodweb.com/ +Learn more at http://www.yesodweb.com/book From 466ba86a55b3ac452a70fbc87f98754e4af5df33 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Thu, 7 Jul 2011 19:32:08 -0700 Subject: [PATCH 603/624] use shelltestrunner for scaffolding tests --- full-test.sh | 6 ------ input-mini | 5 ----- input-postgres | 5 ----- input-sqlite | 5 ----- test.shelltest | 36 ++++++++++++++++++++++++++++++++++++ 5 files changed, 36 insertions(+), 21 deletions(-) delete mode 100755 full-test.sh delete mode 100644 input-mini delete mode 100644 input-postgres delete mode 100644 input-sqlite create mode 100644 test.shelltest diff --git a/full-test.sh b/full-test.sh deleted file mode 100755 index e3207151..00000000 --- a/full-test.sh +++ /dev/null @@ -1,6 +0,0 @@ -#!/bin/sh - -cabal clean && cabal install && rm -rf foobar && \ - runghc scaffold.hs init < input-sqlite && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar && \ - runghc scaffold.hs init < input-postgres && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar && \ - runghc scaffold.hs init < input-mini && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar diff --git a/input-mini b/input-mini deleted file mode 100644 index 61f2e8be..00000000 --- a/input-mini +++ /dev/null @@ -1,5 +0,0 @@ -Michael -foobar - -Foobar -m diff --git a/input-postgres b/input-postgres deleted file mode 100644 index 0bd04d5a..00000000 --- a/input-postgres +++ /dev/null @@ -1,5 +0,0 @@ -Michael -foobar - -Foobar -p diff --git a/input-sqlite b/input-sqlite deleted file mode 100644 index af3132a8..00000000 --- a/input-sqlite +++ /dev/null @@ -1,5 +0,0 @@ -Michael -foobar - -Foobar -s diff --git a/test.shelltest b/test.shelltest new file mode 100644 index 00000000..31bbf7a9 --- /dev/null +++ b/test.shelltest @@ -0,0 +1,36 @@ +# use shelltest +# note that the first cabal install line is its own test +# cabal install shelltestrunner +# shelltest test.shelltest + +cabal clean && cabal install + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. +<<< +Michael +foobar + +Foobar +s +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. +<<< +Michael +foobar + +Foobar +p +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 + +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. && rm -rf foobar +<<< +Michael +foobar + +Foobar +m +>>> /.*Registering foobar-0.0.0.*/ +>>>= 0 From 7452726d40c5faf052501a3ebd0373cf387a7f35 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Wed, 6 Jul 2011 20:14:30 -0700 Subject: [PATCH 604/624] add a Settings.yaml file for dynamic settings also command line to check for environment argument --- scaffold/Controller_hs.cg | 18 +++-- scaffold/Settings_hs.cg | 104 ++++++++++++++++--------- scaffold/Settings_yaml.cg | 16 ++++ scaffold/cabal.cg | 4 +- scaffold/mini-Controller_hs.cg | 8 +- scaffold/mini-cabal.cg | 2 + scaffold/mini-sitearg_hs.cg | 3 +- scaffold/sitearg_hs.cg | 13 ++-- scaffold/test_hs.cg | 47 +++++++++-- tests/runscaffold.sh | 6 ++ tests/sample-input.txt | 4 + test.shelltest => tests/test.shelltest | 0 12 files changed, 163 insertions(+), 62 deletions(-) create mode 100644 scaffold/Settings_yaml.cg create mode 100755 tests/runscaffold.sh create mode 100644 tests/sample-input.txt rename test.shelltest => tests/test.shelltest (100%) diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg index 324816ee..f6d8c961 100644 --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -35,14 +35,22 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod. -with~sitearg~ :: (Application -> IO a) -> IO a -with~sitearg~ f = Settings.withConnectionPool $ \p -> do +with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a +with~sitearg~ conf f = do + Settings.withConnectionPool conf $ \p -> do runConnectionPool (runMigration migrateAll) p - let h = ~sitearg~ s p + let h = ~sitearg~ conf s p toWaiApp h >>= f where - s = static Settings.staticdir + s = static Settings.staticDir + +with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a +with~sitearg~LoadConfig env f = do + conf <- Settings.loadConfig Settings.Development + withFoobar conf f + withDevelApp :: Dynamic -withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ()) +withDevelApp = do + toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ()) diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index d4d35ac0..a84c3c9d 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -16,9 +16,11 @@ module Settings , ConnectionPool , withConnectionPool , runConnectionPool - , approot - , staticroot - , staticdir + , staticRoot + , staticDir + , loadConfig + , AppEnvironment(..) + , AppConfig(..) ) where import qualified Text.Hamlet as H @@ -31,26 +33,67 @@ import Yesod (MonadControlIO, addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) import Data.Text (Text) +import Data.Object +import Data.Object.Yaml +import Control.Monad (join) --- | The base URL for your application. This will usually be different for --- development and production. Yesod automatically constructs URLs for you, --- so this value must be accurate to create valid links. --- Please note that there is no trailing slash. -approot :: Text -approot = -#ifdef PRODUCTION --- You probably want to change this. If your domain name was "yesod.com", --- you would probably want it to be: --- > "http://yesod.com" - "http://localhost:3000" -#else - "http://localhost:3000" -#endif +data AppEnvironment = Test + | Development + | Staging + | Production + deriving (Eq, Show, Read, Enum, Bounded) + +-- | dynamic per-environment configuration loaded from a YAML file +-- use this to avoid the need to re-compile between staging and production environments +data AppConfig = AppConfig { + appEnv :: AppEnvironment + + , appPort :: Int + + -- | Your application will keep a connection pool and take connections from + -- there as necessary instead of continually creating new connections. This + -- value gives the maximum number of connections to be open at a given time. + -- If your application requests a connection when all connections are in + -- use, that request will fail. Try to choose a number that will work well + -- with the system resources available to you while providing enough + -- connections for your expected load. + -- + -- Connections are returned to the pool as quickly as possible by + -- Yesod to avoid resource exhaustion. A connection is only considered in + -- use while within a call to runDB. + , connectionPoolSize :: Int + + -- | The base URL for your application. This will usually be different for + -- development and production. Yesod automatically constructs URLs for you, + -- so this value must be accurate to create valid links. + -- Please note that there is no trailing slash. + -- + -- You probably want to change this! If your domain name was "yesod.com", + -- you would probably want it to be: + -- > "http://yesod.com" + , appRoot :: Text +} + +loadConfig :: AppEnvironment -> IO AppConfig +loadConfig env = do + allSettings <- (join $ decodeFile ("Settings.yaml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + appPortS <- lookupScalar "appPort" settings + appRootS <- lookupScalar "appRoot" settings + connectionPoolSizeS <- lookupScalar "connectionPoolSize" settings + return $ AppConfig { + appEnv = env + , appPort = read $ appPortS + , appRoot = read $ appRootS + , connectionPoolSize = read $ connectionPoolSizeS + } + +-- Static setting below. Changing these requires a recompile -- | The location of static files on your system. This is a file system -- path. The default value works properly with your scaffolded site. -staticdir :: FilePath -staticdir = "static" +staticDir :: FilePath +staticDir = "static" -- | The base URL for your static files. As you can see by the default -- value, this can simply be "static" appended to your application root. @@ -65,8 +108,9 @@ staticdir = "static" -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in ~sitearg~.hs -staticroot :: Text -staticroot = approot `mappend` "/static" +staticRoot :: AppConfig -> Text +staticRoot conf = (appRoot conf) `mappend` "/static" + -- | The database connection string. The meaning of this string is backend- -- specific. @@ -78,20 +122,6 @@ connStr = "~connstr1~" #endif --- | Your application will keep a connection pool and take connections from --- there as necessary instead of continually creating new connections. This --- value gives the maximum number of connections to be open at a given time. --- If your application requests a connection when all connections are in --- use, that request will fail. Try to choose a number that will work well --- with the system resources available to you while providing enough --- connections for your expected load. --- --- Also, connections are returned to the pool as quickly as possible by --- Yesod to avoid resource exhaustion. A connection is only considered in --- use while within a call to runDB. -connectionCount :: Int -connectionCount = 10 - -- The rest of this file contains settings which rarely need changing by a -- user. @@ -155,8 +185,8 @@ widgetFile x = do -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself. -withConnectionPool :: MonadControlIO m => (ConnectionPool -> m a) -> m a -withConnectionPool = with~upper~Pool connStr connectionCount +withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a +withConnectionPool conf = with~upper~Pool connStr (connectionPoolSize conf) runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/scaffold/Settings_yaml.cg b/scaffold/Settings_yaml.cg new file mode 100644 index 00000000..314b7bce --- /dev/null +++ b/scaffold/Settings_yaml.cg @@ -0,0 +1,16 @@ +Default: &default + appRoot: http://localhost + appPort: 3000 + connectionPoolLimit: 10 + +Development: + <<: *defaults + +Test: + <<: *defaults + +Staging: + <<: *defaults + +Production: + <<: *defaults diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index 84d0e91f..fce1f917 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -62,6 +62,8 @@ executable ~project~ , hamlet , hjsmin , transformers + , data-object + , data-object-yaml , warp , blaze-builder - + , cmdargs diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini-Controller_hs.cg index 36999c82..c4947ee9 100644 --- a/scaffold/mini-Controller_hs.cg +++ b/scaffold/mini-Controller_hs.cg @@ -34,13 +34,13 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod. -with~sitearg~ :: (Application -> IO a) -> IO a -with~sitearg~ f = do - let h = ~sitearg~ s +with~sitearg~ :: AppEnvironment -> (Application -> IO a) -> IO a +with~sitearg~ appEnv f = do + let h = ~sitearg~ appEnv s toWaiApp h >>= f where s = static Settings.staticdir withDevelApp :: Dynamic -withDevelApp = toDyn (with~sitearg~ :: (Application -> IO ()) -> IO ()) +withDevelApp = toDyn (with~sitearg~ Development :: (Application -> IO ()) -> IO ()) diff --git a/scaffold/mini-cabal.cg b/scaffold/mini-cabal.cg index 7e69d651..09793f79 100644 --- a/scaffold/mini-cabal.cg +++ b/scaffold/mini-cabal.cg @@ -55,6 +55,8 @@ executable ~project~ , template-haskell , hamlet , transformers + , data-object + , data-object-yaml , wai , warp , blaze-builder diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini-sitearg_hs.cg index 2d94cc5d..aee7f6d1 100644 --- a/scaffold/mini-sitearg_hs.cg +++ b/scaffold/mini-sitearg_hs.cg @@ -30,7 +30,8 @@ import qualified Data.Text as T -- starts running, such as database connections. Every handler will have -- access to the data present here. data ~sitearg~ = ~sitearg~ - { getStatic :: Static -- ^ Settings for static file serving. + { appEnv :: Settings.AppEnvironment + , getStatic :: Static -- ^ Settings for static file serving. } -- | A useful synonym; most of the handler functions in your application diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg index a80a3acb..a39a6f71 100644 --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -40,7 +40,8 @@ import qualified Data.Text as T -- starts running, such as database connections. Every handler will have -- access to the data present here. data ~sitearg~ = ~sitearg~ - { getStatic :: Static -- ^ Settings for static file serving. + { settings :: Settings.AppConfig + , getStatic :: Static -- ^ Settings for static file serving. , connPool :: Settings.ConnectionPool -- ^ Database connection pool. } @@ -76,7 +77,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod ~sitearg~ where - approot _ = Settings.approot + approot = Settings.appRoot . settings defaultLayout widget = do mmsg <- getMessage @@ -86,9 +87,9 @@ instance Yesod ~sitearg~ where hamletToRepHtml $(Settings.hamletFile "default-layout") -- This is done to provide an optimization for serving static files from - -- a separate domain. Please see the staticroot setting in Settings.hs - urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + -- a separate domain. Please see the staticRoot setting in Settings.hs + urlRenderOverride y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. @@ -106,7 +107,7 @@ instance Yesod ~sitearg~ where Left _ -> content Right y -> y else content - let statictmp = Settings.staticdir ++ "/tmp/" + let statictmp = Settings.staticDir ++ "/tmp/" liftIO $ createDirectoryIfMissing True statictmp let fn' = statictmp ++ fn exists <- liftIO $ doesFileExist fn' diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index 35527958..a3028000 100644 --- a/scaffold/test_hs.cg +++ b/scaffold/test_hs.cg @@ -1,20 +1,51 @@ -{-# LANGUAGE CPP #-} -#if PRODUCTION +{-# LANGUAGE CPP, DeriveDataTypeable #-} +import qualified Settings as Settings import Controller (with~sitearg~) import Network.Wai.Handler.Warp (run) +import System.Console.CmdArgs +import Data.Char (toUpper, toLower) +#if PRODUCTION main :: IO () -main = with~sitearg~ $ run 3000 +main = do + appEnv <- getAppEnv + config <- Settings.loadConfig appEnv + with~sitearg~ config $ run (Settings.appPort settings) + #else -import Controller (with~sitearg~) import System.IO (hPutStrLn, stderr) import Network.Wai.Middleware.Debug (debug) -import Network.Wai.Handler.Warp (run) main :: IO () main = do - let port = 3000 - hPutStrLn stderr $ "Application launched, listening on port " ++ show port - with~sitearg~ $ run port . debug + appEnv <- getAppEnv + config <- Settings.loadConfig appEnv + hPutStrLn stderr $ "Application launched, listening on port " ++ show (Settings.appPort config) + with~sitearg~ config $ run (Settings.appPort config) . debug #endif +data ArgConfig = ArgConfig {environment :: String} + deriving (Show, Data, Typeable) + +config = ArgConfig{ environment = def + &= help "application environment, one of:" ++ (foldl1 (++) environments) + &= typ "ENVIRONMENT" +#if PRODUCTION + &= opt "production" +#else + &= opt "development" +#endif +} + +environments :: [String] +environments = map show ([minBound..maxBound] :: [Settings.AppEnvironment]) + + +-- | retrieve the -e environment option +getAppEnv :: IO Settings.AppEnvironment +getAppEnv = do + cfg <- cmdArgs config + return $ read $ capitalize $ environment cfg + where + capitalize [] = [] + capitalize (x:xs) = toUpper x : map toLower xs diff --git a/tests/runscaffold.sh b/tests/runscaffold.sh new file mode 100755 index 00000000..0c81955f --- /dev/null +++ b/tests/runscaffold.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +cd .. && +cabal clean && cabal install && +rm -rf foobar && runghc scaffold.hs init < sample-input.txt && cd foobar && cabal install && cabal install -fdevel && cd .. && +cd tests diff --git a/tests/sample-input.txt b/tests/sample-input.txt new file mode 100644 index 00000000..6b02a6e9 --- /dev/null +++ b/tests/sample-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +s diff --git a/test.shelltest b/tests/test.shelltest similarity index 100% rename from test.shelltest rename to tests/test.shelltest From 01dca42d4f519d5b337f64de147ba5e881caf732 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 8 Jul 2011 12:13:59 -0700 Subject: [PATCH 605/624] add Model and static/js directories --- scaffold.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/scaffold.hs b/scaffold.hs index 49f68ea2..210c0bd2 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -98,7 +98,9 @@ scaffold = do mkDir "julius" mkDir "static" mkDir "static/css" + mkDir "static/js" mkDir "config" + mkDir "Model" writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") From 942590a9e3a1726d7020ae3eea8ca83379ca8937 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sun, 10 Jul 2011 08:12:28 -0700 Subject: [PATCH 606/624] fix option parsing & settings --- scaffold.hs | 1 + scaffold/Settings_hs.cg | 4 ++-- scaffold/Settings_yaml.cg | 4 ++-- scaffold/test_hs.cg | 46 ++++++++++++++++++++++----------------- tests/runscaffold.sh | 4 +--- 5 files changed, 32 insertions(+), 27 deletions(-) diff --git a/scaffold.hs b/scaffold.hs index 49f68ea2..8e647aaa 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -100,6 +100,7 @@ scaffold = do mkDir "static/css" mkDir "config" + writeFile' ("config/Settings.yaml") $(codegen "Settings_yaml") writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' ".ghci" $(codegen "dotghci") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index a84c3c9d..e5624603 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -76,7 +76,7 @@ data AppConfig = AppConfig { loadConfig :: AppEnvironment -> IO AppConfig loadConfig env = do - allSettings <- (join $ decodeFile ("Settings.yaml" :: String)) >>= fromMapping + allSettings <- (join $ decodeFile ("config/Settings.yaml" :: String)) >>= fromMapping settings <- lookupMapping (show env) allSettings appPortS <- lookupScalar "appPort" settings appRootS <- lookupScalar "appRoot" settings @@ -84,7 +84,7 @@ loadConfig env = do return $ AppConfig { appEnv = env , appPort = read $ appPortS - , appRoot = read $ appRootS + , appRoot = read $ (show appRootS) , connectionPoolSize = read $ connectionPoolSizeS } diff --git a/scaffold/Settings_yaml.cg b/scaffold/Settings_yaml.cg index 314b7bce..38053042 100644 --- a/scaffold/Settings_yaml.cg +++ b/scaffold/Settings_yaml.cg @@ -1,7 +1,7 @@ -Default: &default +Default: &defaults appRoot: http://localhost appPort: 3000 - connectionPoolLimit: 10 + connectionPoolSize: 10 Development: <<: *defaults diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index a3028000..072be746 100644 --- a/scaffold/test_hs.cg +++ b/scaffold/test_hs.cg @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable #-} import qualified Settings as Settings +import Settings (AppConfig(..)) import Controller (with~sitearg~) import Network.Wai.Handler.Warp (run) import System.Console.CmdArgs @@ -8,44 +9,49 @@ import Data.Char (toUpper, toLower) #if PRODUCTION main :: IO () main = do - appEnv <- getAppEnv + args <- cmdArgs argConfig + appEnv <- getAppEnv args config <- Settings.loadConfig appEnv - with~sitearg~ config $ run (Settings.appPort settings) + let c = if (port args) /= 0 then config {appPort = (port args) } else config + with~sitearg~ c $ run (appPort c) #else + import System.IO (hPutStrLn, stderr) import Network.Wai.Middleware.Debug (debug) - main :: IO () main = do - appEnv <- getAppEnv + args <- cmdArgs argConfig + appEnv <- getAppEnv args config <- Settings.loadConfig appEnv - hPutStrLn stderr $ "Application launched, listening on port " ++ show (Settings.appPort config) - with~sitearg~ config $ run (Settings.appPort config) . debug + let c = if (port args) /= 0 then config {appPort = (port args) } else config + do hPutStrLn stderr $ "Application launched, listening on port " ++ show (appPort c) + with~sitearg~ c $ run (appPort c) . debug #endif -data ArgConfig = ArgConfig {environment :: String} +data ArgConfig = ArgConfig {environment :: String, port :: Int} deriving (Show, Data, Typeable) -config = ArgConfig{ environment = def - &= help "application environment, one of:" ++ (foldl1 (++) environments) +argConfig = ArgConfig{ environment = def + &= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments)) &= typ "ENVIRONMENT" -#if PRODUCTION - &= opt "production" -#else - &= opt "development" -#endif + ,port = def &= typ "PORT" } environments :: [String] -environments = map show ([minBound..maxBound] :: [Settings.AppEnvironment]) - +environments = map ((map toLower) . show) ([minBound..maxBound] :: [Settings.AppEnvironment]) -- | retrieve the -e environment option -getAppEnv :: IO Settings.AppEnvironment -getAppEnv = do - cfg <- cmdArgs config - return $ read $ capitalize $ environment cfg +getAppEnv :: ArgConfig -> IO Settings.AppEnvironment +getAppEnv cfg = do + let e = if (environment cfg) /= "" then (environment cfg) + else +#if PRODUCTION + "production" +#else + "development" +#endif + return $ read $ capitalize e where capitalize [] = [] capitalize (x:xs) = toUpper x : map toLower xs diff --git a/tests/runscaffold.sh b/tests/runscaffold.sh index 0c81955f..261dc7eb 100755 --- a/tests/runscaffold.sh +++ b/tests/runscaffold.sh @@ -1,6 +1,4 @@ #!/bin/sh -cd .. && cabal clean && cabal install && -rm -rf foobar && runghc scaffold.hs init < sample-input.txt && cd foobar && cabal install && cabal install -fdevel && cd .. && -cd tests + rm -rf foobar && runghc scaffold.hs init < tests/sample-input.txt && cd foobar && cabal install && cabal install -fdevel && cd .. From 0e36cd0e06fd8991370b5f2eb08e35b9e1d58ddb Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sun, 10 Jul 2011 08:42:09 -0700 Subject: [PATCH 607/624] more documentation --- scaffold/Settings_hs.cg | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index e5624603..ba44a3aa 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -43,8 +43,13 @@ data AppEnvironment = Test | Production deriving (Eq, Show, Read, Enum, Bounded) --- | dynamic per-environment configuration loaded from a YAML file --- use this to avoid the need to re-compile between staging and production environments +-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. +-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments). +-- +-- By convention these settings should be overwritten by any command line arguments. +-- See config/~sitearg~.hs for command line arguments +-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku). +-- data AppConfig = AppConfig { appEnv :: AppEnvironment @@ -72,7 +77,7 @@ data AppConfig = AppConfig { -- you would probably want it to be: -- > "http://yesod.com" , appRoot :: Text -} +} deriving (Show) loadConfig :: AppEnvironment -> IO AppConfig loadConfig env = do From 642a9bfde29e138ea7386fe8f486a8cd6769bdde Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Sun, 10 Jul 2011 08:49:01 -0700 Subject: [PATCH 608/624] show env in launching string --- scaffold/test_hs.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index 072be746..2e54d119 100644 --- a/scaffold/test_hs.cg +++ b/scaffold/test_hs.cg @@ -25,7 +25,7 @@ main = do appEnv <- getAppEnv args config <- Settings.loadConfig appEnv let c = if (port args) /= 0 then config {appPort = (port args) } else config - do hPutStrLn stderr $ "Application launched, listening on port " ++ show (appPort c) + do hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c) with~sitearg~ c $ run (appPort c) . debug #endif From 193b74b9aa64fad66a7501e318c2aa331f66f11d Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Mon, 11 Jul 2011 10:20:27 -0700 Subject: [PATCH 609/624] make database settings configurable --- development.md | 5 ++ scaffold.hs | 17 +++--- scaffold/Settings_hs.cg | 54 ++++++++++--------- scaffold/cabal.cg | 2 +- scaffold/pconn1.cg | 6 ++- scaffold/pconn2.cg | 1 - scaffold/postgresql_yml.cg | 21 ++++++++ .../{Settings_yaml.cg => settings_yml.cg} | 0 scaffold/sqlite_yml.cg | 17 ++++++ scaffold/test_hs.cg | 4 +- tests/{test.shelltest => scaffold.shelltest} | 0 11 files changed, 92 insertions(+), 35 deletions(-) create mode 100644 development.md delete mode 100644 scaffold/pconn2.cg create mode 100644 scaffold/postgresql_yml.cg rename scaffold/{Settings_yaml.cg => settings_yml.cg} (100%) create mode 100644 scaffold/sqlite_yml.cg rename tests/{test.shelltest => scaffold.shelltest} (100%) diff --git a/development.md b/development.md new file mode 100644 index 00000000..c9b5b7b8 --- /dev/null +++ b/development.md @@ -0,0 +1,5 @@ +# Scaffolding + +## Test suite + + shelltest test/scaffold.shelltest diff --git a/scaffold.hs b/scaffold.hs index 8e647aaa..fead50e9 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -73,12 +73,11 @@ scaffold = do puts $(codegen "database") backendS <- prompt $ flip elem ["s", "p", "m"] let pconn1 = $(codegen "pconn1") - let pconn2 = $(codegen "pconn2") - let (lower, upper, connstr1, connstr2, importDB) = + let (backendLower, upper, connstr, importDB) = case backendS of - "s" -> ("sqlite", "Sqlite", "debug.db3", "production.db3", "import Database.Persist.Sqlite\n") - "p" -> ("postgresql", "Postgresql", pconn1, pconn2, "import Database.Persist.Postgresql\n") - "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "FIXME connstr2", "") + "s" -> ("sqlite", "Sqlite", " return database", "import Database.Persist.Sqlite\n") + "p" -> ("postgresql", "Postgresql", pconn1, "import Database.Persist.Postgresql\n") + "m" -> ("FIXME lower", "FIXME upper", "FIXME connstr1", "") _ -> error $ "Invalid backend: " ++ backendS putStrLn "That's it! I'm creating your files now..." @@ -100,7 +99,13 @@ scaffold = do mkDir "static/css" mkDir "config" - writeFile' ("config/Settings.yaml") $(codegen "Settings_yaml") + case backendS of + "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("sqlite_yml")) + "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("postgresql_yml")) + "m" -> return () + _ -> error $ "Invalid backend: " ++ backendS + + writeFile' ("config/settings.yml") $(codegen "settings_yml") writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") writeFile' ".ghci" $(codegen "dotghci") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg index ba44a3aa..5641eeed 100644 --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -12,7 +12,6 @@ module Settings , juliusFile , luciusFile , widgetFile - , connStr , ConnectionPool , withConnectionPool , runConnectionPool @@ -29,12 +28,12 @@ import qualified Text.Julius as H import qualified Text.Lucius as H import Language.Haskell.TH.Syntax ~importDB~ -import Yesod (MonadControlIO, addWidget, addCassius, addJulius, addLucius) +import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) import Data.Text (Text) import Data.Object -import Data.Object.Yaml +import qualified Data.Object.Yaml as YAML import Control.Monad (join) data AppEnvironment = Test @@ -81,7 +80,7 @@ data AppConfig = AppConfig { loadConfig :: AppEnvironment -> IO AppConfig loadConfig env = do - allSettings <- (join $ decodeFile ("config/Settings.yaml" :: String)) >>= fromMapping + allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping settings <- lookupMapping (show env) allSettings appPortS <- lookupScalar "appPort" settings appRootS <- lookupScalar "appRoot" settings @@ -117,19 +116,36 @@ staticRoot :: AppConfig -> Text staticRoot conf = (appRoot conf) `mappend` "/static" --- | The database connection string. The meaning of this string is backend- --- specific. -connStr :: Text -connStr = -#ifdef PRODUCTION - "~connstr2~" -#else - "~connstr1~" -#endif - -- The rest of this file contains settings which rarely need changing by a -- user. +-- The next functions are for allocating a connection pool and running +-- database actions using a pool, respectively. It is used internally +-- by the scaffolded application, and therefore you will rarely need to use +-- them yourself. +runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool = runSqlPool + +-- | The database connection string. The meaning of this string is backend- +-- specific. +loadConnStr :: AppEnvironment -> IO Text +loadConnStr env = do + allSettings <- (join $ YAML.decodeFile ("config/~backendLower~.yml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + database <- lookupScalar "database" settings +~connstr~ + +withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a +withConnectionPool conf f = do + cs <- liftIO $ loadConnStr (appEnv conf) + with~upper~Pool cs (connectionPoolSize conf) f + +-- Example of making a dynamic configuration static +-- use /return $(mkConnStr Production)/ instead of loadConnStr +-- mkConnStr :: AppEnvironment -> Q Exp +-- mkConnStr env = qRunIO (loadConnStr env) >>= return . LitE . StringL + + -- The following three functions are used for calling HTML, CSS and -- Javascript templates from your Haskell code. During development, -- the "Debug" versions of these functions are used so that changes to @@ -185,13 +201,3 @@ widgetFile x = do unlessExists tofn f = do e <- qRunIO $ doesFileExist $ tofn x if e then f x else [|mempty|] - --- The next two functions are for allocating a connection pool and running --- database actions using a pool, respectively. It is used internally --- by the scaffolded application, and therefore you will rarely need to use --- them yourself. -withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a -withConnectionPool conf = with~upper~Pool connStr (connectionPoolSize conf) - -runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a -runConnectionPool = runSqlPool diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index fce1f917..b58eaf07 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -57,7 +57,7 @@ executable ~project~ , text , persistent , persistent-template - , persistent-~lower~ >= 0.5 && < 0.6 + , persistent-~backendLower~ >= 0.5 && < 0.6 , template-haskell , hamlet , hjsmin diff --git a/scaffold/pconn1.cg b/scaffold/pconn1.cg index 2fbf5964..ea8ef468 100644 --- a/scaffold/pconn1.cg +++ b/scaffold/pconn1.cg @@ -1 +1,5 @@ -user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_debug + user <- lookupScalar "user" + password <- lookupScalar "user" + host <- lookupScalar "host" + port <- lookupScalar "port" + return $ "user=" ++ user ++ "password=" ++ password ++ "host=" ++ host ++ "port=" ++ port ++ "dbname= ++ database" diff --git a/scaffold/pconn2.cg b/scaffold/pconn2.cg deleted file mode 100644 index 5dbfefe0..00000000 --- a/scaffold/pconn2.cg +++ /dev/null @@ -1 +0,0 @@ -user=~project~ password=~project~ host=localhost port=5432 dbname=~project~_production diff --git a/scaffold/postgresql_yml.cg b/scaffold/postgresql_yml.cg new file mode 100644 index 00000000..a9f18e51 --- /dev/null +++ b/scaffold/postgresql_yml.cg @@ -0,0 +1,21 @@ +Default: &defaults + adapter: postgres + user: ~project~ + password: ~project~ + host: localhost + port: 5432 + database: ~project~ + +Development: + <<: *defaults + +Test: + database: ~project~_test + <<: *defaults + +Staging: + <<: *defaults + +Production: + database: ~project~_production + <<: *defaults diff --git a/scaffold/Settings_yaml.cg b/scaffold/settings_yml.cg similarity index 100% rename from scaffold/Settings_yaml.cg rename to scaffold/settings_yml.cg diff --git a/scaffold/sqlite_yml.cg b/scaffold/sqlite_yml.cg new file mode 100644 index 00000000..1919d640 --- /dev/null +++ b/scaffold/sqlite_yml.cg @@ -0,0 +1,17 @@ +Default: &defaults + adapter: sqlite + database: ~project~.sqlite3 + +Development: + <<: *defaults + +Test: + database: ~project~_test.sqlite3 + <<: *defaults + +Staging: + <<: *defaults + +Production: + database: ~project~_production.sqlite3 + <<: *defaults diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg index 2e54d119..f27521f1 100644 --- a/scaffold/test_hs.cg +++ b/scaffold/test_hs.cg @@ -25,8 +25,8 @@ main = do appEnv <- getAppEnv args config <- Settings.loadConfig appEnv let c = if (port args) /= 0 then config {appPort = (port args) } else config - do hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c) - with~sitearg~ c $ run (appPort c) . debug + hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c) + with~sitearg~ c $ run (appPort c) . debug #endif data ArgConfig = ArgConfig {environment :: String, port :: Int} diff --git a/tests/test.shelltest b/tests/scaffold.shelltest similarity index 100% rename from tests/test.shelltest rename to tests/scaffold.shelltest From 9075a3a808607c7198b741975ed560361fb71209 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Mon, 11 Jul 2011 11:30:55 -0700 Subject: [PATCH 610/624] remove adapter --- scaffold/postgresql_yml.cg | 1 - scaffold/sqlite_yml.cg | 1 - 2 files changed, 2 deletions(-) diff --git a/scaffold/postgresql_yml.cg b/scaffold/postgresql_yml.cg index a9f18e51..28926dab 100644 --- a/scaffold/postgresql_yml.cg +++ b/scaffold/postgresql_yml.cg @@ -1,5 +1,4 @@ Default: &defaults - adapter: postgres user: ~project~ password: ~project~ host: localhost diff --git a/scaffold/sqlite_yml.cg b/scaffold/sqlite_yml.cg index 1919d640..ec25b88e 100644 --- a/scaffold/sqlite_yml.cg +++ b/scaffold/sqlite_yml.cg @@ -1,5 +1,4 @@ Default: &defaults - adapter: sqlite database: ~project~.sqlite3 Development: From a0a729161664497ff333ea0b948400a0f38a0337 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Tue, 12 Jul 2011 08:31:42 -0700 Subject: [PATCH 611/624] use directory structure --- CodeGen.hs | 11 ++-- {scaffold => input}/database.cg | 0 {scaffold => input}/dir-name.cg | 0 {scaffold => input}/project-name.cg | 0 {scaffold => input}/site-arg.cg | 0 {scaffold => input}/welcome.cg | 0 scaffold.hs | 52 +++++++++--------- scaffold/{dotghci.cg => .ghci.cg} | 0 .../{Controller_hs.cg => Controller.hs.cg} | 0 scaffold/{Root_hs.cg => Handler/Root.hs.cg} | 0 scaffold/{Model_hs.cg => Model.hs.cg} | 0 .../default-layout.cassius.cg} | 0 .../homepage.cassius.cg} | 0 .../{Settings_hs.cg => config/Settings.hs.cg} | 0 .../StaticFiles.hs.cg} | 0 .../{favicon_ico.cg => config/favicon.ico.cg} | Bin scaffold/{entities.cg => config/models.cg} | 0 .../postgresql.yml.cg} | 0 scaffold/{ => config}/routes.cg | 0 .../settings.yml.cg} | 0 .../{sqlite_yml.cg => config/sqlite.yml.cg} | 0 .../boilerplate-layout.hamlet.cg} | 0 .../default-layout.hamlet.cg} | 0 .../homepage.hamlet.cg} | 0 .../homepage.julius.cg} | 0 .../Controller.hs.cg} | 0 .../Handler/Root.hs.cg} | 0 scaffold/{mini-cabal.cg => mini/cabal.cg} | 0 .../config/Settings.hs.cg} | 0 .../{mini-routes.cg => mini/config/routes.cg} | 0 .../hamlet/homepage.hamlet.cg} | 0 .../sitearg.hs.cg} | 0 scaffold/{test_hs.cg => project.hs.cg} | 0 scaffold/{sitearg_hs.cg => sitearg.hs.cg} | 0 .../css/html5boilerplate.css.cg} | 0 35 files changed, 33 insertions(+), 30 deletions(-) rename {scaffold => input}/database.cg (100%) rename {scaffold => input}/dir-name.cg (100%) rename {scaffold => input}/project-name.cg (100%) rename {scaffold => input}/site-arg.cg (100%) rename {scaffold => input}/welcome.cg (100%) rename scaffold/{dotghci.cg => .ghci.cg} (100%) rename scaffold/{Controller_hs.cg => Controller.hs.cg} (100%) rename scaffold/{Root_hs.cg => Handler/Root.hs.cg} (100%) rename scaffold/{Model_hs.cg => Model.hs.cg} (100%) rename scaffold/{default-layout_cassius.cg => cassius/default-layout.cassius.cg} (100%) rename scaffold/{homepage_cassius.cg => cassius/homepage.cassius.cg} (100%) rename scaffold/{Settings_hs.cg => config/Settings.hs.cg} (100%) rename scaffold/{StaticFiles_hs.cg => config/StaticFiles.hs.cg} (100%) rename scaffold/{favicon_ico.cg => config/favicon.ico.cg} (100%) rename scaffold/{entities.cg => config/models.cg} (100%) rename scaffold/{postgresql_yml.cg => config/postgresql.yml.cg} (100%) rename scaffold/{ => config}/routes.cg (100%) rename scaffold/{settings_yml.cg => config/settings.yml.cg} (100%) rename scaffold/{sqlite_yml.cg => config/sqlite.yml.cg} (100%) rename scaffold/{boilerplate-layout_hamlet.cg => hamlet/boilerplate-layout.hamlet.cg} (100%) rename scaffold/{default-layout_hamlet.cg => hamlet/default-layout.hamlet.cg} (100%) rename scaffold/{homepage_hamlet.cg => hamlet/homepage.hamlet.cg} (100%) rename scaffold/{homepage_julius.cg => julius/homepage.julius.cg} (100%) rename scaffold/{mini-Controller_hs.cg => mini/Controller.hs.cg} (100%) rename scaffold/{mini-Root_hs.cg => mini/Handler/Root.hs.cg} (100%) rename scaffold/{mini-cabal.cg => mini/cabal.cg} (100%) rename scaffold/{mini-Settings_hs.cg => mini/config/Settings.hs.cg} (100%) rename scaffold/{mini-routes.cg => mini/config/routes.cg} (100%) rename scaffold/{mini-homepage_hamlet.cg => mini/hamlet/homepage.hamlet.cg} (100%) rename scaffold/{mini-sitearg_hs.cg => mini/sitearg.hs.cg} (100%) rename scaffold/{test_hs.cg => project.hs.cg} (100%) rename scaffold/{sitearg_hs.cg => sitearg.hs.cg} (100%) rename scaffold/{boilerplate_css.cg => static/css/html5boilerplate.css.cg} (100%) diff --git a/CodeGen.hs b/CodeGen.hs index 632c2a7c..878159ad 100644 --- a/CodeGen.hs +++ b/CodeGen.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} -- | A code generation template haskell. Everything is taken as literal text, -- with ~var~ variable interpolation. -module CodeGen (codegen) where +module CodeGen (codegen, codegenDir) where import Language.Haskell.TH.Syntax import Text.ParserCombinators.Parsec @@ -11,9 +11,9 @@ import qualified Data.Text.Lazy.Encoding as LT data Token = VarToken String | LitToken String | EmptyToken -codegen :: FilePath -> Q Exp -codegen fp = do - s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg" +codegenDir :: FilePath -> FilePath -> Q Exp +codegenDir dir fp = do + s' <- qRunIO $ L.readFile $ (dir ++ "/" ++ fp ++ ".cg") let s = init $ LT.unpack $ LT.decodeUtf8 s' case parse (many parseToken) s s of Left e -> error $ show e @@ -22,6 +22,9 @@ codegen fp = do concat' <- [|concat|] return $ concat' `AppE` ListE tokens'' +codegen :: FilePath -> Q Exp +codegen fp = codegenDir "scaffold" fp + toExp :: Token -> Exp toExp (LitToken s) = LitE $ StringL s toExp (VarToken s) = VarE $ mkName s diff --git a/scaffold/database.cg b/input/database.cg similarity index 100% rename from scaffold/database.cg rename to input/database.cg diff --git a/scaffold/dir-name.cg b/input/dir-name.cg similarity index 100% rename from scaffold/dir-name.cg rename to input/dir-name.cg diff --git a/scaffold/project-name.cg b/input/project-name.cg similarity index 100% rename from scaffold/project-name.cg rename to input/project-name.cg diff --git a/scaffold/site-arg.cg b/input/site-arg.cg similarity index 100% rename from scaffold/site-arg.cg rename to input/site-arg.cg diff --git a/scaffold/welcome.cg b/input/welcome.cg similarity index 100% rename from scaffold/welcome.cg rename to input/welcome.cg diff --git a/scaffold.hs b/scaffold.hs index fead50e9..42565b76 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -53,10 +53,10 @@ puts s = putStr s >> hFlush stdout scaffold :: IO () scaffold = do - puts $(codegen "welcome") + puts $(codegenDir "input" "welcome") name <- getLine - puts $(codegen "project-name") + puts $(codegenDir "input" "project-name") let validPN c | 'A' <= c && c <= 'Z' = True | 'a' <= c && c <= 'z' = True @@ -66,11 +66,11 @@ scaffold = do project <- prompt $ all validPN let dir = project - puts $(codegen "site-arg") + puts $(codegenDir "input" "site-arg") let isUpperAZ c = 'A' <= c && c <= 'Z' sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) && s /= "Main" - puts $(codegen "database") + puts $(codegenDir "input" "database") backendS <- prompt $ flip elem ["s", "p", "m"] let pconn1 = $(codegen "pconn1") let (backendLower, upper, connstr, importDB) = @@ -100,38 +100,38 @@ scaffold = do mkDir "config" case backendS of - "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("sqlite_yml")) - "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("postgresql_yml")) + "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml")) + "p" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/postgresql.yml")) "m" -> return () _ -> error $ "Invalid backend: " ++ backendS - writeFile' ("config/settings.yml") $(codegen "settings_yml") - writeFile' ("config/" ++ project ++ ".hs") $(codegen "test_hs") - writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini-cabal") else $(codegen "cabal") - writeFile' ".ghci" $(codegen "dotghci") + writeFile' ("config/settings.yml") $(codegen "config/settings.yml") + writeFile' ("config/" ++ project ++ ".hs") $(codegen "project.hs") + writeFile' (project ++ ".cabal") $ if backendS == "m" then $(codegen "mini/cabal") else $(codegen "cabal") + writeFile' ".ghci" $(codegen ".ghci") writeFile' "LICENSE" $(codegen "LICENSE") - writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini-sitearg_hs") else $(codegen "sitearg_hs") - writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini-Controller_hs") else $(codegen "Controller_hs") - writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini-Root_hs") else $(codegen "Root_hs") - when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model_hs") - writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini-Settings_hs") else $(codegen "Settings_hs") - writeFile' "config/StaticFiles.hs" $(codegen "StaticFiles_hs") + writeFile' (sitearg ++ ".hs") $ if backendS == "m" then $(codegen "mini/sitearg.hs") else $(codegen "sitearg.hs") + writeFile' "Controller.hs" $ if backendS == "m" then $(codegen "mini/Controller.hs") else $(codegen "Controller.hs") + writeFile' "Handler/Root.hs" $ if backendS == "m" then $(codegen "mini/Handler/Root.hs") else $(codegen "Handler/Root.hs") + when (backendS /= "m") $ writeFile' "Model.hs" $(codegen "Model.hs") + writeFile' "config/Settings.hs" $ if backendS == "m" then $(codegen "mini/config/Settings.hs") else $(codegen "config/Settings.hs") + writeFile' "config/StaticFiles.hs" $(codegen "config/StaticFiles.hs") writeFile' "cassius/default-layout.cassius" - $(codegen "default-layout_cassius") + $(codegen "cassius/default-layout.cassius") writeFile' "hamlet/default-layout.hamlet" - $(codegen "default-layout_hamlet") + $(codegen "hamlet/default-layout.hamlet") writeFile' "hamlet/boilerplate-layout.hamlet" - $(codegen "boilerplate-layout_hamlet") + $(codegen "hamlet/boilerplate-layout.hamlet") writeFile' "static/css/html5boilerplate.css" - $(codegen "boilerplate_css") - writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini-homepage_hamlet") else $(codegen "homepage_hamlet") - writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini-routes") else $(codegen "routes") - writeFile' "cassius/homepage.cassius" $(codegen "homepage_cassius") - writeFile' "julius/homepage.julius" $(codegen "homepage_julius") - unless (backendS == "m") $ writeFile' "config/models" $(codegen "entities") + $(codegen "static/css/html5boilerplate.css") + writeFile' "hamlet/homepage.hamlet" $ if backendS == "m" then $(codegen "mini/hamlet/homepage.hamlet") else $(codegen "hamlet/homepage.hamlet") + writeFile' "config/routes" $ if backendS == "m" then $(codegen "mini/config/routes") else $(codegen "config/routes") + writeFile' "cassius/homepage.cassius" $(codegen "cassius/homepage.cassius") + writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius") + unless (backendS == "m") $ writeFile' "config/models" $(codegen "config/models") S.writeFile (dir ++ "/config/favicon.ico") - $(runIO (S.readFile "scaffold/favicon_ico.cg") >>= \bs -> do + $(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do pack <- [|S.pack|] return $ pack `AppE` LitE (StringL $ S.unpack bs)) diff --git a/scaffold/dotghci.cg b/scaffold/.ghci.cg similarity index 100% rename from scaffold/dotghci.cg rename to scaffold/.ghci.cg diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller.hs.cg similarity index 100% rename from scaffold/Controller_hs.cg rename to scaffold/Controller.hs.cg diff --git a/scaffold/Root_hs.cg b/scaffold/Handler/Root.hs.cg similarity index 100% rename from scaffold/Root_hs.cg rename to scaffold/Handler/Root.hs.cg diff --git a/scaffold/Model_hs.cg b/scaffold/Model.hs.cg similarity index 100% rename from scaffold/Model_hs.cg rename to scaffold/Model.hs.cg diff --git a/scaffold/default-layout_cassius.cg b/scaffold/cassius/default-layout.cassius.cg similarity index 100% rename from scaffold/default-layout_cassius.cg rename to scaffold/cassius/default-layout.cassius.cg diff --git a/scaffold/homepage_cassius.cg b/scaffold/cassius/homepage.cassius.cg similarity index 100% rename from scaffold/homepage_cassius.cg rename to scaffold/cassius/homepage.cassius.cg diff --git a/scaffold/Settings_hs.cg b/scaffold/config/Settings.hs.cg similarity index 100% rename from scaffold/Settings_hs.cg rename to scaffold/config/Settings.hs.cg diff --git a/scaffold/StaticFiles_hs.cg b/scaffold/config/StaticFiles.hs.cg similarity index 100% rename from scaffold/StaticFiles_hs.cg rename to scaffold/config/StaticFiles.hs.cg diff --git a/scaffold/favicon_ico.cg b/scaffold/config/favicon.ico.cg similarity index 100% rename from scaffold/favicon_ico.cg rename to scaffold/config/favicon.ico.cg diff --git a/scaffold/entities.cg b/scaffold/config/models.cg similarity index 100% rename from scaffold/entities.cg rename to scaffold/config/models.cg diff --git a/scaffold/postgresql_yml.cg b/scaffold/config/postgresql.yml.cg similarity index 100% rename from scaffold/postgresql_yml.cg rename to scaffold/config/postgresql.yml.cg diff --git a/scaffold/routes.cg b/scaffold/config/routes.cg similarity index 100% rename from scaffold/routes.cg rename to scaffold/config/routes.cg diff --git a/scaffold/settings_yml.cg b/scaffold/config/settings.yml.cg similarity index 100% rename from scaffold/settings_yml.cg rename to scaffold/config/settings.yml.cg diff --git a/scaffold/sqlite_yml.cg b/scaffold/config/sqlite.yml.cg similarity index 100% rename from scaffold/sqlite_yml.cg rename to scaffold/config/sqlite.yml.cg diff --git a/scaffold/boilerplate-layout_hamlet.cg b/scaffold/hamlet/boilerplate-layout.hamlet.cg similarity index 100% rename from scaffold/boilerplate-layout_hamlet.cg rename to scaffold/hamlet/boilerplate-layout.hamlet.cg diff --git a/scaffold/default-layout_hamlet.cg b/scaffold/hamlet/default-layout.hamlet.cg similarity index 100% rename from scaffold/default-layout_hamlet.cg rename to scaffold/hamlet/default-layout.hamlet.cg diff --git a/scaffold/homepage_hamlet.cg b/scaffold/hamlet/homepage.hamlet.cg similarity index 100% rename from scaffold/homepage_hamlet.cg rename to scaffold/hamlet/homepage.hamlet.cg diff --git a/scaffold/homepage_julius.cg b/scaffold/julius/homepage.julius.cg similarity index 100% rename from scaffold/homepage_julius.cg rename to scaffold/julius/homepage.julius.cg diff --git a/scaffold/mini-Controller_hs.cg b/scaffold/mini/Controller.hs.cg similarity index 100% rename from scaffold/mini-Controller_hs.cg rename to scaffold/mini/Controller.hs.cg diff --git a/scaffold/mini-Root_hs.cg b/scaffold/mini/Handler/Root.hs.cg similarity index 100% rename from scaffold/mini-Root_hs.cg rename to scaffold/mini/Handler/Root.hs.cg diff --git a/scaffold/mini-cabal.cg b/scaffold/mini/cabal.cg similarity index 100% rename from scaffold/mini-cabal.cg rename to scaffold/mini/cabal.cg diff --git a/scaffold/mini-Settings_hs.cg b/scaffold/mini/config/Settings.hs.cg similarity index 100% rename from scaffold/mini-Settings_hs.cg rename to scaffold/mini/config/Settings.hs.cg diff --git a/scaffold/mini-routes.cg b/scaffold/mini/config/routes.cg similarity index 100% rename from scaffold/mini-routes.cg rename to scaffold/mini/config/routes.cg diff --git a/scaffold/mini-homepage_hamlet.cg b/scaffold/mini/hamlet/homepage.hamlet.cg similarity index 100% rename from scaffold/mini-homepage_hamlet.cg rename to scaffold/mini/hamlet/homepage.hamlet.cg diff --git a/scaffold/mini-sitearg_hs.cg b/scaffold/mini/sitearg.hs.cg similarity index 100% rename from scaffold/mini-sitearg_hs.cg rename to scaffold/mini/sitearg.hs.cg diff --git a/scaffold/test_hs.cg b/scaffold/project.hs.cg similarity index 100% rename from scaffold/test_hs.cg rename to scaffold/project.hs.cg diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg.hs.cg similarity index 100% rename from scaffold/sitearg_hs.cg rename to scaffold/sitearg.hs.cg diff --git a/scaffold/boilerplate_css.cg b/scaffold/static/css/html5boilerplate.css.cg similarity index 100% rename from scaffold/boilerplate_css.cg rename to scaffold/static/css/html5boilerplate.css.cg From 7fd7ba59ca64017c05cad8a81492773fa6c0c7be Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Tue, 12 Jul 2011 13:02:35 -0700 Subject: [PATCH 612/624] fix/improve scaffolding --- scaffold/Controller.hs.cg | 4 +- scaffold/Handler/Root.hs.cg | 2 +- scaffold/config/Settings.hs.cg | 3 +- scaffold/config/routes.cg | 1 - scaffold/mini/Controller.hs.cg | 16 +++-- scaffold/mini/Handler/Root.hs.cg | 2 +- scaffold/mini/cabal.cg | 3 + scaffold/mini/config/Settings.hs.cg | 72 ++++++++++++++------ scaffold/mini/sitearg.hs.cg | 10 +-- scaffold/pconn1.cg | 10 +-- scaffold/project.hs.cg | 14 ++-- tests/mini-input.txt | 4 ++ tests/postgresql-input.txt | 4 ++ tests/runscaffold.sh | 5 +- tests/{sample-input.txt => sqlite-input.txt} | 0 15 files changed, 97 insertions(+), 53 deletions(-) create mode 100644 tests/mini-input.txt create mode 100644 tests/postgresql-input.txt rename tests/{sample-input.txt => sqlite-input.txt} (100%) diff --git a/scaffold/Controller.hs.cg b/scaffold/Controller.hs.cg index f6d8c961..ff405232 100644 --- a/scaffold/Controller.hs.cg +++ b/scaffold/Controller.hs.cg @@ -46,10 +46,10 @@ with~sitearg~ conf f = do with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a with~sitearg~LoadConfig env f = do - conf <- Settings.loadConfig Settings.Development + conf <- Settings.loadConfig env withFoobar conf f - +-- for yesod devel withDevelApp :: Dynamic withDevelApp = do toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ()) diff --git a/scaffold/Handler/Root.hs.cg b/scaffold/Handler/Root.hs.cg index 418fde85..0ef7738d 100644 --- a/scaffold/Handler/Root.hs.cg +++ b/scaffold/Handler/Root.hs.cg @@ -2,6 +2,7 @@ module Handler.Root where import ~sitearg~ +import Data.Text -- This is a handler function for the GET request method on the RootR -- resource pattern. All of your resource patterns are defined in @@ -17,4 +18,3 @@ getRootR = do h2id <- lift newIdent setTitle "~project~ homepage" addWidget $(widgetFile "homepage") - diff --git a/scaffold/config/Settings.hs.cg b/scaffold/config/Settings.hs.cg index 5641eeed..956b0c5f 100644 --- a/scaffold/config/Settings.hs.cg +++ b/scaffold/config/Settings.hs.cg @@ -31,7 +31,8 @@ import Language.Haskell.TH.Syntax import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) -import Data.Text (Text) +import Prelude hiding (concat) +import Data.Text (Text, snoc, append, pack, concat) import Data.Object import qualified Data.Object.Yaml as YAML import Control.Monad (join) diff --git a/scaffold/config/routes.cg b/scaffold/config/routes.cg index 88b05c1c..7a0bb067 100644 --- a/scaffold/config/routes.cg +++ b/scaffold/config/routes.cg @@ -5,4 +5,3 @@ /robots.txt RobotsR GET / RootR GET - diff --git a/scaffold/mini/Controller.hs.cg b/scaffold/mini/Controller.hs.cg index c4947ee9..c895acd0 100644 --- a/scaffold/mini/Controller.hs.cg +++ b/scaffold/mini/Controller.hs.cg @@ -34,13 +34,19 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod. -with~sitearg~ :: AppEnvironment -> (Application -> IO a) -> IO a -with~sitearg~ appEnv f = do - let h = ~sitearg~ appEnv s +with~sitearg~ :: AppConfig -> (Application -> IO a) -> IO a +with~sitearg~ conf f = do + let h = ~sitearg~ conf s toWaiApp h >>= f where - s = static Settings.staticdir + s = static Settings.staticDir + +with~sitearg~LoadConfig :: Settings.AppEnvironment -> (Application -> IO a) -> IO a +with~sitearg~LoadConfig env f = do + conf <- Settings.loadConfig env + withFoobar conf f withDevelApp :: Dynamic -withDevelApp = toDyn (with~sitearg~ Development :: (Application -> IO ()) -> IO ()) +withDevelApp = do + toDyn ((with~sitearg~LoadConfig Settings.Development):: (Application -> IO ()) -> IO ()) diff --git a/scaffold/mini/Handler/Root.hs.cg b/scaffold/mini/Handler/Root.hs.cg index cf292a14..53b7a397 100644 --- a/scaffold/mini/Handler/Root.hs.cg +++ b/scaffold/mini/Handler/Root.hs.cg @@ -5,7 +5,7 @@ import ~sitearg~ -- This is a handler function for the GET request method on the RootR -- resource pattern. All of your resource patterns are defined in --- ~sitearg~.hs; look for the line beginning with mkYesodData. +-- config/routes -- -- The majority of the code you will write in Yesod lives in these handler -- functions. You can spread them across multiple files if you are so diff --git a/scaffold/mini/cabal.cg b/scaffold/mini/cabal.cg index 09793f79..4f570c2d 100644 --- a/scaffold/mini/cabal.cg +++ b/scaffold/mini/cabal.cg @@ -60,5 +60,8 @@ executable ~project~ , wai , warp , blaze-builder + , cmdargs + , data-object + , data-object-yaml ghc-options: -Wall -threaded diff --git a/scaffold/mini/config/Settings.hs.cg b/scaffold/mini/config/Settings.hs.cg index b48fe2e5..10d4ef28 100644 --- a/scaffold/mini/config/Settings.hs.cg +++ b/scaffold/mini/config/Settings.hs.cg @@ -12,9 +12,11 @@ module Settings , juliusFile , luciusFile , widgetFile - , approot - , staticroot - , staticdir + , staticRoot + , staticDir + , loadConfig + , AppEnvironment(..) + , AppConfig(..) ) where import qualified Text.Hamlet as H @@ -26,25 +28,55 @@ import Yesod.Widget (addWidget, addCassius, addJulius, addLucius) import Data.Monoid (mempty, mappend) import System.Directory (doesFileExist) import Data.Text (Text) +import Data.Object +import qualified Data.Object.Yaml as YAML +import Control.Monad (join) --- | The base URL for your application. This will usually be different for --- development and production. Yesod automatically constructs URLs for you, --- so this value must be accurate to create valid links. -approot :: Text -#ifdef PRODUCTION --- You probably want to change this. If your domain name was "yesod.com", --- you would probably want it to be: --- > approot = "http://www.yesod.com" --- Please note that there is no trailing slash. -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif +data AppEnvironment = Test + | Development + | Staging + | Production + deriving (Eq, Show, Read, Enum, Bounded) + +-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml. +-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments). +-- +-- By convention these settings should be overwritten by any command line arguments. +-- See config/~sitearg~.hs for command line arguments +-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku). +-- +data AppConfig = AppConfig { + appEnv :: AppEnvironment + + , appPort :: Int + + -- | The base URL for your application. This will usually be different for + -- development and production. Yesod automatically constructs URLs for you, + -- so this value must be accurate to create valid links. + -- Please note that there is no trailing slash. + -- + -- You probably want to change this! If your domain name was "yesod.com", + -- you would probably want it to be: + -- > "http://yesod.com" + , appRoot :: Text +} deriving (Show) + +loadConfig :: AppEnvironment -> IO AppConfig +loadConfig env = do + allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping + settings <- lookupMapping (show env) allSettings + appPortS <- lookupScalar "appPort" settings + appRootS <- lookupScalar "appRoot" settings + return $ AppConfig { + appEnv = env + , appPort = read $ appPortS + , appRoot = read $ (show appRootS) + } -- | The location of static files on your system. This is a file system -- path. The default value works properly with your scaffolded site. -staticdir :: FilePath -staticdir = "static" +staticDir :: FilePath +staticDir = "static" -- | The base URL for your static files. As you can see by the default -- value, this can simply be "static" appended to your application root. @@ -59,8 +91,8 @@ staticdir = "static" -- have to make a corresponding change here. -- -- To see how this value is used, see urlRenderOverride in ~project~.hs -staticroot :: Text -staticroot = approot `mappend` "/static" +staticRoot :: AppConfig -> Text +staticRoot conf = (appRoot conf) `mappend` "/static" -- The rest of this file contains settings which rarely need changing by a -- user. diff --git a/scaffold/mini/sitearg.hs.cg b/scaffold/mini/sitearg.hs.cg index aee7f6d1..758d4d65 100644 --- a/scaffold/mini/sitearg.hs.cg +++ b/scaffold/mini/sitearg.hs.cg @@ -30,7 +30,7 @@ import qualified Data.Text as T -- starts running, such as database connections. Every handler will have -- access to the data present here. data ~sitearg~ = ~sitearg~ - { appEnv :: Settings.AppEnvironment + { settings :: Settings.AppConfig , getStatic :: Static -- ^ Settings for static file serving. } @@ -66,7 +66,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod ~sitearg~ where - approot _ = Settings.approot + approot = Settings.appRoot . settings defaultLayout widget = do mmsg <- getMessage @@ -77,8 +77,8 @@ instance Yesod ~sitearg~ where -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs - urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s + urlRenderOverride y (StaticR s) = + Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s urlRenderOverride _ _ = Nothing -- This function creates static content files in the static folder @@ -87,7 +87,7 @@ instance Yesod ~sitearg~ where -- users receiving stale content. addStaticContent ext' _ content = do let fn = base64md5 content ++ '.' : T.unpack ext' - let statictmp = Settings.staticdir ++ "/tmp/" + let statictmp = Settings.staticDir ++ "/tmp/" liftIO $ createDirectoryIfMissing True statictmp let fn' = statictmp ++ fn exists <- liftIO $ doesFileExist fn' diff --git a/scaffold/pconn1.cg b/scaffold/pconn1.cg index ea8ef468..370aa79d 100644 --- a/scaffold/pconn1.cg +++ b/scaffold/pconn1.cg @@ -1,5 +1,5 @@ - user <- lookupScalar "user" - password <- lookupScalar "user" - host <- lookupScalar "host" - port <- lookupScalar "port" - return $ "user=" ++ user ++ "password=" ++ password ++ "host=" ++ host ++ "port=" ++ port ++ "dbname= ++ database" + connPart <- fmap concat $ (flip mapM) ["user", "password", "host", "port"] $ \key -> do + value <- lookupScalar key settings + return $ append (snoc (pack key) '=') (snoc value ' ') + return $ append connPart (append " dbname= " database) + diff --git a/scaffold/project.hs.cg b/scaffold/project.hs.cg index f27521f1..55f9374b 100644 --- a/scaffold/project.hs.cg +++ b/scaffold/project.hs.cg @@ -7,24 +7,20 @@ import System.Console.CmdArgs import Data.Char (toUpper, toLower) #if PRODUCTION -main :: IO () -main = do - args <- cmdArgs argConfig - appEnv <- getAppEnv args - config <- Settings.loadConfig appEnv - let c = if (port args) /= 0 then config {appPort = (port args) } else config - with~sitearg~ c $ run (appPort c) - #else - import System.IO (hPutStrLn, stderr) import Network.Wai.Middleware.Debug (debug) +#endif + main :: IO () main = do args <- cmdArgs argConfig appEnv <- getAppEnv args config <- Settings.loadConfig appEnv let c = if (port args) /= 0 then config {appPort = (port args) } else config +#if PRODUCTION + with~sitearg~ c $ run (appPort c) +#else hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c) with~sitearg~ c $ run (appPort c) . debug #endif diff --git a/tests/mini-input.txt b/tests/mini-input.txt new file mode 100644 index 00000000..079224e8 --- /dev/null +++ b/tests/mini-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +m diff --git a/tests/postgresql-input.txt b/tests/postgresql-input.txt new file mode 100644 index 00000000..ad38e160 --- /dev/null +++ b/tests/postgresql-input.txt @@ -0,0 +1,4 @@ +Michael +foobar +Foobar +p diff --git a/tests/runscaffold.sh b/tests/runscaffold.sh index 261dc7eb..6ec79864 100755 --- a/tests/runscaffold.sh +++ b/tests/runscaffold.sh @@ -1,4 +1,3 @@ -#!/bin/sh +#!/bin/bash -x -cabal clean && cabal install && - rm -rf foobar && runghc scaffold.hs init < tests/sample-input.txt && cd foobar && cabal install && cabal install -fdevel && cd .. + rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. diff --git a/tests/sample-input.txt b/tests/sqlite-input.txt similarity index 100% rename from tests/sample-input.txt rename to tests/sqlite-input.txt From a44d1d8ab03e29718408dee737ff1d4213f4ef2a Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Tue, 12 Jul 2011 22:12:43 -0700 Subject: [PATCH 613/624] fix compiler warnings --- development.md | 6 +++++- scaffold/Handler/Root.hs.cg | 1 - scaffold/project.hs.cg | 8 ++++---- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/development.md b/development.md index c9b5b7b8..79f91ede 100644 --- a/development.md +++ b/development.md @@ -2,4 +2,8 @@ ## Test suite - shelltest test/scaffold.shelltest + shelltest tests/scaffold.shelltest + +## Automated builder + + tests/runscaffold.sh < sqlite-input.txt diff --git a/scaffold/Handler/Root.hs.cg b/scaffold/Handler/Root.hs.cg index 0ef7738d..cb0375e7 100644 --- a/scaffold/Handler/Root.hs.cg +++ b/scaffold/Handler/Root.hs.cg @@ -2,7 +2,6 @@ module Handler.Root where import ~sitearg~ -import Data.Text -- This is a handler function for the GET request method on the RootR -- resource pattern. All of your resource patterns are defined in diff --git a/scaffold/project.hs.cg b/scaffold/project.hs.cg index 55f9374b..a7c76af1 100644 --- a/scaffold/project.hs.cg +++ b/scaffold/project.hs.cg @@ -3,7 +3,7 @@ import qualified Settings as Settings import Settings (AppConfig(..)) import Controller (with~sitearg~) import Network.Wai.Handler.Warp (run) -import System.Console.CmdArgs +import System.Console.CmdArgs hiding (args) import Data.Char (toUpper, toLower) #if PRODUCTION @@ -15,13 +15,13 @@ import Network.Wai.Middleware.Debug (debug) main :: IO () main = do args <- cmdArgs argConfig - appEnv <- getAppEnv args - config <- Settings.loadConfig appEnv + env <- getAppEnv args + config <- Settings.loadConfig env let c = if (port args) /= 0 then config {appPort = (port args) } else config #if PRODUCTION with~sitearg~ c $ run (appPort c) #else - hPutStrLn stderr $ (show appEnv) ++ " application launched, listening on port " ++ show (appPort c) + hPutStrLn stderr $ (show env) ++ " application launched, listening on port " ++ show (appPort c) with~sitearg~ c $ run (appPort c) . debug #endif From b7f567e8c0633e8096973e674b225a63025c5771 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Tue, 12 Jul 2011 22:23:33 -0700 Subject: [PATCH 614/624] include all config files --- development.md | 4 ++++ yesod.cabal | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 37 insertions(+), 1 deletion(-) diff --git a/development.md b/development.md index 79f91ede..8a3c4d6b 100644 --- a/development.md +++ b/development.md @@ -7,3 +7,7 @@ ## Automated builder tests/runscaffold.sh < sqlite-input.txt + +## Getting a list of scaffold files for the cabal file + + find scaffold -type f diff --git a/yesod.cabal b/yesod.cabal index bb964045..287f6d18 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -14,7 +14,39 @@ stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/ -extra-source-files: scaffold/*.cg + +extra-source-files: + scaffold/cassius/default-layout.cassius.cg, + scaffold/cassius/homepage.cassius.cg, + scaffold/Model.hs.cg scaffold/sitearg.hs.cg, + scaffold/LICENSE.cg, + scaffold/mini/sitearg.hs.cg, + scaffold/mini/cabal.cg, + scaffold/mini/Controller.hs.cg, + scaffold/mini/hamlet/homepage.hamlet.cg, + scaffold/mini/Handler/Root.hs.cg, + scaffold/mini/config/routes.cg, + scaffold/mini/config/Settings.hs.cg, + scaffold/static/css/html5boilerplate.css.cg, + scaffold/pconn1.cg, + scaffold/.ghci.cg, + scaffold/cabal.cg, + scaffold/Controller.hs.cg, + scaffold/julius/homepage.julius.cg, + scaffold/hamlet/homepage.hamlet.cg, + scaffold/hamlet/default-layout.hamlet.cg, + scaffold/hamlet/boilerplate-layout.hamlet.cg, + scaffold/project.hs.cg, + scaffold/Handler/Root.hs.cg, + scaffold/config/models.cg, + scaffold/config/sqlite.yml.cg, + scaffold/config/settings.yml.cg, + scaffold/config/favicon.ico.cg, + scaffold/config/postgresql.yml.cg, + scaffold/config/routes.cg, + scaffold/config/Settings.hs.cg, + scaffold/config/StaticFiles.hs.cg + flag ghc7 From efc5c19e528e5da63213f1f142f60a3bc89c23bf Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Wed, 13 Jul 2011 09:49:30 -0700 Subject: [PATCH 615/624] test with an sdist --- development.md | 8 +++++++- tests/scaffold.shelltest | 14 +++++++++----- 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/development.md b/development.md index 8a3c4d6b..cd390502 100644 --- a/development.md +++ b/development.md @@ -2,12 +2,18 @@ ## Test suite +Run this from the project root directory. It will make sure each site type builds. It first does an sdist, which ensures we are testing what will be put on hackage. + shelltest tests/scaffold.shelltest -## Automated builder +## Quicker, repeatable site building + +Useful for debugging individual failures. tests/runscaffold.sh < sqlite-input.txt ## Getting a list of scaffold files for the cabal file +It is necessary after adding a scaffolding file to add it to the list of files in the cabal file. + find scaffold -type f diff --git a/tests/scaffold.shelltest b/tests/scaffold.shelltest index 31bbf7a9..16cd5be7 100644 --- a/tests/scaffold.shelltest +++ b/tests/scaffold.shelltest @@ -1,9 +1,13 @@ -# use shelltest -# note that the first cabal install line is its own test -# cabal install shelltestrunner -# shelltest test.shelltest +# This uses shelltest +# +# cabal install shelltestrunner +# shelltest tests/scaffold.shelltest +# +# note that the first 2 lines setup this test but will also be counted as 2 tests. -cabal clean && cabal install +cabal clean && cabal install && cabal sdist + +for f in $(ls -1rt dist/*.tar.gz | tail -1); do tar -xzvf $f && cd `basename $f .tar.gz`; done rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. <<< From 4d7519d2be87cf1b8a6967bd7d464b87a8e328ae Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Fri, 15 Jul 2011 08:59:04 +0300 Subject: [PATCH 616/624] client_session_key in config folder --- scaffold/mini/sitearg.hs.cg | 3 +++ scaffold/sitearg.hs.cg | 4 ++++ 2 files changed, 7 insertions(+) diff --git a/scaffold/mini/sitearg.hs.cg b/scaffold/mini/sitearg.hs.cg index 758d4d65..e7c59ee8 100644 --- a/scaffold/mini/sitearg.hs.cg +++ b/scaffold/mini/sitearg.hs.cg @@ -68,6 +68,9 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") instance Yesod ~sitearg~ where approot = Settings.appRoot . settings + -- Place the session key file in the config folder + encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + defaultLayout widget = do mmsg <- getMessage pc <- widgetToPageContent $ do diff --git a/scaffold/sitearg.hs.cg b/scaffold/sitearg.hs.cg index a39a6f71..0bd383dc 100644 --- a/scaffold/sitearg.hs.cg +++ b/scaffold/sitearg.hs.cg @@ -34,6 +34,7 @@ import qualified Data.Text.Lazy import qualified Data.Text.Lazy.Encoding import Text.Jasmine (minifym) import qualified Data.Text as T +import Web.ClientSession (getKey) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -79,6 +80,9 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes") instance Yesod ~sitearg~ where approot = Settings.appRoot . settings + -- Place the session key file in the config folder + encryptKey _ = fmap Just $ getKey "config/client_session_key.aes" + defaultLayout widget = do mmsg <- getMessage pc <- widgetToPageContent $ do From 040893a0d49ed7f0302fe6433fcadcc278c5d569 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 15 Jul 2011 07:25:56 -0700 Subject: [PATCH 617/624] add heroku Procfile dd Procfile --- scaffold.hs | 3 +++ scaffold/deploy/Procfile.cg | 47 +++++++++++++++++++++++++++++++++++++ yesod.cabal | 2 ++ 3 files changed, 52 insertions(+) create mode 100644 scaffold/deploy/Procfile.cg diff --git a/scaffold.hs b/scaffold.hs index 8d0fb6ab..c76fe7b7 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -100,6 +100,9 @@ scaffold = do mkDir "static/js" mkDir "config" mkDir "Model" + mkDir "deploy" + + writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") case backendS of "s" -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen ("config/sqlite.yml")) diff --git a/scaffold/deploy/Procfile.cg b/scaffold/deploy/Procfile.cg new file mode 100644 index 00000000..3f79f92c --- /dev/null +++ b/scaffold/deploy/Procfile.cg @@ -0,0 +1,47 @@ +# Simple and free deployment to Heroku. +# +# !! Warning: You must use a 64 bit machine to compile !! +# +# This could mean using a virtual machine. Give your VM as much memory as you can to speed up linking. +# +# Yesod setup: +# +# * Move this file out of the deploy directory and into your root directory +# +# mv deploy/Procfile ./ +# +# * Create an empty Gemfile and Gemfile.lock +# +# touch Gemfile && touch Gemfile.lock +# +# * TODO: code to read DATABASE_URL environment variable. +# +# import System.Environment +# main = do +# durl <- getEnv "DATABASE_URL" +# # parse env variable +# # pass settings to withConnectionPool instead of directly using loadConnStr +# +# Heroku setup: +# Find the Heroku guide. Roughly: +# +# * sign up for a heroku account and register your ssh key +# * create a new application on the *cedar* stack +# +# * make your Yesod project the git repository for that application +# * create a deploy branch +# +# git checkout -b deploy +# +# Repeat these steps to deploy: +# * add your web executable binary (referenced below) to the git repository +# +# git add ./dist/build/~project~/~project~ +# +# * push to Heroku +# +# git push heroku deploy:master + + +# Heroku configuration that runs your app +web: ./dist/build/~project~/~project~ -p $PORT diff --git a/yesod.cabal b/yesod.cabal index 287f6d18..b5171709 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -16,6 +16,7 @@ build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: + input/*.cg scaffold/cassius/default-layout.cassius.cg, scaffold/cassius/homepage.cassius.cg, scaffold/Model.hs.cg scaffold/sitearg.hs.cg, @@ -31,6 +32,7 @@ extra-source-files: scaffold/pconn1.cg, scaffold/.ghci.cg, scaffold/cabal.cg, + scaffold/deploy/Procfile.cg, scaffold/Controller.hs.cg, scaffold/julius/homepage.julius.cg, scaffold/hamlet/homepage.hamlet.cg, From 67fc2f8aa7f3707331a71df64deed2bd9246def1 Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 15 Jul 2011 08:03:25 -0700 Subject: [PATCH 618/624] fix tests- clientsession dependencies --- development.md | 2 ++ scaffold/cabal.cg | 1 + scaffold/mini/cabal.cg | 1 + scaffold/mini/sitearg.hs.cg | 1 + 4 files changed, 5 insertions(+) diff --git a/development.md b/development.md index cd390502..9568de23 100644 --- a/development.md +++ b/development.md @@ -6,6 +6,8 @@ Run this from the project root directory. It will make sure each site type build shelltest tests/scaffold.shelltest +Give it the --debug flag to see all output + ## Quicker, repeatable site building Useful for debugging individual failures. diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg index b58eaf07..67b8b7b2 100644 --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -51,6 +51,7 @@ executable ~project~ , yesod-auth >= 0.4 && < 0.5 , yesod-static >= 0.1 && < 0.2 , mime-mail + , clientsession , wai-extra , directory , bytestring diff --git a/scaffold/mini/cabal.cg b/scaffold/mini/cabal.cg index 4f570c2d..20d3381f 100644 --- a/scaffold/mini/cabal.cg +++ b/scaffold/mini/cabal.cg @@ -48,6 +48,7 @@ executable ~project~ build-depends: base >= 4 && < 5 , yesod-core >= 0.8 && < 0.9 , yesod-static + , clientsession , wai-extra , directory , bytestring diff --git a/scaffold/mini/sitearg.hs.cg b/scaffold/mini/sitearg.hs.cg index e7c59ee8..64763598 100644 --- a/scaffold/mini/sitearg.hs.cg +++ b/scaffold/mini/sitearg.hs.cg @@ -24,6 +24,7 @@ import Control.Monad (unless) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T +import Web.ClientSession (getKey) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application From ab30fdcfe6a45beee2f930c06820802dfeb65c9a Mon Sep 17 00:00:00 2001 From: Greg Weber <greg@gregweber.info> Date: Fri, 15 Jul 2011 08:41:07 -0700 Subject: [PATCH 619/624] add wrapper for shelltest --- development.md | 4 +++- tests/run.sh | 17 +++++++++++++++++ tests/runscaffold.sh | 2 +- tests/scaffold.shelltest | 11 +---------- 4 files changed, 22 insertions(+), 12 deletions(-) create mode 100755 tests/run.sh diff --git a/development.md b/development.md index 9568de23..531621ea 100644 --- a/development.md +++ b/development.md @@ -2,9 +2,11 @@ ## Test suite +install the shelltest package: cabal install shelltests + Run this from the project root directory. It will make sure each site type builds. It first does an sdist, which ensures we are testing what will be put on hackage. - shelltest tests/scaffold.shelltest + tests/run.sh Give it the --debug flag to see all output diff --git a/tests/run.sh b/tests/run.sh new file mode 100755 index 00000000..93536b6d --- /dev/null +++ b/tests/run.sh @@ -0,0 +1,17 @@ +#!/bin/bash -x +# +# A wrapper for the shelltest test. Passes along options to shelltest. +# +# cabal install shelltestrunner + +cabal clean && cabal install && cabal sdist + +# I am not that good at shell scripting +# this for loop only operates on 1 file (as per tail -1) +for f in $(ls -1rt dist/*.tar.gz | tail -1) +do + tar -xzvf $f && cd `basename $f .tar.gz` + shelltest ../tests/scaffold.shelltest $@ + cd .. + rm -r `basename $f .tar.gz` +done diff --git a/tests/runscaffold.sh b/tests/runscaffold.sh index 6ec79864..03b40ced 100755 --- a/tests/runscaffold.sh +++ b/tests/runscaffold.sh @@ -1,3 +1,3 @@ #!/bin/bash -x - rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. +rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. diff --git a/tests/scaffold.shelltest b/tests/scaffold.shelltest index 16cd5be7..a35a8554 100644 --- a/tests/scaffold.shelltest +++ b/tests/scaffold.shelltest @@ -1,13 +1,4 @@ -# This uses shelltest -# -# cabal install shelltestrunner -# shelltest tests/scaffold.shelltest -# -# note that the first 2 lines setup this test but will also be counted as 2 tests. - -cabal clean && cabal install && cabal sdist - -for f in $(ls -1rt dist/*.tar.gz | tail -1); do tar -xzvf $f && cd `basename $f .tar.gz`; done +# Important! run with tests/run.sh rm -rf foobar && runghc scaffold.hs init && cd foobar && cabal install && cabal install -fdevel && cd .. <<< From ea5182814390671dcfd36da20896eb80f48ceb1f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Jul 2011 20:54:16 +0300 Subject: [PATCH 620/624] Handling StaticFiles --- Scaffold/Build.hs | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index e479b6a0..be343486 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -25,7 +25,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes, FileStatus) import Data.Text (unpack) -import Control.Monad (filterM) +import Control.Monad (filterM, forM) import Control.Exception (SomeException, try) -- | Touch any files with altered dependencies but do not build @@ -110,7 +110,7 @@ findHaskellFiles path = do then return [y] else return [] -data TempType = Hamlet | Verbatim | Messages FilePath +data TempType = Hamlet | Verbatim | Messages FilePath | StaticFiles FilePath deriving Show determineHamletDeps :: FilePath -> IO [FilePath] @@ -119,12 +119,13 @@ determineHamletDeps x = do let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y case z of A.Fail{} -> return [] - A.Done _ r -> filterM doesFileExist $ concatMap go r + A.Done _ r -> mapM go r >>= filterM doesFileExist . concat where - go (Just (Hamlet, f)) = [f, "hamlet/" ++ f ++ ".hamlet"] - go (Just (Verbatim, f)) = [f] - go (Just (Messages f, _)) = [f] - go Nothing = [] + go (Just (Hamlet, f)) = return [f, "hamlet/" ++ f ++ ".hamlet"] + go (Just (Verbatim, f)) = return [f] + go (Just (Messages f, _)) = return [f] + go (Just (StaticFiles fp, _)) = getFolderContents fp + go Nothing = return [] parser = do ty <- (A.string "$(hamletFile " >> return Hamlet) <|> (A.string "$(ihamletFile " >> return Hamlet) @@ -144,8 +145,13 @@ determineHamletDeps x = do y <- A.many1 $ A.satisfy (/= '"') A.string "\"" return $ Messages $ concat [x, "/", y, ".msg"]) + <|> (do + A.string "\nstaticFiles \"" + x <- A.many1 $ A.satisfy (/= '"') + return $ StaticFiles x) case ty of Messages{} -> return $ Just (ty, "") + StaticFiles{} -> return $ Just (ty, "") _ -> do A.skipWhile isSpace _ <- A.char '"' @@ -154,3 +160,13 @@ determineHamletDeps x = do A.skipWhile isSpace _ <- A.char ')' return $ Just (ty, y) + +getFolderContents :: FilePath -> IO [FilePath] +getFolderContents fp = do + cs <- getDirectoryContents fp + let notHidden ('.':_) = False + notHidden _ = True + fmap concat $ forM (filter notHidden cs) $ \c -> do + let f = fp ++ '/' : c + isFile <- doesFileExist f + if isFile then return [f] else getFolderContents f From c9eaf846949a8b98fb7a329897139b27fda784af Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Jul 2011 21:04:26 +0300 Subject: [PATCH 621/624] configure and build, using command line --- Scaffold/Build.hs | 3 +-- Scaffold/Devel.hs | 6 ++++-- scaffold.hs | 19 +++++++++++++++---- 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index be343486..b38b3b56 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Scaffold.Build - ( build - , touch + ( touch , getDeps , touchDeps , findHaskellFiles diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index e6c50345..49879c84 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -43,8 +43,10 @@ swapApp i f = do I.readIORef i >>= killThread f >>= I.writeIORef i -devel :: IO () -devel = do +devel :: ([String] -> IO ()) -- ^ configure command + -> ([String] -> IO ()) -- ^ build command + -> IO () +devel conf build = do e <- doesFileExist "dist/devel-flag" when e $ removeFile "dist/devel-flag" listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef diff --git a/scaffold.hs b/scaffold.hs index c76fe7b7..24fff92b 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -13,9 +13,11 @@ import qualified Data.Text.Lazy.Encoding as LT import Control.Monad (when, unless) import System.Environment (getArgs) -import Scaffold.Build (build, touch) +import Scaffold.Build (touch) import Scaffold.Devel (devel) +import System.Process (rawSystem) + qq :: String #if __GLASGOW_HASKELL__ >= 700 qq = "" @@ -34,16 +36,25 @@ prompt f = do main :: IO () main = do - args <- getArgs + args' <- getArgs + let (isDev, args) = + case args' of + "--dev":rest -> (True, rest) + _ -> (False, args') + let cmd = if isDev then "cabal-dev" else "cabal" + let conf rest = rawSystem cmd ("configure":rest) >> return () + let build rest = rawSystem cmd ("build":rest) >> return () case args of ["init"] -> scaffold - ["build"] -> build + "build":rest -> touch >> build rest ["touch"] -> touch - ["devel"] -> devel + ["devel"] -> devel conf build + "configure":rest -> conf rest _ -> do putStrLn "Usage: yesod <command>" putStrLn "Available commands:" putStrLn " init Scaffold a new site" + putStrLn " configure Configure a project for building" putStrLn " build Build project (performs TH dependency analysis)" putStrLn " touch Touch any files with altered TH dependencies but do not build" putStrLn " devel Run project with the devel server" From 9adf931c67027f40adb0f661c1de442d6af762fe Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Jul 2011 21:06:49 +0300 Subject: [PATCH 622/624] Cleaned up Scaffold.Build --- Scaffold/Build.hs | 45 ++++++++++----------------------------------- 1 file changed, 10 insertions(+), 35 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index b38b3b56..ba778f9e 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -8,22 +8,16 @@ module Scaffold.Build -- FIXME there's a bug when getFileStatus applies to a file temporary deleted (e.g., Vim saving a file) -import qualified Distribution.Simple.Build as B import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import Data.List (isSuffixOf) -import Distribution.Simple.Setup (defaultBuildFlags) -import Distribution.Simple.Configure (getPersistBuildConfig) -import Distribution.Simple.LocalBuildInfo import qualified Data.Attoparsec.Text.Lazy as A import qualified Data.Text.Lazy.IO as TIO import Control.Applicative ((<|>)) import Data.Char (isSpace) -import Data.Maybe (mapMaybe) import Data.Monoid (mappend) import qualified Data.Map as Map import qualified Data.Set as Set -import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes, FileStatus) -import Data.Text (unpack) +import System.PosixCompat.Files (accessTime, modificationTime, getFileStatus, setFileTimes) import Control.Monad (filterM, forM) import Control.Exception (SomeException, try) @@ -35,25 +29,6 @@ touch = do let deps = fixDeps $ zip hss deps' touchDeps deps -build :: IO () -build = do - {- - cabal <- defaultPackageDesc normal - gpd <- readPackageDescription normal cabal - putStrLn $ showPackageDescription $ packageDescription gpd - -} - hss <- findHaskellFiles "." - deps' <- mapM determineHamletDeps hss - let deps = fixDeps $ zip hss deps' - touchDeps deps - - lbi <- getPersistBuildConfig "dist" - B.build - (localPkgDescr lbi) - lbi - defaultBuildFlags - [] - type Deps = Map.Map FilePath (Set.Set FilePath) getDeps :: IO Deps @@ -136,18 +111,18 @@ determineHamletDeps x = do <|> (A.string "$(persistFile " >> return Verbatim) <|> (A.string "$(parseRoutesFile " >> return Verbatim) <|> (do - A.string "\nmkMessage \"" + _ <- A.string "\nmkMessage \"" A.skipWhile (/= '"') - A.string "\" \"" - x <- A.many1 $ A.satisfy (/= '"') - A.string "\" \"" + _ <- A.string "\" \"" + x' <- A.many1 $ A.satisfy (/= '"') + _ <- A.string "\" \"" y <- A.many1 $ A.satisfy (/= '"') - A.string "\"" - return $ Messages $ concat [x, "/", y, ".msg"]) + _ <- A.string "\"" + return $ Messages $ concat [x', "/", y, ".msg"]) <|> (do - A.string "\nstaticFiles \"" - x <- A.many1 $ A.satisfy (/= '"') - return $ StaticFiles x) + _ <- A.string "\nstaticFiles \"" + x' <- A.many1 $ A.satisfy (/= '"') + return $ StaticFiles x') case ty of Messages{} -> return $ Just (ty, "") StaticFiles{} -> return $ Just (ty, "") From 2e90d0a6b7efb7f3b2370c14adcf5a2df2b8c26d Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Jul 2011 21:22:06 +0300 Subject: [PATCH 623/624] yesod devel uses command line --- Scaffold/Build.hs | 1 + Scaffold/Devel.hs | 37 ++++++++++++++++++++----------------- scaffold.hs | 7 ++++--- 3 files changed, 25 insertions(+), 20 deletions(-) diff --git a/Scaffold/Build.hs b/Scaffold/Build.hs index ba778f9e..64202dc4 100644 --- a/Scaffold/Build.hs +++ b/Scaffold/Build.hs @@ -139,6 +139,7 @@ getFolderContents :: FilePath -> IO [FilePath] getFolderContents fp = do cs <- getDirectoryContents fp let notHidden ('.':_) = False + notHidden "tmp" = False notHidden _ = True fmap concat $ forM (filter notHidden cs) $ \c -> do let f = fp ++ '/' : c diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index 49879c84..cd24854b 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -5,6 +5,7 @@ module Scaffold.Devel import qualified Distribution.Simple.Build as B import Distribution.Simple.Configure (configure) +import Distribution.Simple (defaultMainArgs) import Distribution.Simple.Setup (defaultConfigFlags, configConfigurationsFlags, configUserInstall, Flag (..), defaultBuildFlags, defaultCopyFlags, defaultRegisterFlags) import Distribution.Simple.Utils (defaultPackageDesc, defaultHookedPackageDesc) import Distribution.Simple.Program (defaultProgramConfiguration) @@ -30,8 +31,9 @@ import Control.Monad (when, forever) import System.Process (runCommand, terminateProcess, getProcessExitCode, waitForProcess) import qualified Data.IORef as I import qualified Data.ByteString.Lazy.Char8 as L -import System.Directory (doesFileExist, removeFile) +import System.Directory (doesFileExist, removeFile, getDirectoryContents) import Distribution.Package (PackageName (..), pkgName) +import Data.Maybe (mapMaybe) appMessage :: L.ByteString -> IO () appMessage l = forever $ do @@ -43,10 +45,9 @@ swapApp i f = do I.readIORef i >>= killThread f >>= I.writeIORef i -devel :: ([String] -> IO ()) -- ^ configure command - -> ([String] -> IO ()) -- ^ build command +devel :: ([String] -> IO ()) -- ^ cabal -> IO () -devel conf build = do +devel cabalCmd = do e <- doesFileExist "dist/devel-flag" when e $ removeFile "dist/devel-flag" listenThread <- forkIO (appMessage "Initializing, please wait") >>= I.newIORef @@ -60,10 +61,7 @@ devel conf build = do Nothing -> return emptyHookedBuildInfo Just fp -> readHookedBuildInfo normal fp - lbi <- configure (gpd, hooked) (defaultConfigFlags defaultProgramConfiguration) - { configConfigurationsFlags = [(FlagName "devel", True)] - , configUserInstall = Flag True - } + cabalCmd ["configure", "-fdevel"] let myTry :: IO () -> IO () myTry f = try f >>= \x -> case x of @@ -77,16 +75,10 @@ devel conf build = do deps <- getDeps touchDeps deps - B.build - (localPkgDescr lbi) - lbi - defaultBuildFlags - [] + cabalCmd ["build"] + defaultMainArgs ["install"] - install (localPkgDescr lbi) lbi defaultCopyFlags - register (localPkgDescr lbi) lbi defaultRegisterFlags - - let PackageName pi' = pkgName $ package $ localPkgDescr lbi + pi' <- getPackageName writeFile "dist/devel.hs" $ unlines [ "{-# LANGUAGE PackageImports #-}" , concat @@ -152,3 +144,14 @@ loop oldList getNewApp = do errApp :: String -> Application errApp s _ = return $ ResponseBuilder status500 [("Content-Type", "text/plain")] $ fromString s + +getPackageName :: IO String +getPackageName = do + xs <- getDirectoryContents "." + case mapMaybe (toCabal . reverse) xs of + [x] -> return x + [] -> error "No cabal files found" + _ -> error "Too many cabal files found" + where + toCabal ('l':'a':'b':'a':'c':'.':x) = Just $ reverse x + toCabal _ = Nothing diff --git a/scaffold.hs b/scaffold.hs index 24fff92b..23a1f1c1 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -42,13 +42,14 @@ main = do "--dev":rest -> (True, rest) _ -> (False, args') let cmd = if isDev then "cabal-dev" else "cabal" - let conf rest = rawSystem cmd ("configure":rest) >> return () - let build rest = rawSystem cmd ("build":rest) >> return () + let cabal rest = rawSystem cmd rest >> return () + let conf rest = cabal $ "configure":rest + let build rest = cabal $ "build":rest case args of ["init"] -> scaffold "build":rest -> touch >> build rest ["touch"] -> touch - ["devel"] -> devel conf build + ["devel"] -> devel cabal "configure":rest -> conf rest _ -> do putStrLn "Usage: yesod <command>" From 45bbb0fc93db341ecac1406234fe0e880d63ed12 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 17 Jul 2011 21:26:16 +0300 Subject: [PATCH 624/624] Disabled appMessage server; not as pretty, but actually works --- Scaffold/Devel.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Scaffold/Devel.hs b/Scaffold/Devel.hs index cd24854b..ebd82a04 100644 --- a/Scaffold/Devel.hs +++ b/Scaffold/Devel.hs @@ -37,7 +37,7 @@ import Data.Maybe (mapMaybe) appMessage :: L.ByteString -> IO () appMessage l = forever $ do - run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l + -- run 3000 . const . return $ responseLBS status500 [("Content-Type", "text/plain")] l threadDelay 10000 swapApp :: I.IORef ThreadId -> IO ThreadId -> IO ()