haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'beta'

Browse Source 
Conflicts:
	yesod-core/yesod-core.cabal
	yesod-json/yesod-json.cabal
	yesod-test/Yesod/Test.hs
	yesod-test/test/main.hs
	yesod-test/yesod-test.cabal
This commit is contained in:
Michael Snoyman 2012-07-11 08:48:09 +03:00
commit 699d76d13a
71 changed files with 1096 additions and 854 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
yesod-auth/Yesod/Auth.hs
View File

@ -149,7 +149,10 @@ setCreds doRedirects creds = do
Nothing ->
when doRedirects $ do
case authRoute y of
Nothing -> do rh <- defaultLayout $ toWidget [shamlet| <h1>Invalid login |]
Nothing -> do rh <- defaultLayout $ toWidget [shamlet|
$newline never
<h1>Invalid login
|]
sendResponse rh
Just ar -> do setMessageI Msg.InvalidLogin
redirect ar
@ -168,6 +171,7 @@ getCheckR = do
where
html' creds =
[shamlet|
$newline never
<h1>Authentication Status
$maybe _ <- creds
<p>Logged in.

1
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -62,6 +62,7 @@ helper maudience = AuthPlugin
, apLogin = \toMaster -> do
addScriptRemote browserIdJs
toWidget [hamlet|
$newline never
<p>
<a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
<img src="https://browserid.org/i/sign_in_green.png">

1
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -24,6 +24,7 @@ authDummy =
url = PluginR "dummy" []
login authToMaster =
toWidget [hamlet|
$newline never
<form method="post" action="@{authToMaster url}">
Your new identifier is: #
<input type="text" name="ident">

13
yesod-auth/Yesod/Auth/Email.hs
View File

@ -79,6 +79,7 @@ authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch $ \tm ->
[whamlet|
$newline never
<form method="post" action="@{tm loginR}">
<table>
<tr>
@ -112,6 +113,7 @@ getRegisterR = do
defaultLayout $ do
setTitleI Msg.RegisterLong
[whamlet|
$newline never
<p>_{Msg.EnterEmail}
<form method="post" action="@{toMaster registerR}">
<label for="email">_{Msg.Email}
@ -141,7 +143,10 @@ postRegisterR = do
sendVerifyEmail email verKey verUrl
defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet| <p>_{Msg.ConfirmationEmailSent email} |]
[whamlet|
$newline never
<p>_{Msg.ConfirmationEmailSent email}
|]
getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
@ -161,7 +166,10 @@ getVerifyR lid key = do
_ -> return ()
defaultLayout $ do
setTitleI Msg.InvalidKey
[whamlet| <p>_{Msg.InvalidKey} |]
[whamlet|
$newline never
<p>_{Msg.InvalidKey}
|]
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
postLoginR = do
@ -200,6 +208,7 @@ getPasswordR = do
defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet|
$newline never
<h3>_{Msg.SetPass}
<form method="post" action="@{toMaster setpassR}">
<table>

5
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -46,7 +46,10 @@ authGoogleEmail =
where
complete = PluginR pid ["complete"]
login tm =
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
[whamlet|
$newline never
<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}
|]
dispatch "GET" ["forward"] = do
render <- getUrlRender
toMaster <- getRouteToMaster

7
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -76,7 +76,7 @@ import Yesod.Handler
import Yesod.Form
import Yesod.Auth
import Yesod.Widget (toWidget)
import Text.Hamlet (hamlet, shamlet)
import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
@ -176,7 +176,7 @@ postLoginR uniq = do
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage [shamlet| Invalid username/password |]
else do setMessage "Invalid username/password"
toMaster <- getRouteToMaster
redirect $ toMaster LoginR
@ -207,7 +207,7 @@ getAuthIdHashDB authR uniq creds = do
-- user exists
Just (Entity uid _) -> return $ Just uid
Nothing -> do
setMessage [shamlet| User not found |]
setMessage "User not found"
redirect $ authR LoginR
-- | Prompt for username and password, validate that against a database
@ -221,6 +221,7 @@ authHashDB :: ( YesodAuth m, YesodPersist m
, PersistUnique b (GHandler Auth m))
=> (Text -> Maybe (Unique user b)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never
<div id="header">
<h1>Login

35
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -3,10 +3,11 @@
{-# LANGUAGE CPP #-}
module Yesod.Auth.OpenId
( authOpenId
, authOpenIdExtended
, forwardUrl
, claimedKey
, opLocalKey
, credsIdentClaimed
, IdentifierType (..)
) where
import Yesod.Auth
@ -30,11 +31,13 @@ import Data.Maybe (fromMaybe)
forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
authOpenId :: YesodAuth m => AuthPlugin m
authOpenId = authOpenIdExtended []
data IdentifierType = Claimed | OPLocal
authOpenIdExtended :: YesodAuth m => [(Text, Text)] -> AuthPlugin m
authOpenIdExtended extensionFields =
authOpenId :: YesodAuth m
=> IdentifierType
-> [(Text, Text)] -- ^ extension fields
-> AuthPlugin m
authOpenId idType extensionFields =
AuthPlugin "openid" dispatch login
where
complete = PluginR "openid" ["complete"]
@ -46,6 +49,7 @@ authOpenIdExtended extensionFields =
padding-left: 18px;
|]
[whamlet|
$newline never
<form method="get" action="@{tm forwardUrl}">
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
<button .openid-google>_{Msg.LoginGoogle}
@ -78,15 +82,15 @@ authOpenIdExtended extensionFields =
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
completeHelper idType $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper posts
completeHelper idType posts
dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do
completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
completeHelper idType gets' = do
master <- getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster
@ -98,8 +102,14 @@ completeHelper gets' = do
case OpenId.oirClaimed oir of
Nothing -> id
Just (OpenId.Identifier i') -> ((claimedKey, i'):)
gets'' = claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
i = OpenId.identifier $ OpenId.oirOpLocal oir
oplocal =
case OpenId.oirOpLocal oir of
OpenId.Identifier i' -> ((opLocalKey, i'):)
gets'' = oplocal $ claimed $ filter (\(k, _) -> not $ "__" `isPrefixOf` k) gets'
i = OpenId.identifier $
case idType of
OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
setCreds True $ Creds "openid" i gets''
either onFailure onSuccess eres
@ -117,6 +127,9 @@ completeHelper gets' = do
claimedKey :: Text
claimedKey = "__CLAIMED"
opLocalKey :: Text
opLocalKey = "__OPLOCAL"
-- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
--
-- See 'claimedKey'.

1
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -25,6 +25,7 @@ authRpxnow app apiKey =
login tm = do
let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
toWidget [hamlet|
$newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|]
dispatch _ [] = do

36
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.0.2.1
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -12,44 +12,34 @@ build-type: Simple
homepage: http://www.yesodweb.com/
description: Authentication for Yesod.
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
build-depends: base >= 4 && < 5
, authenticate >= 1.2.1 && < 1.3
, authenticate >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, yesod-core >= 1.0 && < 1.1
, wai >= 1.2 && < 1.3
, yesod-core >= 1.1 && < 1.2
, wai >= 1.3 && < 1.4
, template-haskell
, pureMD5 >= 2.0 && < 2.2
, random >= 1.0.0.2 && < 1.1
, text >= 0.7 && < 0.12
, mime-mail >= 0.3 && < 0.5
, yesod-persistent >= 1.0 && < 1.1
, hamlet >= 1.0 && < 1.1
, yesod-persistent >= 1.1 && < 1.2
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, yesod-json >= 1.0 && < 1.1
, yesod-json >= 1.1 && < 1.2
, containers
, unordered-containers
, yesod-form >= 1.0 && < 1.1
, yesod-form >= 1.1 && < 1.2
, transformers >= 0.2.2 && < 0.4
, persistent >= 0.9 && < 0.10
, persistent-template >= 0.9 && < 0.10
, persistent >= 1.0 && < 1.1
, persistent-template >= 1.0 && < 1.1
, SHA >= 1.4.1.3 && < 1.6
, http-conduit >= 1.4.1.1 && < 1.5
, http-conduit >= 1.5 && < 1.6
, aeson >= 0.5
, pwstore-fast >= 2.2 && < 3
, lifted-base >= 0.1 && < 0.2
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
exposed-modules: Yesod.Auth
Yesod.Auth.BrowserId

4
yesod-core/Yesod/Content.hs
View File

@ -60,11 +60,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
import Data.Monoid (mempty)
import Text.Hamlet (Html)
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
#else
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
#endif
import Data.String (IsString (fromString))
import Network.Wai (FilePart)
import Data.Conduit (Source, ResourceT, Flush)

36
yesod-core/Yesod/Core.hs
View File

@ -10,6 +10,7 @@ module Yesod.Core
, breadcrumbs
-- * Types
, Approot (..)
, FileUpload (..)
-- * Utitlities
, maybeAuthorized
, widgetToPageContent
@ -20,8 +21,6 @@ module Yesod.Core
, unauthorizedI
-- * Logging
, LogLevel (..)
, formatLogMessage
, fileLocationToString
, logDebug
, logInfo
, logWarn
@ -59,38 +58,7 @@ import Yesod.Request
import Yesod.Widget
import Yesod.Message
import Language.Haskell.TH.Syntax
import qualified Language.Haskell.TH.Syntax as TH
import Data.Text (Text)
logTH :: LogLevel -> Q Exp
logTH level =
[|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|]
where
liftLoc :: Loc -> Q Exp
liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|]
-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
--
-- > $(logDebug) "This is a debug log message"
logDebug :: Q Exp
logDebug = logTH LevelDebug
-- | See 'logDebug'
logInfo :: Q Exp
logInfo = logTH LevelInfo
-- | See 'logDebug'
logWarn :: Q Exp
logWarn = logTH LevelWarn
-- | See 'logDebug'
logError :: Q Exp
logError = logTH LevelError
-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
--
-- > $(logOther "My new level") "This is a log message"
logOther :: Text -> Q Exp
logOther = logTH . LevelOther
import Control.Monad.Logger
-- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult

44
yesod-core/Yesod/Dispatch.hs
View File

@ -28,7 +28,7 @@ module Yesod.Dispatch
, WaiSubsite (..)
) where
import Data.Functor ((<$>))
import Control.Applicative ((<$>), (<*>))
import Prelude hiding (exp)
import Yesod.Internal.Core
import Yesod.Handler hiding (lift)
@ -53,6 +53,7 @@ import Network.HTTP.Types (status301)
import Yesod.Routes.TH
import Yesod.Content (chooseRep)
import Yesod.Routes.Parse
import System.Log.FastLogger (Logger)
type Texts = [Text]
@ -60,7 +61,7 @@ type Texts = [Text]
-- 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 String]
-> [ResourceTree String]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
@ -71,7 +72,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-- be embedded in other sites.
mkYesodSub :: String -- ^ name of the argument datatype
-> Cxt
-> [Resource String]
-> [ResourceTree String]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@ -82,28 +83,28 @@ mkYesodSub name clazzes =
-- 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 String] -> Q [Dec]
mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> 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 `AppT` ConT ''String)
let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
-- | See 'mkYesodData'.
mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
where (name':rest) = words name
@ -111,7 +112,7 @@ mkYesodGeneral :: String -- ^ foundation type
-> [String]
-> Cxt -- ^ classes
-> Bool -- ^ is subsite?
-> [Resource String]
-> [ResourceTree String]
-> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub resS = do
let args' = map mkName args
@ -119,7 +120,13 @@ mkYesodGeneral name args clazzes isSub resS = do
let res = map (fmap parseType) resS
renderRouteDec <- mkRenderRouteInstance arg res
disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
let logger = mkName "logger"
Clause pat body decs <- mkDispatchClause
[|yesodRunner $(return $ VarE logger)|]
[|yesodDispatch $(return $ VarE logger)|]
[|fmap chooseRep|]
res
let disp = Clause (VarP logger : pat) body decs
let master = mkName "master"
let ctx = if isSub
then ClassP (mkName "Yesod") [VarT master] : clazzes
@ -130,7 +137,7 @@ mkYesodGeneral name args clazzes isSub resS = do
let yesodDispatch' =
InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
return (renderRouteDec : masterTypSyns, [yesodDispatch'])
return (renderRouteDec ++ masterTypSyns, [yesodDispatch'])
where
name' = mkName name
masterTypSyns
@ -160,23 +167,24 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
toWaiAppPlain :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a
toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
toWaiApp' :: ( Yesod master
, YesodDispatch master master
)
=> master
-> Logger
-> Maybe (SessionBackend master)
-> W.Application
toWaiApp' y sb env =
toWaiApp' y logger sb env =
case cleanPath y $ W.pathInfo env of
Left pieces -> sendRedirect y pieces env
Right pieces ->
yesodDispatch y y id app404 handler405 method pieces sb env
yesodDispatch logger y y id app404 handler405 method pieces sb env
where
app404 = yesodRunner notFound y y Nothing id
handler405 route = yesodRunner badMethod y y (Just route) id
app404 = yesodRunner logger notFound y y Nothing id
handler405 route = yesodRunner logger badMethod y y (Just route) id
method = decodeUtf8With lenientDecode $ W.requestMethod env
sendRedirect :: Yesod master => master -> [Text] -> W.Application
@ -202,4 +210,4 @@ instance RenderRoute WaiSubsite where
renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
instance YesodDispatch WaiSubsite master where
yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

65
yesod-core/Yesod/Handler.hs
View File

@ -138,11 +138,7 @@ import qualified Network.Wai as W
import qualified Network.HTTP.Types as H
import Text.Hamlet
#if MIN_VERSION_blaze_html(0, 5, 0)
import qualified Text.Blaze.Html.Renderer.Text as RenderText
#else
import qualified Text.Blaze.Renderer.Text as RenderText
#endif
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
@ -159,18 +155,18 @@ import Control.Arrow ((***))
import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty, Endo (..))
import qualified Data.ByteString.Char8 as S8
import Data.ByteString (ByteString)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
#define preEscapedText preEscapedToMarkup
#else
import Text.Blaze (toHtml, preEscapedText)
#endif
import System.Log.FastLogger
import Control.Monad.Logger
import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
@ -181,6 +177,9 @@ import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Control.Monad.Base
import Yesod.Routes.Class
import Data.Word (Word64)
import Data.Conduit (Sink)
import Language.Haskell.TH.Syntax (Loc)
class YesodSubRoute s y where
fromSubRoute :: s -> y -> Route s -> Route y
@ -193,6 +192,8 @@ data HandlerData sub master = HandlerData
, handlerRender :: Route master -> [(Text, Text)] -> Text
, handlerToMaster :: Route sub -> Route master
, handlerState :: I.IORef GHState
, handlerUpload :: Word64 -> FileUpload
, handlerLog :: Loc -> LogLevel -> LogStr -> IO ()
}
handlerSubData :: (Route sub -> Route master)
@ -322,22 +323,36 @@ hcError = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents
runRequestBody = do
hd <- ask
let getUpload = handlerUpload hd
len = reqBodySize $ handlerRequest hd
upload = getUpload len
x <- get
case ghsRBC x of
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
rbc <- lift $ rbHelper rr
rbc <- lift $ rbHelper upload rr
put x { ghsRBC = Just rbc }
return rbc
rbHelper :: W.Request -> ResourceT IO RequestBodyContents
rbHelper req =
(map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
rbHelper upload =
case upload of
FileUploadMemory s -> rbHelper' s mkFileInfoLBS
FileUploadDisk s -> rbHelper' s mkFileInfoFile
FileUploadSource s -> rbHelper' s mkFileInfoSource
rbHelper' :: Sink S8.ByteString (ResourceT IO) x
-> (Text -> Text -> x -> FileInfo)
-> W.Request
-> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
rbHelper' sink mkFI req =
(map fix1 *** map fix2) <$> (NWP.parseRequestBody sink req)
where
fix1 = go *** go
fix2 (x, NWP.FileInfo a b c) =
(go x, FileInfo (go a) (go b) c)
(go x, mkFI (go a) (go b) c)
go = decodeUtf8With lenientDecode
-- | Get the sub application argument.
@ -378,8 +393,10 @@ runHandler :: HasReps c
-> (Route sub -> Route master)
-> master
-> sub
-> (Word64 -> FileUpload)
-> (Loc -> LogLevel -> LogStr -> IO ())
-> YesodApp
runHandler handler mrender sroute tomr master sub =
runHandler handler mrender sroute tomr master sub upload log' =
YesodApp $ \eh rr cts initSession -> do
let toErrorHandler e =
case fromException e of
@ -400,6 +417,8 @@ runHandler handler mrender sroute tomr master sub =
, handlerRender = mrender
, handlerToMaster = tomr
, handlerState = istate
, handlerUpload = upload
, handlerLog = log'
}
contents' <- catch (fmap Right $ unGHandler handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
@ -772,6 +791,8 @@ getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b)
=> master -- ^ master site foundation
-> sub -- ^ sub site foundation
-> (Word64 -> FileUpload)
-> (Loc -> LogLevel -> LogStr -> IO ())
-> (Route sub -> Route master)
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
-> (ErrorResponse -> GHandler sub master a)
@ -780,15 +801,15 @@ handlerToYAR :: (HasReps a, HasReps b)
-> SessionMap
-> GHandler sub master b
-> ResourceT IO YesodAppResult
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap
where
ya = runHandler h render murl toMasterRoute y s
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
ya = runHandler h render murl toMasterRoute y s upload log'
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'
types = httpAccept $ reqWaiRequest rr
errorHandler' = localNoCurrent . errorHandler
yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response
yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response
yarToResponse (YARWai a) _ = a
yarToResponse (YARPlain s hs _ c _) extraHeaders =
case c of
@ -810,7 +831,7 @@ httpAccept = parseHttpAccept
-- | Convert Header to a key/value pair.
headerToPair :: Header
-> (CI H.Ascii, H.Ascii)
-> (CI ByteString, ByteString)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie $ sc)
headerToPair (DeleteCookie key path) =
@ -842,6 +863,7 @@ redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
redirectToPost url = do
urlText <- toTextUrl url
hamletToRepHtml [hamlet|
$newline never
$doctype 5
<html>
@ -936,3 +958,8 @@ instance MonadResource (GHandler sub master) where
register = lift . register
release = lift . release
resourceMask = lift . resourceMask
instance MonadLogger (GHandler sub master) where
monadLoggerLog a b c = do
hd <- ask
liftIO $ handlerLog hd a b (toLogStr c)

30
yesod-core/Yesod/Internal.hs
View File

@ -27,7 +27,8 @@ module Yesod.Internal
, tokenKey
) where
import Text.Hamlet (HtmlUrl, hamlet, Html)
import Text.Hamlet (HtmlUrl, Html)
import Text.Blaze.Html (toHtml)
import Text.Julius (JavascriptUrl)
import Data.Monoid (Monoid (..), Last)
import Data.List (nub)
@ -41,8 +42,8 @@ import qualified Network.HTTP.Types as H
import Data.String (IsString)
import qualified Data.Map as Map
import Data.Text.Lazy.Builder (Builder)
import Network.HTTP.Types (Ascii)
import Web.Cookie (SetCookie (..))
import Data.ByteString (ByteString)
-- | Responses to indicate some form of an error occurred. These are different
-- from 'SpecialResponse' in that they allow for custom error pages.
@ -59,8 +60,8 @@ instance Exception ErrorResponse
-- | Headers to be added to a 'Result'.
data Header =
AddCookie SetCookie
| DeleteCookie Ascii Ascii
| Header Ascii Ascii
| DeleteCookie ByteString ByteString
| Header ByteString ByteString
deriving (Eq, Show)
langKey :: IsString a => a
@ -69,10 +70,8 @@ langKey = "_LANG"
data Location url = Local url | Remote Text
deriving (Show, Eq)
locationToHtmlUrl :: Location url -> HtmlUrl url
locationToHtmlUrl (Local url) = [hamlet|\@{url}
|]
locationToHtmlUrl (Remote s) = [hamlet|\#{s}
|]
locationToHtmlUrl (Local url) render = toHtml $ render url []
locationToHtmlUrl (Remote s) _ = toHtml s
newtype UniqueList x = UniqueList ([x] -> [x])
instance Monoid (UniqueList x) where
@ -100,13 +99,14 @@ tokenKey = "_TOKEN"
type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
data GWData a = GWData
!(Body a)
!(Last Title)
!(UniqueList (Script a))
!(UniqueList (Stylesheet a))
!(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
!(Maybe (JavascriptUrl a))
!(Head a)
{ gwdBody :: !(Body a)
, gwdTitle :: !(Last Title)
, gwdScripts :: !(UniqueList (Script a))
, gwdStylesheets :: !(UniqueList (Stylesheet a))
, gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
, gwdJavascript :: !(Maybe (JavascriptUrl a))
, gwdHead :: !(Head a)
}
instance Monoid (GWData a) where
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
mappend (GWData a1 a2 a3 a4 a5 a6 a7)

152
yesod-core/Yesod/Internal/Core.hs
View File

@ -20,11 +20,6 @@ module Yesod.Internal.Core
, defaultErrorHandler
-- * Data types
, AuthResult (..)
-- * Logging
, LogLevel (..)
, formatLogMessage
, fileLocationToString
, messageLoggerHandler
-- * Sessions
, SessionBackend (..)
, defaultClientSessionBackend
@ -40,6 +35,7 @@ module Yesod.Internal.Core
, yesodRender
, resolveApproot
, Approot (..)
, FileUpload (..)
) where
import Yesod.Content
@ -47,6 +43,7 @@ import Yesod.Handler hiding (lift, getExpires)
import Yesod.Routes.Class
import Data.Word (Word64)
import Control.Arrow ((***))
import Control.Monad (forM)
import Yesod.Widget
@ -80,26 +77,19 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.List (foldl')
import qualified Network.HTTP.Types as H
import Web.Cookie (SetCookie (..))
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO
import qualified Data.Text.Lazy.Builder as TB
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
#if MIN_VERSION_blaze_html(0, 5, 0)
import Language.Haskell.TH.Syntax (Loc (..))
import Text.Blaze (preEscapedToMarkup)
#else
import Text.Blaze (preEscapedLazyText)
#endif
import Data.Aeson (Value (Array, String))
import Data.Aeson.Encode (encode)
import qualified Data.Vector as Vector
import Network.Wai.Middleware.Gzip (GzipSettings, def)
import Network.Wai.Parse (tempFileSink, lbsSink)
import qualified Paths_yesod_core
import Data.Version (showVersion)
#if MIN_VERSION_blaze_html(0, 5, 0)
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
#endif
import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther))
import System.Log.FastLogger.Date (ZonedDate)
import System.IO (stdout)
yesodVersion :: String
yesodVersion = showVersion Paths_yesod_core.version
@ -109,7 +99,8 @@ yesodVersion = showVersion Paths_yesod_core.version
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> master
=> Logger
-> master
-> sub
-> (Route sub -> Route master)
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
@ -120,7 +111,8 @@ class YesodDispatch sub master where
-> W.Application
yesodRunner :: Yesod master
=> GHandler sub master ChooseRep
=> Logger
-> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
@ -170,6 +162,7 @@ class RenderRoute a => Yesod a where
p <- widgetToPageContent w
mmsg <- getMessage
hamletToRepHtml [hamlet|
$newline never
$doctype 5
<html>
@ -290,21 +283,28 @@ $doctype 5
cookieDomain _ = Nothing
-- | Maximum allowed length of the request body, in bytes.
maximumContentLength :: a -> Maybe (Route a) -> Int
--
-- Default: 2 megabytes.
maximumContentLength :: a -> Maybe (Route a) -> Word64
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
-- | Send a message to the log. By default, prints to stdout.
-- | Returns a @Logger@ to use for log messages.
--
-- Default: Sends to stdout and automatically flushes on each write.
getLogger :: a -> IO Logger
getLogger _ = mkLogger True stdout
-- | Send a message to the @Logger@ provided by @getLogger@.
messageLogger :: a
-> Logger
-> Loc -- ^ position in source code
-> LogLevel
-> Text -- ^ message
-> LogStr -- ^ message
-> IO ()
messageLogger a loc level msg =
messageLogger a logger loc level msg =
if level < logLevel a
then return ()
else
formatLogMessage loc level msg >>=
Data.Text.Lazy.IO.putStrLn
else formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger
-- | The logging level in place for this application. Any messages below
-- this level will simply be ignored.
@ -332,38 +332,37 @@ $doctype 5
key <- CS.getKey CS.defaultKeyFile
return $ Just $ clientSessionBackend key 120
-- | How to store uploaded files.
--
-- Default: Whe nthe request body is greater than 50kb, store in a temp
-- file. Otherwise, store in memory.
fileUpload :: a
-> Word64 -- ^ request body size
-> FileUpload
fileUpload _ size
| size > 50000 = FileUploadDisk tempFileSink
| otherwise = FileUploadMemory lbsSink
messageLoggerHandler :: Yesod m
=> Loc -> LogLevel -> Text -> GHandler s m ()
messageLoggerHandler loc level msg = do
y <- getYesod
liftIO $ messageLogger y loc level msg
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
deriving (Eq, Show, Read, Ord)
instance Lift LogLevel where
lift LevelDebug = [|LevelDebug|]
lift LevelInfo = [|LevelInfo|]
lift LevelWarn = [|LevelWarn|]
lift LevelError = [|LevelError|]
lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|]
formatLogMessage :: Loc
formatLogMessage :: IO ZonedDate
-> Loc
-> LogLevel
-> Text -- ^ message
-> IO TL.Text
formatLogMessage loc level msg = do
now <- getCurrentTime
return $ TB.toLazyText $
TB.fromText (T.pack $ show now)
`mappend` TB.fromText " ["
`mappend` TB.fromText (T.pack $ drop 5 $ show level)
`mappend` TB.fromText "] "
`mappend` TB.fromText msg
`mappend` TB.fromText " @("
`mappend` TB.fromText (T.pack $ fileLocationToString loc)
`mappend` TB.fromText ") "
-> LogStr -- ^ message
-> IO [LogStr]
formatLogMessage getdate loc level msg = do
now <- getdate
return
[ LB now
, LB " ["
, LS $
case level of
LevelOther t -> T.unpack t
_ -> drop 5 $ show level
, LB "] "
, msg
, LB " @("
, LS $ fileLocationToString loc
, LB ")\n"
]
-- taken from file-location package
-- turn the TH Loc loaction information into a human readable string
@ -376,31 +375,26 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
char = show . snd . loc_start
defaultYesodRunner :: Yesod master
=> GHandler sub master ChooseRep
=> Logger
-> GHandler sub master ChooseRep
-> master
-> sub
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> Maybe (SessionBackend master)
-> W.Application
defaultYesodRunner _ master _ murl toMaster _ req
| maximumContentLength master (fmap toMaster murl) < len =
defaultYesodRunner logger handler master sub murl toMasterRoute msb req
| maximumContentLength master (fmap toMasterRoute murl) < len =
return $ W.responseLBS
(H.Status 413 "Too Large")
[("Content-Type", "text/plain")]
"Request body too large to be processed."
where
len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
readMay s =
case reads $ S8.unpack s of
[] -> Nothing
(x, _):_ -> Just x
defaultYesodRunner handler master sub murl toMasterRoute msb req = do
| otherwise = do
now <- liftIO getCurrentTime
let dontSaveSession _ _ = return []
(session, saveSession) <- liftIO $
maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
rr <- liftIO $ parseWaiRequest req session (isJust msb)
rr <- liftIO $ parseWaiRequest req session (isJust msb) len
let h = {-# SCC "h" #-} do
case murl of
Nothing -> handler
@ -420,7 +414,8 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req = do
handler
let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session
let ra = resolveApproot master req
yar <- handlerToYAR master sub toMasterRoute
let log' = messageLogger master logger
yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute
(yesodRender master ra) errorHandler rr murl sessionMap h
extraHeaders <- case yar of
(YARPlain _ _ ct _ newSess) -> do
@ -432,6 +427,12 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req = do
return $ ("Content-Type", ct) : map headerToPair sessionHeaders
_ -> return []
return $ yarToResponse yar extraHeaders
where
len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
readMay s =
case reads $ S8.unpack s of
[] -> Nothing
(x, _):_ -> Just x
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
deriving (Eq, Show, Read)
@ -478,18 +479,21 @@ defaultErrorHandler NotFound = do
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
applyLayout' "Not Found"
[hamlet|
$newline never
<h1>Not Found
<p>#{path'}
|]
defaultErrorHandler (PermissionDenied msg) =
applyLayout' "Permission Denied"
[hamlet|
$newline never
<h1>Permission denied
<p>#{msg}
|]
defaultErrorHandler (InvalidArgs ia) =
applyLayout' "Invalid Arguments"
[hamlet|
$newline never
<h1>Invalid Arguments
<ul>
$forall msg <- ia
@ -498,12 +502,14 @@ defaultErrorHandler (InvalidArgs ia) =
defaultErrorHandler (InternalError e) =
applyLayout' "Internal Server Error"
[hamlet|
$newline never
<h1>Internal Server Error
<p>#{e}
|]
defaultErrorHandler (BadMethod m) =
applyLayout' "Bad Method"
[hamlet|
$newline never
<h1>Method Not Supported
<p>Method "#{S8.unpack m}" not supported
|]
@ -521,7 +527,7 @@ maybeAuthorized r isWrite = do
return $ if x == Authorized then Just r else Nothing
jsToHtml :: Javascript -> Html
jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b
jelper :: JavascriptUrl url -> HtmlUrl url
jelper = fmap jsToHtml
@ -549,7 +555,7 @@ widgetToPageContent w = do
$ encodeUtf8 rendered
return (mmedia,
case x of
Nothing -> Left $ preEscapedLazyText rendered
Nothing -> Left $ preEscapedToMarkup rendered
Just y -> Right $ either id (uncurry render) y)
jsLoc <-
case jscript of
@ -563,6 +569,7 @@ widgetToPageContent w = do
-- the asynchronous loader means your page doesn't have to wait for all the js to load
let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc
regularScriptLoad = [hamlet|
$newline never
$forall s <- scripts
^{mkScriptTag s}
$maybe j <- jscript
@ -573,6 +580,7 @@ $maybe j <- jscript
|]
headAll = [hamlet|
$newline never
\^{head'}
$forall s <- stylesheets
^{mkLinkTag s}
@ -595,6 +603,7 @@ $case jsLoader master
^{regularScriptLoad}
|]
let bodyScript = [hamlet|
$newline never
^{body}
^{regularScriptLoad}
|]
@ -641,6 +650,7 @@ jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String
loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
loadJsYepnope eyn scripts mcomplete =
[hamlet|
$newline never
$maybe yn <- left eyn
<script src=#{yn}>
$maybe yn <- right eyn

43
yesod-core/Yesod/Internal/Request.hs
View File

@ -4,7 +4,15 @@ module Yesod.Internal.Request
( parseWaiRequest
, Request (..)
, RequestBodyContents
, FileInfo (..)
, FileInfo
, fileName
, fileContentType
, fileSource
, fileMove
, mkFileInfoLBS
, mkFileInfoFile
, mkFileInfoSource
, FileUpload (..)
-- The below are exported for testing.
, randomString
, parseWaiRequest'
@ -28,6 +36,10 @@ import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Conduit
import Data.Conduit.List (sourceList)
import Data.Conduit.Binary (sourceFile, sinkFile)
import Data.Word (Word64)
-- | The parsed request information.
data Request = Request
@ -38,23 +50,27 @@ data Request = Request
, reqLangs :: [Text]
-- | A random, session-specific token used to prevent CSRF attacks.
, reqToken :: Maybe Text
-- | Size of the request body.
, reqBodySize :: Word64
}
parseWaiRequest :: W.Request
-> [(Text, ByteString)] -- ^ session
-> Bool
-> Word64
-> IO Request
parseWaiRequest env session' useToken =
parseWaiRequest' env session' useToken <$> newStdGen
parseWaiRequest env session' useToken bodySize =
parseWaiRequest' env session' useToken bodySize <$> newStdGen
parseWaiRequest' :: RandomGen g
=> W.Request
-> [(Text, ByteString)] -- ^ session
-> Bool
-> Word64
-> g
-> Request
parseWaiRequest' env session' useToken gen =
Request gets'' cookies' env langs'' token
parseWaiRequest' env session' useToken bodySize gen =
Request gets'' cookies' env langs'' token bodySize
where
gets' = queryToQueryText $ W.queryString env
gets'' = map (second $ fromMaybe "") gets'
@ -116,6 +132,19 @@ type RequestBodyContents =
data FileInfo = FileInfo
{ fileName :: Text
, fileContentType :: Text
, fileContent :: L.ByteString
, fileSource :: Source (ResourceT IO) ByteString
, fileMove :: FilePath -> IO ()
}
deriving (Eq, Show)
mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
data FileUpload = FileUploadMemory (Sink ByteString (ResourceT IO) L.ByteString)
| FileUploadDisk (Sink ByteString (ResourceT IO) FilePath)
| FileUploadSource (Sink ByteString (ResourceT IO) (Source (ResourceT IO) ByteString))

138
yesod-core/Yesod/Logger.hs
View File

@ -1,138 +0,0 @@
{-# LANGUAGE BangPatterns #-}
module Yesod.Logger
( Logger
, handle
, developmentLogger, productionLogger
, defaultDevelopmentLogger, defaultProductionLogger
, toProduction
, flushLogger
, logText
, logLazyText
, logString
, logBS
, logMsg
, formatLogText
, timed
-- * Deprecated
, makeLoggerWithHandle
, makeDefaultLogger
) where
import System.IO (Handle, stdout, hFlush)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.ByteString.Lazy (toChunks)
import qualified Data.Text.Lazy as TL
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy.Encoding as TLE
import System.Log.FastLogger
import Network.Wai.Logger.Date (DateRef, dateInit, getDate)
-- for timed logging
import Data.Time (getCurrentTime, diffUTCTime)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Printf (printf)
import Data.Text (unpack)
-- for formatter
import Language.Haskell.TH.Syntax (Loc)
import Yesod.Core (LogLevel, fileLocationToString)
data Logger = Logger {
loggerLogFun :: [LogStr] -> IO ()
, loggerHandle :: Handle
, loggerDateRef :: DateRef
}
handle :: Logger -> Handle
handle = loggerHandle
flushLogger :: Logger -> IO ()
flushLogger = hFlush . loggerHandle
makeDefaultLogger :: IO Logger
makeDefaultLogger = defaultDevelopmentLogger
{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}
makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger
makeLoggerWithHandle = productionLogger
{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}
-- | uses stdout handle
defaultProductionLogger, defaultDevelopmentLogger :: IO Logger
defaultProductionLogger = productionLogger stdout
defaultDevelopmentLogger = developmentLogger stdout
productionLogger h = mkLogger h (handleToLogFun h)
-- | a development logger gets automatically flushed
developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)
mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger
mkLogger h logFun = do
initHandle h
dateInit >>= return . Logger logFun h
-- convert (a development) logger to production settings
toProduction :: Logger -> Logger
toProduction (Logger _ h d) = Logger (handleToLogFun h) h d
handleToLogFun :: Handle -> ([LogStr] -> IO ())
handleToLogFun = hPutLogStr
logMsg :: Logger -> [LogStr] -> IO ()
logMsg = hPutLogStr . handle
logLazyText :: Logger -> TL.Text -> IO ()
logLazyText logger msg = loggerLogFun logger $
map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
logText :: Logger -> Text -> IO ()
logText logger = logBS logger . encodeUtf8
logBS :: Logger -> ByteString -> IO ()
logBS logger msg = loggerLogFun logger $ [LB msg, newLine]
logString :: Logger -> String -> IO ()
logString logger msg = loggerLogFun logger $ [LS msg, newLine]
formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]
formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)
toLB :: Text -> LogStr
toLB = LB . encodeUtf8
formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]
formatLogMsg logger loc level msg = do
date <- liftIO $ getDate $ loggerDateRef logger
return
[ LB date
, LB $ pack" ["
, LS (drop 5 $ show level)
, LB $ pack "] "
, msg
, LB $ pack " @("
, LS (fileLocationToString loc)
, LB $ pack ") "
]
newLine :: LogStr
newLine = LB $ pack "\n"
-- | Execute a monadic action and log the duration
--
timed :: MonadIO m
=> Logger -- ^ Logger
-> Text -- ^ Message
-> m a -- ^ Action
-> m a -- ^ Timed and logged action
timed logger msg action = do
start <- liftIO getCurrentTime
!result <- action
stop <- liftIO getCurrentTime
let diff = fromEnum $ diffUTCTime stop start
ms = diff `div` 10 ^ (9 :: Int)
formatted = printf " [%4dms] %s" ms (unpack msg)
liftIO $ logString logger formatted
return result

6
yesod-core/Yesod/Request.hs
View File

@ -16,7 +16,11 @@ module Yesod.Request
-- * Request datatype
RequestBodyContents
, Request (..)
, FileInfo (..)
, FileInfo
, fileName
, fileContentType
, fileSource
, fileMove
-- * Convenience functions
, languages
-- * Lookup parameters

15
yesod-core/Yesod/Widget.hs
View File

@ -53,6 +53,7 @@ module Yesod.Widget
, addScriptEither
-- * Internal
, unGWidget
, whamletFileWithSettings
) where
import Data.Monoid
@ -80,20 +81,16 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Exception (throwIO)
import qualified Text.Hamlet as NP
import Data.Text.Lazy.Builder (fromLazyText)
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import qualified Data.Text.Lazy as TL
#else
import Text.Blaze (toHtml, preEscapedLazyText)
#endif
import Control.Monad.Base (MonadBase (liftBase))
import Control.Arrow (first)
import Control.Monad.Trans.Resource
#if MIN_VERSION_blaze_html(0, 5, 0)
import Control.Monad.Logger
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
#endif
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
@ -272,6 +269,9 @@ whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
whamletFile :: FilePath -> Q Exp
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
whamletFileWithSettings = NP.hamletFileWithSettings rules
rules :: Q NP.HamletRules
rules = do
ah <- [|toWidget|]
@ -344,3 +344,6 @@ instance MonadResource (GWidget sub master) where
register = lift . register
release = lift . release
resourceMask = lift . resourceMask
instance MonadLogger (GWidget sub master) where
monadLoggerLog a b = lift . monadLoggerLog a b

8
yesod-core/helloworld.hs
View File

@ -5,7 +5,7 @@
import Yesod.Core
import Control.Monad.IO.Class (liftIO)
import Network.Wai.Handler.Warp (run)
import Data.Text (unpack)
import Data.Text (unpack, pack)
import Text.Julius (julius)
data Subsite = Subsite String
@ -22,13 +22,13 @@ getSubRootR = do
Subsite s <- getYesodSub
tm <- getRouteToMaster
render <- getUrlRender
$(logDebug) "I'm in SubRootR"
$logDebug "I'm in SubRootR"
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
handleSubMultiR x = do
Subsite y <- getYesodSub
$(logInfo) "In SubMultiR"
$logInfo "In SubMultiR"
return . RepPlain . toContent . show $ (x, y)
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
@ -38,7 +38,7 @@ mkYesod "HelloWorld" [parseRoutes|
|]
instance Yesod HelloWorld where
addStaticContent a b c = do
liftIO $ print (a, b, c)
$logInfo $ pack $ show (a, b, c)
return Nothing
getRootR = do

2
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -26,7 +26,7 @@ instance RenderRoute Subsite where
renderRoute (SubsiteRoute x) = (x, [])
instance YesodDispatch Subsite master where
yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show pieces

6
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -24,7 +24,9 @@ mkYesod "App" [parseRoutes|
instance Yesod App
getHomeR :: Handler RepHtml
getHomeR = defaultLayout $ toWidget [hamlet|
getHomeR = do
$logDebug "Testing logging"
defaultLayout $ toWidget [hamlet|
$doctype 5
<html>
@ -49,7 +51,7 @@ postFirstThingR = do
postAfterRunRequestBodyR = do
x <- runRequestBody
_ <- error $ show x
_ <- error $ show $ fst x
getHomeR
errorHandlingTest :: Spec

18
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -40,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)"
noDisabledToken :: Bool
noDisabledToken = reqToken r == Nothing where
r = parseWaiRequest' defaultRequest [] False g
r = parseWaiRequest' defaultRequest [] False 0 g
ignoreDisabledToken :: Bool
ignoreDisabledToken = reqToken r == Nothing where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False g
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 g
useOldToken :: Bool
useOldToken = reqToken r == Just "old" where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g
generateToken :: Bool
generateToken = reqToken r /= Nothing where
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True g
r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 g
langSpecs :: Spec
@ -67,21 +67,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)"
respectAcceptLangs :: Bool
respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
r = parseWaiRequest' defaultRequest
{ requestHeaders = [("Accept-Language", "en-US, es")] } [] False g
{ requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 g
respectSessionLang :: Bool
respectSessionLang = reqLangs r == ["en"] where
r = parseWaiRequest' defaultRequest [("_LANG", "en")] False g
r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 g
respectCookieLang :: Bool
respectCookieLang = reqLangs r == ["en"] where
r = parseWaiRequest' defaultRequest
{ requestHeaders = [("Cookie", "_LANG=en")]
} [] False g
} [] False 0 g
respectQueryLang :: Bool
respectQueryLang = reqLangs r == ["en-US", "en"] where
r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False g
r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 g
prioritizeLangs :: Bool
prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@ -90,7 +90,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
, ("Cookie", "_LANG=en-COOKIE")
]
, queryString = [("_LANG", Just "en-QUERY")]
} [("_LANG", "en-SESSION")] False g
} [("_LANG", "en-SESSION")] False 0 g
internalRequestTest :: Spec

2
yesod-core/test/YesodCoreTest/Links.hs
View File

@ -31,4 +31,4 @@ runner f = toWaiApp Y >>= runSession f
case_linkToHome :: IO ()
case_linkToHome = runner $ do
res <- request defaultRequest
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a>\n</body></html>" res

9
yesod-core/test/YesodCoreTest/Widget.hs
View File

@ -56,12 +56,13 @@ getTowidgetR = defaultLayout $ do
toWidget [lucius|foo{bar:baz}|]
toWidgetHead [lucius|foo{bar:baz}|]
toWidget [hamlet|<foo>|] :: Widget
toWidget [hamlet|<foo>|]
toWidgetHead [hamlet|<foo>|]
toWidgetBody [hamlet|<foo>|]
getWhamletR :: Handler RepHtml
getWhamletR = defaultLayout [whamlet|
$newline never
<h1>Test
<h2>@{WhamletR}
<h3>_{Goodbye}
@ -69,10 +70,14 @@ getWhamletR = defaultLayout [whamlet|
^{embed}
|]
where
embed = [whamlet|<h4>Embed|]
embed = [whamlet|
$newline never
<h4>Embed
|]
getAutoR :: Handler RepHtml
getAutoR = defaultLayout [whamlet|
$newline never
^{someHtml}
|]
where

35
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core
version: 1.0.1.3
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -40,10 +40,6 @@ flag test
description: Build the executable to run unit tests
default: False
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
-- Work around a bug in cabal. Without this, wai-test doesn't get built and
-- we have a missing dependency during --enable-tests builds.
@ -52,21 +48,21 @@ library
build-depends: base >= 4.3 && < 5
, time >= 1.1.4
, yesod-routes >= 1.0 && < 1.1
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, yesod-routes >= 1.1 && < 1.2
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, text >= 0.7 && < 0.12
, template-haskell
, path-pieces >= 0.1 && < 0.2
, hamlet >= 1.0 && < 1.1
, hamlet >= 1.1 && < 1.2
, shakespeare >= 1.0 && < 1.1
, shakespeare-js >= 1.0 && < 1.1
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-i18n >= 1.0 && < 1.1
, blaze-builder >= 0.2.1.4 && < 0.4
, transformers >= 0.2.2 && < 0.4
, clientsession >= 0.7.3.1 && < 0.8
, clientsession >= 0.8 && < 0.9
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.3 && < 0.4
, old-locale >= 1.0.0.2 && < 1.1
@ -75,31 +71,24 @@ library
, monad-control >= 0.3 && < 0.4
, transformers-base >= 0.4
, cookie >= 0.4 && < 0.5
, http-types >= 0.6.5 && < 0.7
, http-types >= 0.7 && < 0.8
, case-insensitive >= 0.2
, parsec >= 2 && < 3.2
, directory >= 1 && < 1.2
, vector >= 0.9 && < 0.10
, aeson >= 0.5
, fast-logger >= 0.0.2
, wai-logger >= 0.0.1
, conduit >= 0.4 && < 0.5
, fast-logger >= 0.2 && < 0.3
, monad-logger >= 0.2 && < 0.3
, conduit >= 0.5 && < 0.6
, resourcet >= 0.3 && < 0.4
, lifted-base >= 0.1 && < 0.2
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
exposed-modules: Yesod.Content
Yesod.Core
Yesod.Dispatch
Yesod.Handler
Yesod.Logger
Yesod.Request
Yesod.Widget
Yesod.Message

13
yesod-default/Yesod/Default/Main.hs
View File

@ -7,7 +7,6 @@ module Yesod.Default.Main
) where
import Yesod.Default.Config
import Yesod.Logger (Logger, defaultDevelopmentLogger, logString)
import Network.Wai (Application)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort, settingsHost)
@ -33,12 +32,11 @@ import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
--
defaultMain :: (Show env, Read env)
=> IO (AppConfig env extra)
-> (AppConfig env extra -> Logger -> IO Application)
-> (AppConfig env extra -> IO Application)
-> IO ()
defaultMain load getApp = do
config <- load
logger <- defaultDevelopmentLogger
app <- getApp config logger
app <- getApp config
print $ appHost config
runSettings defaultSettings
{ settingsPort = appPort config
@ -80,12 +78,11 @@ defaultRunner f app = do
defaultDevelApp
:: (Show env, Read env)
=> IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@
-> (AppConfig env extra -> Logger -> IO Application) -- ^ Get your @Application@
-> (AppConfig env extra -> IO Application) -- ^ Get your @Application@
-> IO (Int, Application)
defaultDevelApp load getApp = do
conf <- load
logger <- defaultDevelopmentLogger
let p = appPort conf
logString logger $ "Devel application launched: http://localhost:" ++ show p
app <- getApp conf logger
putStrLn $ "Devel application launched: http://localhost:" ++ show p
app <- getApp conf
return (p, app)

68
yesod-default/Yesod/Default/Util.hs
View File

@ -7,7 +7,11 @@ module Yesod.Default.Util
, globFile
, widgetFileNoReload
, widgetFileReload
, widgetFileJsCss
, TemplateLanguage (..)
, defaultTemplateLanguages
, WidgetFileSettings
, wfsLanguages
, wfsHamletSettings
) where
import Control.Monad.IO.Class (liftIO)
@ -20,7 +24,9 @@ import Language.Haskell.TH.Syntax
import Text.Lucius (luciusFile, luciusFileReload)
import Text.Julius (juliusFile, juliusFileReload)
import Text.Cassius (cassiusFile, cassiusFileReload)
import Text.Hamlet (HamletSettings, defaultHamletSettings)
import Data.Maybe (catMaybes)
import Data.Default (Default (def))
-- | An implementation of 'addStaticContent' which stores the contents in an
-- external file. Files are created in the given static folder with names based
@ -57,34 +63,40 @@ addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
globFile :: String -> String -> FilePath
globFile kind x = "templates/" ++ x ++ "." ++ kind
widgetFileNoReload :: FilePath -> Q Exp
widgetFileNoReload x = combine "widgetFileNoReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFile
, whenExists x True "julius" juliusFile
, whenExists x True "lucius" luciusFile
]
data TemplateLanguage = TemplateLanguage
{ tlRequiresToWidget :: Bool
, tlExtension :: String
, tlNoReload :: FilePath -> Q Exp
, tlReload :: FilePath -> Q Exp
}
widgetFileReload :: FilePath -> Q Exp
widgetFileReload x = combine "widgetFileReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFileReload
, whenExists x True "julius" juliusFileReload
, whenExists x True "lucius" luciusFileReload
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages hset =
[ TemplateLanguage False "hamlet" whamletFile' whamletFile'
, TemplateLanguage True "cassius" cassiusFile cassiusFileReload
, TemplateLanguage True "julius" juliusFile juliusFileReload
, TemplateLanguage True "lucius" luciusFile luciusFileReload
]
where
whamletFile' = whamletFileWithSettings hset
widgetFileJsCss :: (String, FilePath -> Q Exp) -- ^ JavaScript file extenstion and loading function. example: ("julius", juliusFileReload)
-> (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("cassius", cassiusFileReload)
-> FilePath -> Q Exp
widgetFileJsCss (jsExt, jsLoad) (csExt, csLoad) x = combine "widgetFileJsCss" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True csExt csLoad
, whenExists x True jsExt jsLoad
]
data WidgetFileSettings = WidgetFileSettings
{ wfsLanguages :: HamletSettings -> [TemplateLanguage]
, wfsHamletSettings :: HamletSettings
}
combine :: String -> String -> [Q (Maybe Exp)] -> Q Exp
combine func file qmexps = do
mexps <- sequence qmexps
instance Default WidgetFileSettings where
def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings
widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs
widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp
widgetFileReload wfs x = combine "widgetFileReload" x True $ wfsLanguages wfs $ wfsHamletSettings wfs
combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine func file isReload tls = do
mexps <- qmexps
case catMaybes mexps of
[] -> error $ concat
[ "Called "
@ -94,6 +106,12 @@ combine func file qmexps = do
, ", but no template were found."
]
exps -> return $ DoE $ map NoBindS exps
where
qmexps :: Q [Maybe Exp]
qmexps = mapM go tls
go :: TemplateLanguage -> Q (Maybe Exp)
go tl = whenExists file (tlRequiresToWidget tl) (tlExtension tl) ((if isReload then tlReload else tlNoReload) tl)
whenExists :: String
-> Bool -- ^ requires toWidget wrap

16
yesod-default/yesod-default.cabal
View File

@ -1,5 +1,5 @@
name: yesod-default
version: 1.0.1.1
version: 1.1.0
license: MIT
license-file: LICENSE
author: Patrick Brisbin
@ -18,10 +18,10 @@ library
cpp-options: -DWINDOWS
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, warp >= 1.2 && < 1.3
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, yesod-core >= 1.1 && < 1.2
, warp >= 1.3 && < 1.4
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9.1.4
, transformers >= 0.2.2 && < 0.4
, text >= 0.9
@ -29,9 +29,11 @@ library
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0 && < 1.1
, template-haskell
, yaml >= 0.7 && < 0.8
, network-conduit >= 0.4 && < 0.5
, yaml >= 0.8 && < 0.9
, network-conduit >= 0.5 && < 0.6
, unordered-containers
, hamlet >= 1.1 && < 1.2
, data-default
if !os(windows)
build-depends: unix

44
yesod-form/Yesod/Form/Fields.hs
View File

@ -111,6 +111,7 @@ intField = Field
_ -> Left $ MsgInvalidInteger s
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
|]
}
@ -126,6 +127,7 @@ doubleField = Field
_ -> Left $ MsgInvalidNumber s
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
|]
}
@ -135,6 +137,7 @@ dayField :: RenderMessage master FormMessage => Field sub master Day
dayField = Field
{ fieldParse = blank $ parseDate . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|]
}
@ -144,6 +147,7 @@ timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay
timeField = Field
{ fieldParse = blank $ parseTime . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
|]
}
@ -158,6 +162,7 @@ htmlField :: RenderMessage master FormMessage => Field sub master Html
htmlField = Field
{ fieldParse = blank $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
$newline never
$# FIXME: There was a class="html" attribute, for what purpose?
<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}
|]
@ -186,6 +191,7 @@ textareaField :: RenderMessage master FormMessage => Field sub master Textarea
textareaField = Field
{ fieldParse = blank $ Right . Textarea
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
$newline never
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}
|]
}
@ -195,6 +201,7 @@ hiddenField :: (PathPiece p, RenderMessage master FormMessage)
hiddenField = Field
{ fieldParse = blank $ maybe (Left MsgValueRequired) Right . fromPathPiece
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
$newline never
<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">
|]
}
@ -204,6 +211,7 @@ textField = Field
{ fieldParse = blank $ Right
, fieldView = \theId name attrs val isReq ->
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">
|]
}
@ -212,6 +220,7 @@ passwordField :: RenderMessage master FormMessage => Field sub master Text
passwordField = Field
{ fieldParse = blank $ Right
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">
|]
}
@ -261,6 +270,7 @@ emailField = Field
then Right s
else Left $ MsgInvalidEmail s
, fieldView = \theId name attrs val isReq -> toWidget [hamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">
|]
}
@ -271,11 +281,15 @@ searchField autoFocus = Field
{ fieldParse = blank Right
, fieldView = \theId name attrs val isReq -> do
[whamlet|\
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|]
when autoFocus $ do
-- we want this javascript to be placed immediately after the field
[whamlet|<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}|]
[whamlet|
$newline never
<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}
|]
toWidget [cassius|
#{theId}
-webkit-appearance: textfield
@ -290,6 +304,7 @@ urlField = Field
Just _ -> Right s
, fieldView = \theId name attrs val isReq ->
[whamlet|
$newline never
<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
|]
}
@ -299,9 +314,18 @@ selectFieldList = selectField . optionsPairs
selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
selectField = selectFieldHelper
(\theId name inside -> [whamlet|<select ##{theId} name=#{name}>^{inside}|]) -- outside
(\_theId _name isSel -> [whamlet|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt
(\_theId _name attrs value isSel text -> [whamlet|<option value=#{value} :isSel:selected *{attrs}>#{text}|]) -- inside
(\theId name inside -> [whamlet|
$newline never
<select ##{theId} name=#{name}>^{inside}
|]) -- outside
(\_theId _name isSel -> [whamlet|
$newline never
<option value=none :isSel:selected>_{MsgSelectNone}
|]) -- onOpt
(\_theId _name attrs value isSel text -> [whamlet|
$newline never
<option value=#{value} :isSel:selected *{attrs}>#{text}
|]) -- inside
multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]
multiSelectFieldList = multiSelectField . optionsPairs
@ -323,6 +347,7 @@ multiSelectField ioptlist =
opts <- fmap olOptions $ lift ioptlist
let selOpts = map (id &&& (optselected val)) opts
[whamlet|
$newline never
<select ##{theId} name=#{name} :isReq:required multiple *{attrs}>
$forall (opt, optsel) <- selOpts
<option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
@ -336,13 +361,18 @@ radioFieldList = radioField . optionsPairs
radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a
radioField = selectFieldHelper
(\theId _name inside -> [whamlet|<div ##{theId}>^{inside}|])
(\theId _name inside -> [whamlet|
$newline never
<div ##{theId}>^{inside}
|])
(\theId name isSel -> [whamlet|
$newline never
<div>
<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>
<label for=#{theId}-none>_{MsgSelectNone}
|])
(\theId name attrs value isSel text -> [whamlet|
$newline never
<div>
<input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
<label for=#{theId}-#{value}>#{text}
@ -352,6 +382,7 @@ boolField :: RenderMessage master FormMessage => Field sub master Bool
boolField = Field
{ fieldParse = return . boolParser
, fieldView = \theId name attrs val isReq -> [whamlet|
$newline never
$if not isReq
<input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>
<label for=#{theId}-none>_{MsgSelectNone}
@ -386,6 +417,7 @@ checkBoxField :: RenderMessage m FormMessage => Field s m Bool
checkBoxField = Field
{ fieldParse = return . checkBoxParser
, fieldView = \theId name attrs val _ -> [whamlet|
$newline never
<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>
|]
}
@ -501,6 +533,7 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id'
, fvInput = [whamlet|
$newline never
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|]
, fvErrors = errs
@ -529,6 +562,7 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs
, fvId = id'
, fvInput = [whamlet|
$newline never
<input type=file name=#{name} ##{id'} *{fsAttrs fs}>
|]
, fvErrors = errs

30
yesod-form/Yesod/Form/Functions.hs
View File

@ -55,14 +55,13 @@ import Text.Blaze (Html, toHtml)
import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet)
import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages, FileInfo (..))
import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod)
import Text.Hamlet (shamlet)
import Data.Monoid (mempty)
import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Message (RenderMessage (..))
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as L
import Control.Applicative ((<$>))
import Control.Arrow (first)
@ -188,7 +187,10 @@ postHelper form env = do
let token =
case reqToken req of
Nothing -> mempty
Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
Just n -> [shamlet|
$newline never
<input type=hidden name=#{tokenKey} value=#{n}>
|]
m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form token) m langs env
@ -218,9 +220,7 @@ postEnv = do
else do
(p, f) <- runRequestBody
let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
return $ Just (p', Map.fromList $ filter (notEmpty . snd) f)
where
notEmpty = not . L.null . fileContent
return $ Just (p', Map.fromList f)
runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoToken form = do
@ -246,7 +246,10 @@ getKey = "_hasdata"
getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
getHelper form env = do
let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
let fragment = [shamlet|
$newline never
<input type=hidden name=#{getKey}>
|]
langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
@ -262,6 +265,7 @@ renderTable aform fragment = do
let views = views' []
-- FIXME non-valid HTML
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
@ -286,6 +290,7 @@ renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<div :fvRequired view:.required :not $ fvRequired view:.optional>
@ -321,6 +326,7 @@ renderBootstrap aform fragment = do
has (Just _) = True
has Nothing = False
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
@ -347,13 +353,21 @@ checkM :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg a))
-> Field sub master a
-> Field sub master a
checkM f field = field
checkM f = checkM' f id
checkM' :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg b))
-> (b -> a)
-> Field sub master a
-> Field sub master b
checkM' f inv field = field
{ fieldParse = \ts -> do
e1 <- fieldParse field ts
case e1 of
Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
, fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
}
-- | Allows you to overwrite the error message on parse error.

2
yesod-form/Yesod/Form/Jquery.hs
View File

@ -70,6 +70,7 @@ jqueryDayField jds = Field
. unpack
, fieldView = \theId name attrs val isReq -> do
toWidget [shamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">
|]
addScript' urlJqueryJs
@ -109,6 +110,7 @@ jqueryAutocompleteField src = Field
{ fieldParse = blank $ Right
, fieldView = \theId name attrs val isReq -> do
toWidget [shamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete>
|]
addScript' urlJqueryJs

8
yesod-form/Yesod/Form/MassInput.hs
View File

@ -80,6 +80,7 @@ inputList label fixXml single mdef = formToAForm $ do
, fvTooltip = Nothing
, fvId = theId
, fvInput = [whamlet|
$newline never
^{fixXml views}
<p>
$forall xml <- xmls
@ -100,7 +101,10 @@ withDelete af = do
deleteName <- newFormIdent
(menv, _, _) <- ask
res <- case menv >>= Map.lookup deleteName . fst of
Just ("yes":_) -> return $ Left [whamlet|<input type=hidden name=#{deleteName} value=yes>|]
Just ("yes":_) -> return $ Left [whamlet|
$newline never
<input type=hidden name=#{deleteName} value=yes>
|]
_ -> do
(_, xml2) <- aFormToForm $ areq boolField FieldSettings
{ fsLabel = SomeMessage MsgDelete
@ -127,6 +131,7 @@ massDivs, massTable
:: [[FieldView sub master]]
-> GWidget sub master ()
massDivs viewss = [whamlet|
$newline never
$forall views <- viewss
<fieldset>
$forall view <- views
@ -140,6 +145,7 @@ $forall views <- viewss
|]
massTable viewss = [whamlet|
$newline never
$forall views <- viewss
<fieldset>
<table>

1
yesod-form/Yesod/Form/Nic.hs
View File

@ -38,6 +38,7 @@ nicHtmlField = Field
{ fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe
, fieldView = \theId name attrs val _isReq -> do
toWidget [shamlet|
$newline never
<textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val}
|]
addScript' urlNicEdit

26
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.0.0.4
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -12,19 +12,15 @@ build-type: Simple
homepage: http://www.yesodweb.com/
description: Form handling support for Yesod Web Framework
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, yesod-persistent >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, yesod-persistent >= 1.1 && < 1.2
, time >= 1.1.4
, hamlet >= 1.0 && < 1.1
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0 && < 1.1
, persistent >= 0.9 && < 0.10
, persistent >= 1.0 && < 1.1
, template-haskell
, transformers >= 0.2.2 && < 0.4
, data-default
@ -34,16 +30,10 @@ library
, email-validate >= 0.2.6 && < 0.3
, bytestring >= 0.9.1.4
, text >= 0.9 && < 1.0
, wai >= 1.2 && < 1.3
, wai >= 1.3 && < 1.4
, containers >= 0.2
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
exposed-modules: Yesod.Form
Yesod.Form.Class

14
yesod-json/yesod-json.cabal
View File

@ -1,5 +1,5 @@
name: yesod-json
version: 1.0.1.0
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,19 +14,19 @@ description: Generate content for Yesod using the aeson package.
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, yesod-routes >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, yesod-routes >= 1.1 && < 1.2
, aeson >= 0.5
, text >= 0.8 && < 1.0
, shakespeare-js >= 1.0 && < 1.1
, vector >= 0.9
, containers >= 0.2
, blaze-builder
, attoparsec-conduit >= 0.4 && < 0.5
, conduit >= 0.4 && < 0.5
, attoparsec-conduit >= 0.5 && < 0.6
, conduit >= 0.5 && < 0.6
, transformers >= 0.2.2 && < 0.4
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, bytestring >= 0.9
, safe >= 0.2 && < 0.4
exposed-modules: Yesod.Json

31
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -31,11 +31,8 @@ import qualified Data.ByteString.Char8 as S8
import Data.Text (Text)
import Data.Text.Lazy (toStrict)
import Text.XML
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html.Renderer.Text (renderHtml)
#else
import Text.Blaze.Renderer.Text (renderHtml)
#endif
import qualified Data.Map as Map
newtype RepAtom = RepAtom Content
instance HasReps RepAtom where
@ -55,21 +52,22 @@ template Feed {..} render =
addNS' n = n
namespace = "http://www.w3.org/2005/Atom"
root = Element "feed" [] $ map NodeElement
$ Element "title" [] [NodeContent feedTitle]
: Element "link" [("rel", "self"), ("href", render feedLinkSelf)] []
: Element "link" [("href", render feedLinkHome)] []
: Element "updated" [] [NodeContent $ formatW3 feedUpdated]
: Element "id" [] [NodeContent $ render feedLinkHome]
root = Element "feed" Map.empty $ map NodeElement
$ Element "title" Map.empty [NodeContent feedTitle]
: Element "link" (Map.fromList [("rel", "self"), ("href", render feedLinkSelf)]) []
: Element "link" (Map.singleton "href" $ render feedLinkHome) []
: Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
: Element "id" Map.empty [NodeContent $ render feedLinkHome]
: Element "author" Map.empty [NodeContent feedAuthor]
: map (flip entryTemplate render) feedEntries
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {..} render = Element "entry" [] $ map NodeElement
[ Element "id" [] [NodeContent $ render feedEntryLink]
, Element "link" [("href", render feedEntryLink)] []
, Element "updated" [] [NodeContent $ formatW3 feedEntryUpdated]
, Element "title" [] [NodeContent feedEntryTitle]
, Element "content" [("type", "html")] [NodeContent $ toStrict $ renderHtml feedEntryContent]
entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElement
[ Element "id" Map.empty [NodeContent $ render feedEntryLink]
, Element "link" (Map.singleton "href" $ render feedEntryLink) []
, Element "updated" Map.empty [NodeContent $ formatW3 feedEntryUpdated]
, Element "title" Map.empty [NodeContent feedEntryTitle]
, Element "content" (Map.singleton "type" "html") [NodeContent $ toStrict $ renderHtml feedEntryContent]
]
-- | Generates a link tag in the head of a widget.
@ -77,5 +75,6 @@ atomLink :: Route m
-> Text -- ^ title
-> GWidget s m ()
atomLink r title = toWidgetHead [hamlet|
$newline never
<link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
|]

1
yesod-newsfeed/Yesod/FeedTypes.hs
View File

@ -12,6 +12,7 @@ data Feed url = Feed
{ feedTitle :: Text
, feedLinkSelf :: url
, feedLinkHome :: url
, feedAuthor :: Text
-- | note: currently only used for Rss

34
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -27,11 +27,8 @@ import qualified Data.ByteString.Char8 as S8
import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Text.XML
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html.Renderer.Text (renderHtml)
#else
import Text.Blaze.Renderer.Text (renderHtml)
#endif
import qualified Data.Map as Map
newtype RepRss = RepRss Content
instance HasReps RepRss where
@ -47,26 +44,26 @@ template :: Feed url -> (url -> Text) -> Document
template Feed {..} render =
Document (Prologue [] Nothing []) root []
where
root = Element "rss" [("version", "2.0")] $ return $ NodeElement $ Element "channel" [] $ map NodeElement
$ Element "{http://www.w3.org/2005/Atom}link"
root = Element "rss" (Map.singleton "version" "2.0") $ return $ NodeElement $ Element "channel" Map.empty $ map NodeElement
$ Element "{http://www.w3.org/2005/Atom}link" (Map.fromList
[ ("href", render feedLinkSelf)
, ("rel", "self")
, ("type", pack $ S8.unpack typeRss)
] []
: Element "title" [] [NodeContent feedTitle]
: Element "link" [] [NodeContent $ render feedLinkHome]
: Element "description" [] [NodeContent $ toStrict $ renderHtml feedDescription]
: Element "lastBuildDate" [] [NodeContent $ formatRFC822 feedUpdated]
: Element "language" [] [NodeContent feedLanguage]
]) []
: Element "title" Map.empty [NodeContent feedTitle]
: Element "link" Map.empty [NodeContent $ render feedLinkHome]
: Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedDescription]
: Element "lastBuildDate" Map.empty [NodeContent $ formatRFC822 feedUpdated]
: Element "language" Map.empty [NodeContent feedLanguage]
: map (flip entryTemplate render) feedEntries
entryTemplate :: FeedEntry url -> (url -> Text) -> Element
entryTemplate FeedEntry {..} render = Element "item" [] $ map NodeElement
[ Element "title" [] [NodeContent feedEntryTitle]
, Element "link" [] [NodeContent $ render feedEntryLink]
, Element "guid" [] [NodeContent $ render feedEntryLink]
, Element "pubDate" [] [NodeContent $ formatRFC822 feedEntryUpdated]
, Element "description" [] [NodeContent $ toStrict $ renderHtml feedEntryContent]
entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
[ Element "title" Map.empty [NodeContent feedEntryTitle]
, Element "link" Map.empty [NodeContent $ render feedEntryLink]
, Element "guid" Map.empty [NodeContent $ render feedEntryLink]
, Element "pubDate" Map.empty [NodeContent $ formatRFC822 feedEntryUpdated]
, Element "description" Map.empty [NodeContent $ toStrict $ renderHtml feedEntryContent]
]
-- | Generates a link tag in the head of a widget.
@ -74,5 +71,6 @@ rssLink :: Route m
-> Text -- ^ title
-> GWidget s m ()
rssLink r title = toWidgetHead [hamlet|
$newline never
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|]

23
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -1,5 +1,5 @@
name: yesod-newsfeed
version: 1.0.0.2
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -12,26 +12,17 @@ build-type: Simple
homepage: http://www.yesodweb.com/
description: Helper functions and data types for producing News feeds.
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, time >= 1.1.4
, hamlet >= 1.0 && < 1.1
, hamlet >= 1.1 && < 1.2
, bytestring >= 0.9.1.4
, text >= 0.9 && < 0.12
, xml-conduit >= 0.7 && < 0.8
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, xml-conduit >= 1.0 && < 1.1
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
, containers
exposed-modules: Yesod.AtomFeed
, Yesod.RssFeed

8
yesod-persistent/yesod-persistent.cabal
View File

@ -1,5 +1,5 @@
name: yesod-persistent
version: 1.0.0.1
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,9 +14,9 @@ description: Some helpers for using Persistent from Yesod.
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, persistent >= 0.9 && < 0.10
, persistent-template >= 0.9 && < 0.10
, yesod-core >= 1.1 && < 1.2
, persistent >= 1.0 && < 1.1
, persistent-template >= 1.0 && < 1.1
, transformers >= 0.2.2 && < 0.4
exposed-modules: Yesod.Persist
ghc-options: -Wall

47
yesod-routes/Yesod/Routes/Overlap.hs
View File

@ -2,27 +2,41 @@
module Yesod.Routes.Overlap
( findOverlaps
, findOverlapNames
, Overlap (..)
) where
import Yesod.Routes.TH.Types
import Control.Arrow ((***))
import Data.Maybe (mapMaybe)
import Data.List (intercalate)
findOverlaps :: [Resource t] -> [(Resource t, Resource t)]
findOverlaps [] = []
findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs
data Overlap t = Overlap
{ overlapParents :: [String] -> [String] -- ^ parent resource trees
, overlap1 :: ResourceTree t
, overlap2 :: ResourceTree t
}
findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)
findOverlap x y
| overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)
| otherwise = Nothing
findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
findOverlaps _ [] = []
findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
hasSuffix :: Resource t -> Bool
hasSuffix r =
findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
findOverlap front x y =
here rest
where
here
| overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)
| otherwise = id
rest =
case x of
ResourceParent name _ children -> findOverlaps (front . (name:)) children
ResourceLeaf{} -> []
hasSuffix :: ResourceTree t -> Bool
hasSuffix (ResourceLeaf r) =
case resourceDispatch r of
Subsite{} -> True
Methods Just{} _ -> True
Methods Nothing _ -> False
hasSuffix ResourceParent{} = True
overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
@ -50,9 +64,14 @@ piecesOverlap :: Piece t -> Piece t -> Bool
piecesOverlap (Static x) (Static y) = x == y
piecesOverlap _ _ = True
findOverlapNames :: [Resource t] -> [(String, String)]
findOverlapNames = map (resourceName *** resourceName) . findOverlaps
findOverlapNames :: [ResourceTree t] -> [(String, String)]
findOverlapNames =
map go . findOverlaps id
where
go (Overlap front x y) =
(go' $ resourceTreeName x, go' $ resourceTreeName y)
where
go' = intercalate "/" . front . return
{-
-- n^2, should be a way to speed it up
findOverlaps :: [Resource a] -> [[Resource a]]

32
yesod-routes/Yesod/Routes/Parse.hs
View File

@ -10,7 +10,6 @@ module Yesod.Routes.Parse
) where
import Language.Haskell.TH.Syntax
import Data.Maybe
import Data.Char (isUpper)
import Language.Haskell.TH.Quote
import qualified System.IO as SIO
@ -55,18 +54,29 @@ parseRoutesNoCheck = QuasiQuoter
-- | Convert a multi-line string to a set of resources. See documentation for
-- the format of this string. This is a partial function which calls 'error' on
-- invalid input.
resourcesFromString :: String -> [Resource String]
resourcesFromString :: String -> [ResourceTree String]
resourcesFromString =
mapMaybe go . lines
fst . parse 0 . lines
where
go s =
case takeWhile (/= "--") $ words s of
(pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
disp = dispatchFromString rest mmulti
in Just $ Resource constr pieces disp
[] -> Nothing
_ -> error $ "Invalid resource line: " ++ s
parse _ [] = ([], [])
parse indent (thisLine:otherLines)
| length spaces < indent = ([], thisLine : otherLines)
| otherwise = (this others, remainder)
where
spaces = takeWhile (== ' ') thisLine
(others, remainder) = parse indent otherLines'
(this, otherLines') =
case takeWhile (/= "--") $ words thisLine of
[pattern, constr] | last constr == ':' ->
let (children, otherLines'') = parse (length spaces + 1) otherLines
(pieces, Nothing) = piecesFromString $ drop1Slash pattern
in ((ResourceParent (init constr) pieces children :), otherLines'')
(pattern:constr:rest) ->
let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
disp = dispatchFromString rest mmulti
in ((ResourceLeaf (Resource constr pieces disp):), otherLines)
[] -> (id, otherLines)
_ -> error $ "Invalid resource line: " ++ thisLine
dispatchFromString :: [String] -> Maybe String -> Dispatch String
dispatchFromString rest mmulti

58
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -17,6 +17,16 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Control.Applicative ((<$>))
import Data.List (foldl')
data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
flatten :: [ResourceTree a] -> [FlatResource a]
flatten =
concatMap (go id)
where
go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
go front (ResourceParent name pieces children) =
concatMap (go (front . ((name, pieces):))) children
-- |
--
-- This function will generate a single clause that will address all
@ -83,9 +93,9 @@ import Data.List (foldl')
mkDispatchClause :: Q Exp -- ^ runHandler function
-> Q Exp -- ^ dispatcher function
-> Q Exp -- ^ fixHandler function
-> [Resource a]
-> [ResourceTree a]
-> Q Clause
mkDispatchClause runHandler dispatcher fixHandler ress = do
mkDispatchClause runHandler dispatcher fixHandler ress' = do
-- Allocate the names to be used. Start off with the names passed to the
-- function itself (with a 0 suffix).
--
@ -130,22 +140,25 @@ mkDispatchClause runHandler dispatcher fixHandler ress = do
Nothing -> $(return $ VarE app4040)
|]
return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
where
ress = flatten ress'
-- | Determine the name of the method map for a given resource name.
methodMapName :: String -> Name
methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: Q Exp -- ^ fixHandler
-> Resource a
-> FlatResource a
-> Q (Maybe Dec)
buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
fromList <- [|Map.fromList|]
methods' <- mapM go methods
let exp = fromList `AppE` ListE methods'
let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
return $ Just fun
where
pieces = concat $ map snd parents ++ [pieces']
go method = do
fh <- fixHandler
let func = VarE $ mkName $ map toLower method ++ name
@ -156,28 +169,31 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
xs <- replicateM argCount $ newName "arg"
let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
return $ TupE [pack' `AppE` LitE (StringL method), rhs]
buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
-- | Build a single 'D.Route' expression.
buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp
buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
-- First two arguments to D.Route
routePieces <- ListE <$> mapM (convertPiece . snd) resPieces
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
where
allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> [(String, [(CheckOverlap, Piece a)])]
-> String -- ^ name of resource
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
pieces <- newName "pieces"
-- Allocate input piece variables (xs) and variables that have been
@ -216,7 +232,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
_ -> return ([], [])
-- The final expression that actually uses the values we've computed
caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
-- Put together all the statements
just <- [|Just|]
@ -239,11 +255,12 @@ buildCaller :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> Name -- ^ xrest
-> [(String, [(CheckOverlap, Piece a)])]
-> String -- ^ name of resource
-> Dispatch a
-> [Name] -- ^ ys
-> Q Exp
buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
master <- newName "master"
sub <- newName "sub"
toMaster <- newName "toMaster"
@ -254,7 +271,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
let pat = map VarP [master, sub, toMaster, app404, handler405, method]
-- Create the route
let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
let route = routeFromDynamics parents name ys
exp <-
case resDisp of
@ -309,3 +326,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
-> String -- ^ constructor name
-> [Name]
-> Exp
routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
isDynamic Dynamic{} = True
isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys']

62
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
View File

@ -14,17 +14,19 @@ import Control.Monad (replicateM)
import Data.Text (pack)
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Yesod.Routes.Class
import Data.Monoid (mconcat)
-- | Generate the constructors of a route data type.
mkRouteCons :: [Resource Type] -> [Con]
mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])
mkRouteCons =
map mkRouteCon
mconcat . map mkRouteCon
where
mkRouteCon res =
NormalC (mkName $ resourceName res)
mkRouteCon (ResourceLeaf res) =
([con], [])
where
con = NormalC (mkName $ resourceName res)
$ map (\x -> (NotStrict, x))
$ concat [singles, multi, sub]
where
singles = concatMap (toSingle . snd) $ resourcePieces res
toSingle Static{} = []
toSingle (Dynamic typ) = [typ]
@ -35,16 +37,53 @@ mkRouteCons =
case resourceDispatch res of
Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
_ -> []
mkRouteCon (ResourceParent name pieces children) =
([con], dec : decs)
where
(cons, decs) = mkRouteCons children
con = NormalC (mkName name)
$ map (\x -> (NotStrict, x))
$ concat [singles, [ConT $ mkName name]]
dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]
singles = concatMap (toSingle . snd) pieces
toSingle Static{} = []
toSingle (Dynamic typ) = [typ]
-- | Clauses for the 'renderRoute' method.
mkRenderRouteClauses :: [Resource Type] -> Q [Clause]
mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]
mkRenderRouteClauses =
mapM go
where
isDynamic Dynamic{} = True
isDynamic _ = False
go res = do
go (ResourceParent name pieces children) = do
let cnt = length $ filter (isDynamic . snd) pieces
dyns <- replicateM cnt $ newName "dyn"
child <- newName "child"
let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]
pack' <- [|pack|]
tsp <- [|toPathPiece|]
let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns
childRender <- newName "childRender"
let rr = VarE childRender
childClauses <- mkRenderRouteClauses children
a <- newName "a"
b <- newName "b"
colon <- [|(:)|]
let cons y ys = InfixE (Just y) colon (Just ys)
let pieces' = foldr cons (VarE a) piecesSingle
let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)
return $ Clause [pat] (NormalB body) [FunD childRender childClauses]
go (ResourceLeaf res) = do
let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
dyns <- replicateM cnt $ newName "dyn"
sub <-
@ -93,18 +132,19 @@ mkRenderRouteClauses =
-- This includes both the 'Route' associated type and the
-- 'renderRoute' method. This function uses both 'mkRouteCons' and
-- 'mkRenderRouteClasses'.
mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec
mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance = mkRenderRouteInstance' []
-- | A more general version of 'mkRenderRouteInstance' which takes an
-- additional context.
mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec
mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]
mkRenderRouteInstance' cxt typ ress = do
cls <- mkRenderRouteClauses ress
let (cons, decs) = mkRouteCons ress
return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)
[ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
[ DataInstD [] ''Route [typ] cons clazzes
, FunD (mkName "renderRoute") cls
]
] : decs
where
clazzes = [''Show, ''Eq, ''Read]

21
yesod-routes/Yesod/Routes/TH/Types.hs
View File

@ -2,16 +2,37 @@
module Yesod.Routes.TH.Types
( -- * Data types
Resource (..)
, ResourceTree (..)
, Piece (..)
, Dispatch (..)
, CheckOverlap
-- ** Helper functions
, resourceMulti
, resourceTreePieces
, resourceTreeName
) where
import Language.Haskell.TH.Syntax
import Control.Arrow (second)
data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]
resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]
resourceTreePieces (ResourceLeaf r) = resourcePieces r
resourceTreePieces (ResourceParent _ x _) = x
resourceTreeName :: ResourceTree typ -> String
resourceTreeName (ResourceLeaf r) = resourceName r
resourceTreeName (ResourceParent x _ _) = x
instance Functor ResourceTree where
fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)
fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c
instance Lift t => Lift (ResourceTree t) where
lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]
lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]
data Resource typ = Resource
{ resourceName :: String
, resourcePieces :: [(CheckOverlap, Piece typ)]

103
yesod-routes/test/Hierarchy.hs Normal file
View File

@ -0,0 +1,103 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hierarchy
( hierarchy
, Dispatcher (..)
, RunHandler (..)
, Handler
, App
, toText
) where
import Test.Hspec.Monadic
import Test.Hspec.HUnit ()
import Test.HUnit
import Yesod.Routes.Parse
import Yesod.Routes.TH
import Yesod.Routes.Class
import Language.Haskell.TH.Syntax
import qualified Yesod.Routes.Class as YRC
import Data.Text (Text, pack, append)
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
type Handler sub master = Text
type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where
dispatcher
:: master
-> sub
-> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page
-> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method
-> [Text]
-> App sub master
class RunHandler sub master where
runHandler
:: Handler sub master
-> master
-> sub
-> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master)
-> App sub master
data Hierarchy = Hierarchy
do
let resources = [parseRoutes|
/ HomeR GET
/admin/#Int AdminR:
/ AdminRootR GET
/login LoginR GET POST
/table/#Text TableR GET
|]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources
return
$ InstanceD
[]
(ConT ''Dispatcher
`AppT` ConT ''Hierarchy
`AppT` ConT ''Hierarchy)
[FunD (mkName "dispatcher") [dispatch]]
: rrinst
getHomeR :: Handler sub master
getHomeR = "home"
getAdminRootR :: Int -> Handler sub master
getAdminRootR i = pack $ "admin root: " ++ show i
getLoginR :: Int -> Handler sub master
getLoginR i = pack $ "login: " ++ show i
postLoginR :: Int -> Handler sub master
postLoginR i = pack $ "post login: " ++ show i
getTableR :: Int -> Text -> Handler sub master
getTableR _ t = append "TableR " t
instance RunHandler Hierarchy master where
runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
hierarchy :: Specs
hierarchy = describe "hierarchy" $ do
it "renders root correctly" $
renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
it "renders table correctly" $
renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

38
yesod-routes/test/main.hs
View File

@ -20,12 +20,7 @@ import Yesod.Routes.Parse (parseRoutesNoCheck)
import Yesod.Routes.Overlap (findOverlapNames)
import Yesod.Routes.TH hiding (Dispatch)
import Language.Haskell.TH.Syntax
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
import Hierarchy
result :: ([Text] -> Maybe Int) -> Dispatch Int
result f ts = f ts
@ -101,32 +96,9 @@ instance RenderRoute MySubParam where
getMySubParam :: MyApp -> Int -> MySubParam
getMySubParam _ = MySubParam
type Handler sub master = Text
type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where
dispatcher
:: master
-> sub
-> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page
-> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method
-> [Text]
-> App sub master
class RunHandler sub master where
runHandler
:: Handler sub master
-> master
-> sub
-> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master)
-> App sub master
do
texts <- [t|[Text]|]
let ress =
let ress = map ResourceLeaf
[ Resource "RootR" [] $ Methods Nothing ["GET"]
, Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]
, Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []
@ -137,14 +109,13 @@ do
rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
return
[ rrinst
, InstanceD
$ InstanceD
[]
(ConT ''Dispatcher
`AppT` ConT ''MyApp
`AppT` ConT ''MyApp)
[FunD (mkName "dispatcher") [dispatch]]
]
: rrinst
instance RunHandler MyApp master where
runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
@ -328,6 +299,7 @@ main = hspecX $ do
/bar/baz Foo3
|]
findOverlapNames routes @?= []
hierarchy
getRootR :: Text
getRootR = pack "this is the root"

5
yesod-routes/yesod-routes.cabal
View File

@ -1,5 +1,5 @@
name: yesod-routes
version: 1.0.1.2
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -36,12 +36,13 @@ test-suite runtests
type: exitcode-stdio-1.0
main-is: main.hs
hs-source-dirs: test
other-modules: Hierarchy
build-depends: base >= 4.3 && < 5
, yesod-routes
, text >= 0.5 && < 0.12
, HUnit >= 1.2 && < 1.3
, hspec >= 0.6 && < 1.2
, hspec >= 1.2 && < 1.3
, containers
, template-haskell
, path-pieces

13
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -30,6 +30,7 @@ import Data.Time (UTCTime)
import Data.Monoid (mappend)
import Text.XML
import Data.Text (Text, pack)
import qualified Data.Map as Map
data SitemapChangeFreq = Always
| Hourly
@ -66,13 +67,13 @@ template urls render =
addNS' n = n
namespace = "http://www.sitemaps.org/schemas/sitemap/0.9"
root = Element "urlset" [] $ map go urls
root = Element "urlset" Map.empty $ map go urls
go SitemapUrl {..} = NodeElement $ Element "url" [] $ map NodeElement
[ Element "loc" [] [NodeContent $ render sitemapLoc]
, Element "lastmod" [] [NodeContent $ formatW3 sitemapLastMod]
, Element "changefreq" [] [NodeContent $ showFreq sitemapChangeFreq]
, Element "priority" [] [NodeContent $ pack $ show sitemapPriority]
go SitemapUrl {..} = NodeElement $ Element "url" Map.empty $ map NodeElement
[ Element "loc" Map.empty [NodeContent $ render sitemapLoc]
, Element "lastmod" Map.empty [NodeContent $ formatW3 sitemapLastMod]
, Element "changefreq" Map.empty [NodeContent $ showFreq sitemapChangeFreq]
, Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
]
sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml

7
yesod-sitemap/yesod-sitemap.cabal
View File

@ -1,5 +1,5 @@
name: yesod-sitemap
version: 1.0.0.1
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,10 +14,11 @@ description: Generate XML sitemaps.
library
build-depends: base >= 4 && < 5
, yesod-core >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, time >= 1.1.4
, xml-conduit >= 0.7 && < 0.8
, xml-conduit >= 1.0 && < 1.1
, text
, containers
exposed-modules: Yesod.Sitemap
ghc-options: -Wall

35
yesod-static/Yesod/Static.hs
View File

@ -78,19 +78,15 @@ import System.Posix.Types (EpochTime)
import Data.Conduit (($$))
import Data.Conduit.List (sourceList)
import Data.Functor.Identity (runIdentity)
import qualified Filesystem.Path.CurrentOS as F
import Network.Wai.Application.Static
( StaticSettings (..)
, defaultWebAppSettings
, staticApp
, embeddedLookup
, toEmbedded
, toFilePath
, fromFilePath
, FilePath
, ETagLookup
, webAppSettingsWithLookup
, embeddedSettings
)
import WaiAppStatic.Storage.Filesystem (ETagLookup)
-- | Type used for the subsite with static contents.
newtype Static = Static StaticSettings
@ -106,7 +102,7 @@ type StaticRoute = Route Static
static :: Prelude.FilePath -> IO Static
static dir = do
hashLookup <- cachedETagLookup dir
return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
-- | Same as 'static', but does not assumes that the files do not
-- change and checks their modification time whenever a request
@ -114,7 +110,7 @@ static dir = do
staticDevel :: Prelude.FilePath -> IO Static
staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
-- | Produce a 'Static' based on embedding all of the static
-- files' contents in the executable at compile time.
@ -126,10 +122,7 @@ staticDevel dir = do
-- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround.
-- This will cause yesod to embed those assets into the generated HTML file itself.
embed :: Prelude.FilePath -> Q Exp
embed fp =
[|Static (defaultWebAppSettings
{ ssFolder = embeddedLookup (toEmbedded $(embedDir fp))
})|]
embed fp = [|Static (embeddedSettings $(embedDir fp))|]
instance RenderRoute Static where
-- | A route on the static subsite (see also 'staticFiles').
@ -152,10 +145,10 @@ instance RenderRoute Static where
instance Yesod master => YesodDispatch Static master where
-- Need to append trailing slash to make relative links work
yesodDispatch _ _ _ _ _ _ [] _ req =
yesodDispatch _ _ _ _ _ _ _ [] _ req =
return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
yesodDispatch _ (Static set) _ _ _ _ textPieces _ req =
yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req =
staticApp set req { pathInfo = textPieces }
notHidden :: Prelude.FilePath -> Bool
@ -233,18 +226,18 @@ publicFiles :: Prelude.FilePath -> Q [Dec]
publicFiles dir = mkStaticFiles' dir "StaticRoute" False
mkHashMap :: Prelude.FilePath -> IO (M.Map FilePath S8.ByteString)
mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)
mkHashMap dir = do
fs <- getFileListPieces dir
hashAlist fs >>= return . M.fromList
where
hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)]
hashAlist fs = mapM hashPair fs
where
hashPair :: [String] -> IO (FilePath, S8.ByteString)
hashPair :: [String] -> IO (F.FilePath, S8.ByteString)
hashPair pieces = do let file = pathFromRawPieces dir pieces
h <- base64md5File file
return (toFilePath file, S8.pack h)
return (F.decodeString file, S8.pack h)
pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath
pathFromRawPieces =
@ -255,12 +248,12 @@ pathFromRawPieces =
cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup
cachedETagLookupDevel dir = do
etags <- mkHashMap dir
mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime)
mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime)
return $ \f ->
case M.lookup f etags of
Nothing -> return Nothing
Just checksum -> do
fs <- getFileStatus $ fromFilePath f
fs <- getFileStatus $ F.encodeString f
let newt = modificationTime fs
mtimes <- readIORef mtimeVar
oldt <- case M.lookup f mtimes of

18
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static
version: 1.0.0.3
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -19,22 +19,23 @@ library
build-depends: base >= 4 && < 5
, containers >= 0.2
, old-time >= 1.0
, yesod-core >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, base64-bytestring >= 0.1.0.1 && < 0.2
, cereal >= 0.3 && < 0.4
, bytestring >= 0.9.1.4
, template-haskell
, directory >= 1.0 && < 1.2
, transformers >= 0.2.2 && < 0.4
, wai-app-static >= 1.2 && < 1.3
, wai >= 1.2 && < 1.3
, wai-app-static >= 1.3 && < 1.4
, wai >= 1.3 && < 1.4
, text >= 0.9 && < 1.0
, file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.6.5 && < 0.7
, http-types >= 0.7 && < 0.8
, unix-compat >= 0.2
, conduit >= 0.4 && < 0.5
, crypto-conduit >= 0.3 && < 0.4
, conduit >= 0.5 && < 0.6
, crypto-conduit >= 0.4 && < 0.5
, cryptohash >= 0.6.1
, system-filepath >= 0.4.6 && < 0.5
exposed-modules: Yesod.Static
ghc-options: -Wall
@ -60,11 +61,12 @@ test-suite tests
, wai
, text >= 0.9 && < 1.0
, file-embed >= 0.0.4.1 && < 0.5
, http-types >= 0.6.5 && < 0.7
, http-types
, unix-compat >= 0.2
, conduit
, crypto-conduit
, cryptohash >= 0.6.1
, system-filepath
ghc-options: -Wall

108
yesod-test/Yesod/Test.hs
View File

@ -69,6 +69,7 @@ import qualified Test.Hspec.Runner as Runner
import qualified Data.List as DL
import qualified Data.Maybe as DY
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy.Char8 as BSL8
@ -77,7 +78,6 @@ import qualified Test.Hspec.HUnit ()
import qualified Network.HTTP.Types as H
import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI)
import Text.XML.HXT.Core hiding (app, err)
import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader)
import qualified Control.Monad.Trans.State as ST
@ -88,6 +88,8 @@ import Database.Persist.GenericSql
import Data.Monoid (mappend)
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Text.XML.Cursor hiding (element)
import qualified Text.HTML.DOM as HD
-- | The state used in 'describe' to build a list of specs
data SpecsData = SpecsData Application ConnectionPool [Core.Spec]
@ -105,8 +107,8 @@ data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse)
-- | Request parts let us discern regular key/values from files sent in the request.
data RequestPart
= ReqPlainPart String String
| ReqFilePart String FilePath BSL8.ByteString String
= ReqPlainPart T.Text T.Text
| ReqFilePart T.Text FilePath BSL8.ByteString T.Text
-- | The RequestBuilder state monad constructs an url encoded string of arguments
-- to send with your requests. Some of the functions that run on it use the current
@ -123,7 +125,7 @@ instance HoldsResponse OneSpecData where
instance HoldsResponse RequestBuilderData where
readResponse (RequestBuilderData _ x) = x
type CookieValue = H.Ascii
type CookieValue = ByteString
-- | Runs your test suite, using you wai 'Application' and 'ConnectionPool' for performing
-- the database queries in your tests.
@ -136,12 +138,7 @@ type CookieValue = H.Ascii
runTests :: Application -> ConnectionPool -> Specs -> IO ()
runTests app connection specsDef = do
(SpecsData _ _ specs) <- ST.execStateT specsDef (SpecsData app connection [])
#if MIN_VERSION_hspec(1,2,0)
Runner.hspec
#else
Runner.hspecX
#endif
specs
Runner.hspec specs
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool'
@ -168,14 +165,14 @@ withResponse f = maybe err f =<< fmap readResponse ST.get
-- | Use HXT to parse a value from an html tag.
-- Check for usage examples in this module's source.
parseHTML :: Html -> LA XmlTree a -> [a]
parseHTML html p = runLA (hread >>> p ) (TL.unpack $ decodeUtf8 html)
parseHTML :: Html -> (Cursor -> [a]) -> [a]
parseHTML html p = p $ fromDocument $ HD.parseLBS html
-- | Query the last response using css selectors, returns a list of matched fragments
htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html]
htmlQuery query = withResponse $ \ res ->
case findBySelector (simpleBody res) query of
Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err)
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
Right matches -> return $ map (encodeUtf8 . TL.pack) matches
-- | Asserts that the two given values are equal.
@ -194,7 +191,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } ->
assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO ()
assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of
Nothing -> failure $ concat
Nothing -> failure $ T.pack $ concat
[ "Expected header "
, show header
, " to be "
@ -215,7 +212,7 @@ assertNoHeader :: HoldsResponse a => CI BS8.ByteString -> ST.StateT a IO ()
assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->
case lookup header h of
Nothing -> return ()
Just s -> failure $ concat
Just s -> failure $ T.pack $ concat
[ "Unexpected header "
, show header
, " containing "
@ -245,7 +242,7 @@ htmlAllContain :: HoldsResponse a => Query -> String -> ST.StateT a IO ()
htmlAllContain query search = do
matches <- htmlQuery query
case matches of
[] -> failure $ "Nothing matched css query: "++T.unpack query
[] -> failure $ "Nothing matched css query: " <> query
_ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
@ -269,7 +266,7 @@ printMatches query = do
liftIO $ hPutStrLn stderr $ show matches
-- | Add a parameter with the given name and value.
byName :: String -> String -> RequestBuilder ()
byName :: T.Text -> T.Text -> RequestBuilder ()
byName name value = do
RequestBuilderData parts r <- ST.get
ST.put $ RequestBuilderData ((ReqPlainPart name value):parts) r
@ -277,50 +274,67 @@ byName name value = do
-- | Add a file to be posted with the current request
--
-- Adding a file will automatically change your request content-type to be multipart/form-data
fileByName :: String -> FilePath -> String -> RequestBuilder ()
fileByName :: T.Text -> FilePath -> T.Text -> RequestBuilder ()
fileByName name path mimetype = do
RequestBuilderData parts r <- ST.get
contents <- liftIO $ BSL8.readFile path
ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r
-- This looks up the name of a field based on the contents of the label pointing to it.
nameFromLabel :: String -> RequestBuilder String
nameFromLabel :: T.Text -> RequestBuilder T.Text
nameFromLabel label = withResponse $ \ res -> do
let
body = simpleBody res
escaped = escapeHtmlEntities label
mfor = parseHTML body $ deep $ hasName "label"
>>> filterA (xshow this >>> mkText >>> hasText (DL.isInfixOf escaped))
>>> getAttrValue "for"
mfor = parseHTML body $ \c -> c
$// attributeIs "name" "label"
>=> contentContains escaped
>=> attribute "for"
contentContains x c
| x `T.isInfixOf` T.concat (c $// content) = [c]
| otherwise = []
case mfor of
for:[] -> do
let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name"
let mname = parseHTML body $ \c -> c
$// attributeIs "id" for
>=> attribute "name"
case mname of
"":_ -> failure $ "Label "++label++" resolved to id "++for++" which was not found. "
"":_ -> failure $ T.concat
[ "Label "
, label
, " resolved to id "
, for
, " which was not found. "
]
name:_ -> return name
_ -> failure $ "More than one input with id " ++ for
[] -> failure $ "No label contained: "++label
_ -> failure $ "More than one label contained "++label
_ -> failure $ "More than one input with id " <> for
[] -> failure $ "No label contained: " <> label
_ -> failure $ "More than one label contained " <> label
(<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append
-- | Escape HTML entities in a string, so you can write the text you want in
-- label lookups without worrying about the fact that yesod escapes some characters.
escapeHtmlEntities :: String -> String
escapeHtmlEntities "" = ""
escapeHtmlEntities (c:cs) = case c of
'<' -> '&' : 'l' : 't' : ';' : escapeHtmlEntities cs
'>' -> '&' : 'g' : 't' : ';' : escapeHtmlEntities cs
'&' -> '&' : 'a' : 'm' : 'p' : ';' : escapeHtmlEntities cs
'"' -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeHtmlEntities cs
'\'' -> '&' : '#' : '3' : '9' : ';' : escapeHtmlEntities cs
x -> x : escapeHtmlEntities cs
escapeHtmlEntities :: T.Text -> T.Text
escapeHtmlEntities =
T.concatMap go
where
go '<' = "&lt;"
go '>' = "&gt;"
go '&' = "&amp;"
go '"' = "&quot;"
go '\'' = "&#39;"
go x = T.singleton x
byLabel :: String -> String -> RequestBuilder ()
byLabel :: T.Text -> T.Text -> RequestBuilder ()
byLabel label value = do
name <- nameFromLabel label
byName name value
fileByLabel :: String -> FilePath -> String -> RequestBuilder ()
fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder ()
fileByLabel label path mime = do
name <- nameFromLabel label
fileByName name path mime
@ -332,7 +346,7 @@ addNonce_ scope = do
matches <- htmlQuery $ scope `mappend` "input[name=_token][type=hidden][value]"
case matches of
[] -> failure $ "No nonce found in the current page"
element:[] -> byName "_token" $ head $ parseHTML element $ getAttrValue "value"
element:[] -> byName "_token" $ head $ parseHTML element $ attribute "value"
_ -> failure $ "More than one nonce found in the page"
-- | For responses that display a single form, just lookup the only nonce available.
@ -384,22 +398,22 @@ doRequest method url paramsBuild = do
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
multipartPart (ReqPlainPart k v) = BS8.concat
[ "Content-Disposition: form-data; "
, "name=\"", (BS8.pack k), "\"\r\n\r\n"
, (BS8.pack v), "\r\n"]
, "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
, TE.encodeUtf8 v, "\r\n"]
multipartPart (ReqFilePart k v bytes mime) = BS8.concat
[ "Content-Disposition: form-data; "
, "name=\"", BS8.pack k, "\"; "
, "name=\"", TE.encodeUtf8 k, "\"; "
, "filename=\"", BS8.pack v, "\"\r\n"
, "Content-Type: ", BS8.pack mime, "\r\n\r\n"
, "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
, BS8.concat $ BSL8.toChunks bytes, "\r\n"]
-- For building the regular non-multipart requests
makeSinglepart cookie parts = SRequest (mkRequest
[("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $
BSL8.pack $ DL.concat $ DL.intersperse "&" $ map singlepartPart parts
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts
singlepartPart (ReqFilePart _ _ _ _) = ""
singlepartPart (ReqPlainPart k v) = concat [k,"=",v]
singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]
-- General request making
mkRequest headers = defaultRequest
@ -418,5 +432,5 @@ runDB query = do
liftIO $ runSqlPool query pool
-- Yes, just a shortcut
failure :: (MonadIO a) => String -> a b
failure reason = (liftIO $ HUnit.assertFailure reason) >> error ""
failure :: (MonadIO a) => T.Text -> a b
failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""

14
yesod-test/Yesod/Test/HtmlParse.hs
View File

@ -1,14 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Parse an HTML document into xml-conduit's Document.
--
-- Assumes UTF-8 encoding.
module Yesod.Test.HtmlParse
( parseHtml
) where
import qualified Data.ByteString.Lazy as L
import Text.XML (Document)
import qualified Text.HTML.DOM as HD
parseHtml :: L.ByteString -> Either String Document
parseHtml = Right . HD.parseLBS

5
yesod-test/Yesod/Test/TransversingCSS.hs
View File

@ -41,11 +41,11 @@ where
import Yesod.Test.CssQuery
import qualified Data.Text as T
import Yesod.Test.HtmlParse (parseHtml)
import Control.Applicative ((<$>), (<*>))
import Text.XML
import Text.XML.Cursor
import qualified Data.ByteString.Lazy as L
import qualified Text.HTML.DOM as HD
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Html.Renderer.String (renderHtml)
@ -53,7 +53,6 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
import Text.Blaze (toHtml)
import Text.Blaze.Renderer.String (renderHtml)
#endif
import Text.XML.Xml2Html ()
type Query = T.Text
type Html = L.ByteString
@ -65,7 +64,7 @@ type Html = L.ByteString
-- * Right: List of matching Html fragments.
findBySelector :: Html -> Query -> Either String [String]
findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x)
<$> (fromDocument <$> parseHtml html)
<$> (Right $ fromDocument $ HD.parseLBS html)
<*> parseQuery query
-- Run a compiled query on Html, returning a list of matching Html fragments.

35
yesod-test/test/main.hs
View File

@ -6,23 +6,18 @@ import Test.Hspec.HUnit ()
import Yesod.Test.CssQuery
import Yesod.Test.TransversingCSS
import Yesod.Test.HtmlParse
import Text.XML
import Data.ByteString.Lazy.Char8 ()
import qualified Data.Map as Map
import qualified Text.HTML.DOM as HD
parseQuery_ = either error id . parseQuery
findBySelector_ x = either error id . findBySelector x
parseHtml_ = either error id . parseHtml
parseHtml_ = HD.parseLBS
main :: IO ()
main =
#if MIN_VERSION_hspec(1,2,0)
hspec
#else
hspecX
#endif
$ do
main = hspec $ do
describe "CSS selector parsing" $ do
it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]]
it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]]
@ -40,13 +35,13 @@ main =
it "XHTML" $
let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"
doc = Document (Prologue [] Nothing []) root []
root = Element "html" []
[ NodeElement $ Element "head" []
[ NodeElement $ Element "title" []
root = Element "html" Map.empty
[ NodeElement $ Element "head" Map.empty
[ NodeElement $ Element "title" Map.empty
[NodeContent "foo"]
]
, NodeElement $ Element "body" []
[ NodeElement $ Element "p" []
, NodeElement $ Element "body" Map.empty
[ NodeElement $ Element "p" Map.empty
[NodeContent "Hello World"]
]
]
@ -54,14 +49,14 @@ main =
it "HTML" $
let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>"
doc = Document (Prologue [] Nothing []) root []
root = Element "html" []
[ NodeElement $ Element "head" []
[ NodeElement $ Element "title" []
root = Element "html" Map.empty
[ NodeElement $ Element "head" Map.empty
[ NodeElement $ Element "title" Map.empty
[NodeContent "foo"]
]
, NodeElement $ Element "body" []
[ NodeElement $ Element "br" [] []
, NodeElement $ Element "p" []
, NodeElement $ Element "body" Map.empty
[ NodeElement $ Element "br" Map.empty []
, NodeElement $ Element "p" Map.empty
[NodeContent "Hello World"]
]
]

36
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test
version: 0.2.1
version: 0.3.0
license: MIT
license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar>
@ -13,44 +13,30 @@ homepage: http://www.yesodweb.com
description: Behaviour Oriented integration Testing for Yesod Applications
extra-source-files: README.md, LICENSE, test/main.hs
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
build-depends: base >= 4.3 && < 5
, hxt >= 9.1.6
, attoparsec >= 0.10 && < 0.11
, persistent >= 0.9 && < 0.10
, persistent >= 1.0 && < 1.1
, transformers >= 0.2.2 && < 0.4
, wai >= 1.2 && < 1.3
, wai-test >= 1.2 && < 1.3
, wai >= 1.3 && < 1.4
, wai-test >= 1.3 && < 1.4
, network >= 2.2 && < 2.4
, http-types >= 0.6 && < 0.7
, http-types >= 0.7 && < 0.8
, HUnit >= 1.2 && < 1.3
, hspec >= 1.1 && < 1.3
, hspec >= 1.2 && < 1.3
, bytestring >= 0.9
, case-insensitive >= 0.2
, text
, xml-conduit >= 0.7 && < 0.8
, xml-conduit >= 1.0 && < 1.1
, xml-types >= 0.3 && < 0.4
, containers
, xml2html >= 0.1.2.3 && < 0.2
, html-conduit >= 0.0.1 && < 0.1
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, html-conduit >= 0.1 && < 0.2
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
exposed-modules: Yesod.Test
Yesod.Test.CssQuery
Yesod.Test.TransversingCSS
Yesod.Test.HtmlParse
ghc-options: -Wall
test-suite test
@ -63,6 +49,8 @@ test-suite test
, HUnit
, xml-conduit
, bytestring
, containers
, html-conduit
source-repository head
type: git

113
yesod/AddHandler.hs Normal file
View File

@ -0,0 +1,113 @@
module AddHandler (addHandler) where
import Prelude hiding (readFile)
import System.IO (hFlush, stdout)
import Data.Char (isLower, toLower, isSpace)
import Data.List (isPrefixOf, isSuffixOf)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import System.Directory (getDirectoryContents)
-- strict readFile
readFile :: FilePath -> IO String
readFile = fmap T.unpack . TIO.readFile
addHandler :: IO ()
addHandler = do
allFiles <- getDirectoryContents "."
cabal <-
case filter (".cabal" `isSuffixOf`) allFiles of
[x] -> return x
[] -> error "No cabal file found"
_ -> error "Too many cabal files found"
putStr "Name of route (without trailing R): "
hFlush stdout
name <- getLine
case name of
[] -> error "Please provide a name"
c:_
| isLower c -> error "Name must start with an upper case letter"
| otherwise -> return ()
putStr "Enter route pattern: "
hFlush stdout
pattern <- getLine
putStr "Enter space-separated list of methods: "
hFlush stdout
methods <- getLine
let modify fp f = readFile fp >>= writeFile fp . f
modify "Application.hs" $ fixApp name
modify cabal $ fixCabal name
modify "config/routes" $ fixRoutes name pattern methods
writeFile ("Handler/" ++ name ++ ".hs") $ mkHandler name pattern methods
fixApp :: String -> String -> String
fixApp name =
unlines . reverse . go . reverse . lines
where
l = "import Handler." ++ name
go [] = [l]
go (x:xs)
| "import Handler." `isPrefixOf` x = l : x : xs
| otherwise = x : go xs
fixCabal :: String -> String -> String
fixCabal name =
unlines . reverse . go . reverse . lines
where
l = "import Handler." ++ name
go [] = [l]
go (x:xs)
| "Handler." `isPrefixOf` x' = (spaces ++ "Handler." ++ name) : x : xs
| otherwise = x : go xs
where
(spaces, x') = span isSpace x
fixRoutes :: String -> String -> String -> String -> String
fixRoutes name pattern methods =
(++ l)
where
l = concat
[ pattern
, " "
, name
, "R "
, methods
, "\n"
]
mkHandler :: String -> String -> String -> String
mkHandler name pattern methods = unlines
$ ("module Handler." ++ name ++ " where")
: ""
: "import Import"
: concatMap go (words methods)
where
go method =
[ ""
, concat $ func : " :: " : map toArrow types ++ ["Handler RepHtml"]
, concat
[ func
, " = error \"Not yet implemented: "
, func
, "\""
]
]
where
func = concat [map toLower method, name, "R"]
types = getTypes pattern
toArrow t = concat [t, " -> "]
getTypes "" = []
getTypes ('/':rest) = getTypes rest
getTypes ('#':rest) =
typ : getTypes rest'
where
(typ, rest') = break (== '/') rest
getTypes rest = getTypes $ dropWhile (/= '/') rest

1
yesod/Scaffolding/Scaffolder.hs
View File

@ -143,6 +143,7 @@ scaffold = do
Mysql -> writeFile' ("config/" ++ backendLower ++ ".yml") $(codegen "config/mysql.yml")
writeFile' "config/settings.yml" $(codegen "config/settings.yml")
writeFile' "config/keter.yaml" $(codegen "config/keter.yaml")
writeFile' "main.hs" $(codegen "main.hs")
writeFile' "devel.hs" $(codegen "devel.hs")
writeFile' (project ++ ".cabal") $(codegen "project.cabal")

24
yesod/Yesod.hs
View File

@ -45,15 +45,13 @@ import Text.Julius
import Yesod.Form
import Yesod.Json
import Yesod.Persist
import Network.HTTP.Types (status200)
import Control.Monad.IO.Class (liftIO, MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl)
import Network.Wai
import Network.Wai.Logger
import Network.Wai.Middleware.RequestLogger (logStdout)
import Network.Wai.Handler.Warp (run)
import System.IO (stderr, stdout, hFlush, hPutStrLn)
import System.Log.FastLogger
import System.IO (stderr, hPutStrLn)
#if MIN_VERSION_blaze_html(0, 5, 0)
import Text.Blaze.Html (toHtml)
#else
@ -80,23 +78,7 @@ warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO ()
warpDebug port app = do
hPutStrLn stderr $ "Application launched, listening on port " ++ show port
waiApp <- toWaiApp app
dateRef <- dateInit
run port $ (logStdout dateRef) waiApp
logStdout :: DateRef -> Middleware
logStdout dateRef waiApp =
\req -> do
logRequest dateRef req
waiApp req
logRequest :: Control.Monad.IO.Class.MonadIO m =>
DateRef -> Network.Wai.Request -> m ()
logRequest dateRef req = do
date <- liftIO $ getDate dateRef
let status = status200
len = 4
liftIO $ hPutLogStr stdout $ apacheFormat FromSocket date req status (Just len)
liftIO $ hFlush stdout
run port $ logStdout waiApp
-- | Run a development server, where your code changes are automatically
-- reloaded.

3
yesod/main.hs
View File

@ -11,6 +11,7 @@ import Control.Monad (unless)
import Build (touch)
#endif
import Devel (devel)
import AddHandler (addHandler)
windowsWarning :: String
#ifdef WINDOWS
@ -46,6 +47,7 @@ main = do
rawSystem' cmd ["test"]
["version"] -> putStrLn $ "yesod-core version:" ++ yesodVersion
"configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith
["add-handler"] -> addHandler
_ -> do
putStrLn "Usage: yesod <command>"
putStrLn "Available commands:"
@ -59,6 +61,7 @@ main = do
putStrLn " use --dev devel to build with cabal-dev"
putStrLn " test Build and run the integration tests"
putStrLn " use --dev devel to build with cabal-dev"
putStrLn " add-handler Add a new handler and module to your project"
putStrLn " version Print the version of Yesod"
-- | Like @rawSystem@, but exits if it receives a non-success result.

20
yesod/scaffold/Application.hs.cg
View File

@ -11,8 +11,7 @@ import Yesod.Auth
import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers
import Yesod.Logger (Logger, logBS, toProduction)
import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev)
import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
import qualified Database.Persist.Store~importMigration~
import Network.HTTP.Conduit (newManager, def)
@ -29,25 +28,24 @@ mkYesodDispatch "~sitearg~" resources~sitearg~
-- 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.
makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application
makeApplication conf logger = do
foundation <- makeFoundation conf setLogger
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
makeApplication conf = do
foundation <- makeFoundation conf
app <- toWaiAppPlain foundation
return $ logWare app
where
setLogger = if development then logger else toProduction logger
logWare = if development then logCallbackDev (logBS setLogger)
else logCallback (logBS setLogger)
logWare = if development then logStdoutDev
else logStdout
makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO ~sitearg~
makeFoundation conf setLogger = do
makeFoundation :: AppConfig DefaultEnv Extra -> IO ~sitearg~
makeFoundation conf = do
manager <- newManager def
s <- staticSite
dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf)
Database.Persist.Store.loadConfig >>=
Database.Persist.Store.applyEnv
p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)~runMigration~
return $ ~sitearg~ conf setLogger s p manager dbconf
return $ ~sitearg~ conf s p manager dbconf
-- for yesod devel
getApplicationDev :: IO (Int, Application)

5
yesod/scaffold/Foundation.hs.cg
View File

@ -20,7 +20,6 @@ import Yesod.Auth.BrowserId
import Yesod.Auth.GoogleEmail
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Logger (Logger, logMsg, formatLogText)
import Network.HTTP.Conduit (Manager)
import qualified Settings
import qualified Database.Persist.Store
@ -38,7 +37,6 @@ import Text.Hamlet (hamletFile)
-- access to the data present here.
data ~sitearg~ = ~sitearg~
{ settings :: AppConfig DefaultEnv Extra
, getLogger :: Logger
, getStatic :: Static -- ^ Settings for static file serving.
, connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
, httpManager :: Manager
@ -107,9 +105,6 @@ instance Yesod ~sitearg~ where
-- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR
messageLogger y loc level msg =
formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
-- 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

17
yesod/scaffold/Settings.hs.cg
View File

@ -17,11 +17,13 @@ import Text.Shakespeare.Text (st)
import Language.Haskell.TH.Syntax
import Database.Persist.~importPersist~ (~configPersist~)
import Yesod.Default.Config
import qualified Yesod.Default.Util
import Yesod.Default.Util
import Data.Text (Text)
import Data.Yaml
import Control.Applicative
import Settings.Development
import Data.Default (def)
import Text.Hamlet
-- | Which Persistent backend this site is using.
type PersistConfig = ~configPersist~
@ -49,13 +51,22 @@ staticDir = "static"
staticRoot :: AppConfig DefaultEnv x -> Text
staticRoot conf = [st|#{appRoot conf}/static|]
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
{ wfsHamletSettings = defaultHamletSettings
{ hamletNewlines = AlwaysNewlines
}
}
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = if development then Yesod.Default.Util.widgetFileReload
else Yesod.Default.Util.widgetFileNoReload
widgetFile = (if development then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
data Extra = Extra
{ extraCopyright :: Text

4
yesod/scaffold/config/keter.yaml.cg Normal file
View File

@ -0,0 +1,4 @@
exec: ../dist/build/~project~/~project~
args:
- production
host: ~project~.yesodweb.com

44
yesod/scaffold/project.cabal.cg
View File

@ -50,31 +50,32 @@ library
NoMonomorphismRestriction
build-depends: base >= 4 && < 5
, yesod-platform >= 1.0 && < 1.1
, yesod >= 1.0 && < 1.1
, yesod-core >= 1.0 && < 1.1
, yesod-auth >= 1.0 && < 1.1
, yesod-static >= 1.0 && < 1.1
, yesod-default >= 1.0 && < 1.1
, yesod-form >= 1.0 && < 1.1
, yesod-test >= 0.2 && < 0.3
, clientsession >= 0.7.3 && < 0.8
-- , yesod-platform >= 1.1 && < 1.2
, yesod >= 1.1 && < 1.2
, yesod-core >= 1.1 && < 1.2
, yesod-auth >= 1.1 && < 1.2
, yesod-static >= 1.1 && < 1.2
, yesod-default >= 1.1 && < 1.2
, yesod-form >= 1.1 && < 1.2
, yesod-test >= 0.3 && < 0.4
, clientsession >= 0.8 && < 0.9
, bytestring >= 0.9 && < 0.10
, text >= 0.11 && < 0.12
, persistent >= 0.9 && < 0.10
, persistent-~backendLower~ >= 0.9 && < 0.10
, persistent >= 1.0 && < 1.1
, persistent-~backendLower~ >= 1.0 && < 1.1
, template-haskell
, hamlet >= 1.0 && < 1.1
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0 && < 1.1
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 1.2 && < 1.3
, yaml >= 0.7 && < 0.8
, http-conduit >= 1.4 && < 1.5
, wai-extra >= 1.3 && < 1.4
, yaml >= 0.8 && < 0.9
, http-conduit >= 1.5 && < 1.6
, directory >= 1.1 && < 1.2
, warp >= 1.2 && < 1.3
, warp >= 1.3 && < 1.4
, data-default
executable ~project~
if flag(library-only)
@ -93,17 +94,6 @@ test-suite test
main-is: main.hs
hs-source-dirs: tests
ghc-options: -Wall
extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
NoImplicitPrelude
CPP
OverloadedStrings
MultiParamTypeClasses
TypeFamilies
GADTs
GeneralizedNewtypeDeriving
FlexibleContexts
build-depends: base
, ~project~

1
yesod/scaffold/templates/default-layout-wrapper.hamlet.cg
View File

@ -1,3 +1,4 @@
$newline never
\<!doctype html>
\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
\<!--[if IE 7]> <html class="no-js ie7 oldie" lang="en"> <![endif]-->

2
yesod/scaffold/tests/HomeTest.hs.cg
View File

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
module HomeTest
( homeSpecs
) where
import Import
import Yesod.Test
homeSpecs :: Specs

2
yesod/scaffold/tests/main.hs.cg
View File

@ -13,7 +13,7 @@ import Application (makeFoundation)
import HomeTest
main :: IO a
main :: IO ()
main = do
conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra }
logger <- defaultDevelopmentLogger

40
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 1.0.1.6
version: 1.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -51,6 +51,7 @@ extra-source-files:
scaffold/templates/boilerplate-wrapper.hamlet.cg
scaffold/templates/homepage.lucius.cg
scaffold/messages/en.msg.cg
scaffold/config/keter.yaml.cg
scaffold/config/models.cg
scaffold/config/mysql.yml.cg
scaffold/config/sqlite.yml.cg
@ -62,34 +63,23 @@ extra-source-files:
scaffold/config/mongoDB.yml.cg
scaffold/devel.hs.cg
flag blaze_html_0_5
description: use blaze-html 0.5 and blaze-markup 0.5
default: True
library
build-depends: base >= 4.3 && < 5
, yesod-core >= 1.0 && < 1.1
, yesod-auth >= 1.0 && < 1.1
, yesod-json >= 1.0 && < 1.1
, yesod-persistent >= 1.0 && < 1.1
, yesod-form >= 1.0 && < 1.1
, yesod-core >= 1.1 && < 1.2
, yesod-auth >= 1.1 && < 1.2
, yesod-json >= 1.1 && < 1.2
, yesod-persistent >= 1.1 && < 1.2
, yesod-form >= 1.1 && < 1.2
, monad-control >= 0.3 && < 0.4
, transformers >= 0.2.2 && < 0.4
, wai >= 1.2 && < 1.3
, wai-extra >= 1.2 && < 1.3
, wai-logger >= 0.1.2
, hamlet >= 1.0 && < 1.1
, wai >= 1.3 && < 1.4
, wai-extra >= 1.3 && < 1.4
, hamlet >= 1.1 && < 1.2
, shakespeare-js >= 1.0 && < 1.1
, shakespeare-css >= 1.0 && < 1.1
, warp >= 1.2 && < 1.3
if flag(blaze_html_0_5)
build-depends:
blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
else
build-depends:
blaze-html >= 0.4 && < 0.5
, warp >= 1.3 && < 1.4
, blaze-html >= 0.5 && < 0.6
, blaze-markup >= 0.5.1 && < 0.6
exposed-modules: Yesod
ghc-options: -Wall
@ -109,10 +99,9 @@ executable yesod
, unix-compat >= 0.2 && < 0.4
, containers >= 0.2
, attoparsec >= 0.10
, http-types >= 0.6.1 && < 0.7
, http-types >= 0.7 && < 0.8
, blaze-builder >= 0.2.1.4 && < 0.4
, filepath >= 1.1
, fast-logger >= 0.0.2 && < 0.1
, process
ghc-options: -Wall -threaded
main-is: main.hs
@ -120,6 +109,7 @@ executable yesod
Scaffolding.Scaffolder
Devel
Build
AddHandler
source-repository head
type: git