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

Major modification of data types

Browse Source
This commit is contained in:
Michael Snoyman 2011-03-24 16:32:44 +02:00
parent a221c1c832
commit 33db6ced91
12 changed files with 88 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Test/CleanPath.hs
View File

@ -16,10 +16,11 @@ import Network.Wai.Test
import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Text as TS
data Subsite = Subsite
getSubsite = const Subsite
data SubsiteRoute = SubsiteRoute [String]
data SubsiteRoute = SubsiteRoute [TS.Text]
deriving (Eq, Show, Read)
type instance Route Subsite = SubsiteRoute
instance RenderRoute SubsiteRoute where
@ -48,7 +49,7 @@ instance Yesod Y where
then Right s
else Left corrected
where
corrected = filter (not . null) s
corrected = filter (not . TS.null) s
getFooR = return $ RepPlain "foo"
getFooStringR = return . RepPlain . toContent

4
Test/Exceptions.hs
View File

@ -35,9 +35,9 @@ exceptionsTest = testGroup "Test.Exceptions"
runner f = toWaiApp Y >>= runSession f
defaultRequest = Request
{ pathInfo = ""
{ pathInfo = []
, requestHeaders = []
, queryString = ""
, queryString = []
, requestMethod = "GET"
}

7
Yesod/Content.hs
View File

@ -61,7 +61,6 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString))
import qualified Data.Ascii as A
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
| ContentEnum (forall a. Enumerator Builder IO a)
@ -167,7 +166,7 @@ newtype RepXml = RepXml Content
instance HasReps RepXml where
chooseRep (RepXml c) _ = return (typeXml, c)
type ContentType = A.Ascii
type ContentType = B.ByteString
typeHtml :: ContentType
typeHtml = "text/html; charset=utf-8"
@ -216,8 +215,8 @@ typeOctet = "application/octet-stream"
--
-- For example, \"text/html; charset=utf-8\" is commonly used to specify the
-- character encoding for HTML data. This function would return \"text/html\".
simpleContentType :: A.Ascii -> A.Ascii
simpleContentType = A.unsafeFromByteString . fst . B.breakByte 59 . A.toByteString -- 59 == ;
simpleContentType :: ContentType -> ContentType
simpleContentType = fst . B.breakByte 59 -- 59 == ;
-- | Format a 'UTCTime' in W3 format.
formatW3 :: UTCTime -> String

35
Yesod/Core.hs
View File

@ -54,9 +54,11 @@ import Web.Cookie (parseCookies)
import qualified Data.Map as Map
import Data.Time
import Network.HTTP.Types (encodePath)
import qualified Network.HTTP.Types as H
import qualified Data.Text as TS
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import qualified Data.Ascii as A
import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
#if GHC7
#define HAMLET hamlet
@ -65,7 +67,7 @@ import qualified Data.Ascii as A
#endif
class Eq u => RenderRoute u where
renderRoute :: u -> ([String], [(String, String)]) -- FIXME switch to Text?
renderRoute :: u -> ([Text], [(Text, Text)])
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
@ -74,7 +76,7 @@ class YesodDispatch a master where
:: Yesod master
=> a
-> Maybe CS.Key
-> [String]
-> [Text]
-> master
-> (Route a -> Route master)
-> Maybe W.Application
@ -99,7 +101,7 @@ class RenderRoute (Route a) => Yesod a where
--
-- * You do not use any features that require absolute URLs, such as Atom
-- feeds and XML sitemaps.
approot :: a -> A.Ascii
approot :: a -> H.Ascii
-- | The encryption key to be used for encrypting client sessions.
-- Returning 'Nothing' disables sessions.
@ -136,7 +138,7 @@ class RenderRoute (Route a) => Yesod a where
-- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid
-- sending cookies.
urlRenderOverride :: a -> Route a -> Maybe A.AsciiBuilder
urlRenderOverride :: a -> Route a -> Maybe Builder
urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not.
@ -179,21 +181,21 @@ class RenderRoute (Route a) => Yesod a where
--
-- Note that versions of Yesod prior to 0.7 used a different set of rules
-- involing trailing slashes.
cleanPath :: a -> [String] -> Either [String] [String]
cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath _ s =
if corrected == s
then Right s
else Left corrected
where
corrected = filter (not . null) s
corrected = filter (not . TS.null) s
-- | Join the pieces of a path together into an absolute URL. This should
-- be the inverse of 'splitPath'.
joinPath :: a
-> A.AsciiBuilder -- ^ application root
-> Builder -- ^ application root
-> [TS.Text] -- ^ path pieces FIXME Text
-> [(TS.Text, TS.Text)] -- ^ query string
-> A.AsciiBuilder
-> Builder
joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs
where
qs = map (TE.encodeUtf8 *** go) qs'
@ -379,7 +381,7 @@ defaultErrorHandler (BadMethod m) =
[$hamlet|
#endif
<h1>Method Not Supported
<p>Method "#{A.toText m}" not supported
<p>Method "#{S8.unpack m}" not supported
|]
-- | Return the same URL if the user is authorized to see it.
@ -411,7 +413,8 @@ widgetToPageContent (GWidget w) = do
jelper :: Julius url -> Hamlet url
jelper = fmap jsToHtml
render <- getUrlRenderParams
renderFIXME <- getUrlRenderParams
let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b
let renderLoc x =
case x of
Nothing -> Nothing
@ -462,13 +465,13 @@ yesodVersion = showVersion Paths_yesod_core.version
yesodRender :: Yesod y
=> y
-> Route y
-> [(String, String)]
-> String
-> [(Text, Text)]
-> String -- FIXME
yesodRender y u qs =
A.toString $ A.fromAsciiBuilder $
S8.unpack $ toByteString $
fromMaybe
( joinPath y (A.toAsciiBuilder $ approot y) (map TS.pack ps)
$ map (TS.pack *** TS.pack) $ qs ++ qs')
(joinPath y (fromByteString $ approot y) ps
$ qs ++ qs')
(urlRenderOverride y u)
where
(ps, qs') = renderRoute u

6
Yesod/Dispatch.hs
View File

@ -39,7 +39,6 @@ import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
import qualified Data.Text as TS
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -175,8 +174,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y)
=> y
-> Maybe Key
-> W.Application
toWaiApp' y key' env = do
let segments = map TS.unpack $ W.pathInfo env
case yesodDispatch y key' segments y id of
toWaiApp' y key' env =
case yesodDispatch y key' (W.pathInfo env) y id of
Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env

60
Yesod/Handler.hs
View File

@ -125,7 +125,7 @@ import Control.Failure (Failure (failure))
import Text.Hamlet
import Control.Monad.IO.Peel (MonadPeelIO)
import Control.Monad.IO.Peel (MonadPeelIO) -- FIXME monad-control
import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
import qualified Data.Map as Map
import qualified Data.ByteString as S
@ -139,8 +139,12 @@ import Web.Cookie (SetCookie (..), renderSetCookie)
import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP
import qualified Data.Ascii as A
import Data.Monoid (mappend, mempty)
import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import qualified Data.Text as TS
-- | The type-safe URLs associated with a site argument.
type family Route a
@ -153,7 +157,7 @@ data HandlerData sub master = HandlerData
, handlerSub :: sub
, handlerMaster :: master
, handlerRoute :: Maybe (Route sub)
, handlerRender :: (Route master -> [(String, String)] -> String) -- FIXME replace output String with Ascii
, handlerRender :: (Route master -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii
, handlerToMaster :: Route sub -> Route master
}
@ -271,8 +275,8 @@ data HandlerContents =
HCContent H.Status ChooseRep
| HCError ErrorResponse
| HCSendFile ContentType FilePath
| HCRedirect RedirectType A.Ascii
| HCCreated A.Ascii
| HCRedirect RedirectType H.Ascii
| HCCreated H.Ascii
| HCWai W.Response
instance Error HandlerContents where
@ -318,7 +322,7 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters.
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(String, String)] -> String)
=> GGHandler sub master m (Route master -> [(Text, Text)] -> String)
getUrlRenderParams = handlerRender `liftM` GHandler ask
-- | Get the route requested by the user. If this is a 404 response- where the
@ -335,7 +339,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
runHandler :: HasReps c
=> GHandler sub master c
-> (Route master -> [(String, String)] -> String)
-> (Route master -> [(Text, Text)] -> String)
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> master
@ -419,14 +423,14 @@ redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters.
redirectParams :: Monad mo
=> RedirectType -> Route master -> [(String, String)]
=> RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ A.unsafeFromString $ r url params
redirectString rt $ S8.pack $ r url params
-- | Redirect to the given URL.
redirectString :: Monad mo => RedirectType -> A.Ascii -> GGHandler sub master mo a
redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a
redirectString rt = GHandler . lift . throwError . HCRedirect rt
ultDestKey :: String
@ -458,7 +462,8 @@ setUltDest' = do
tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
render <- getUrlRenderParams
setUltDestString $ render (tm r) gets'
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
setUltDestString $ renderFIXME (tm r) gets'
-- | Redirect to the ultimate destination in the user's session. Clear the
-- value from the session.
@ -471,7 +476,7 @@ redirectUltDest :: Monad mo
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest
maybe (redirect rt def) (redirectString rt . S8.pack) mdest
msgKey :: String
msgKey = "_MSG"
@ -516,7 +521,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do
r <- getUrlRender
GHandler $ lift $ throwError $ HCCreated $ A.unsafeFromString $ r url
GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url
-- | Send a 'W.Response'. Please note: this function is rarely
-- necessary, and will /disregard/ any changes to response headers and session
@ -548,29 +553,29 @@ invalidArgs = failure . InvalidArgs
-- | Set the cookie on the client.
setCookie :: Monad mo
=> Int -- ^ minutes to timeout
-> A.Ascii -- ^ key
-> A.Ascii -- ^ value
-> H.Ascii -- ^ key
-> H.Ascii -- ^ value
-> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client.
deleteCookie :: Monad mo => A.Ascii -> GGHandler sub master mo ()
deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie
-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
setLanguage :: Monad mo => String -> GGHandler sub master mo ()
setLanguage = setSession (A.toString langKey)
setLanguage = setSession $ S8.unpack langKey
-- | Set an arbitrary response header.
setHeader :: Monad mo
=> A.CIAscii -> A.Ascii -> GGHandler sub master mo ()
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds.
cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ A.unsafeFromString $ concat
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age="
, show i
, ", public"
@ -588,7 +593,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date.
expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . A.unsafeFromString . formatRFC1123
expiresAt = setHeader "Expires" . S8.pack . formatRFC1123
-- | Set a variable in the user's session.
--
@ -648,7 +653,7 @@ handlerToYAR :: (HasReps a, HasReps b)
=> m -- ^ master site foundation
-> s -- ^ sub site foundation
-> (Route s -> Route m)
-> (Route m -> [(String, String)] -> String) -- ^ url render
-> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME
-> (ErrorResponse -> GHandler s m a)
-> Request
-> Maybe (Route s)
@ -666,7 +671,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
type HeaderRenderer = [Header]
-> ContentType
-> SessionMap
-> [(A.CIAscii, A.Ascii)]
-> [(CI H.Ascii, H.Ascii)]
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
yarToResponse _ (YARWai a) = a
@ -675,12 +680,12 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
ContentBuilder b mlen ->
let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b
ContentFile fp -> W.ResponseFile s finalHeaders fp
ContentFile fp -> W.ResponseFile s finalHeaders fp Nothing -- FIXME handle partial files
ContentEnum e ->
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where
finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len)
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
{-
getExpires m = fromIntegral (m * 60) `addUTCTime` now
@ -711,9 +716,9 @@ httpAccept = parseHttpAccept
-- | Convert Header to a key/value pair.
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-> Header
-> (A.CIAscii, A.Ascii)
-> (CI H.Ascii, H.Ascii)
headerToPair getExpires (AddCookie minutes key value) =
("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
{ setCookieName = key
, setCookieValue = value
, setCookiePath = Just "/" -- FIXME make a config option, or use approot?
@ -777,7 +782,8 @@ hamletToContent :: Monad mo
=> Hamlet (Route master) -> GGHandler sub master mo Content
hamletToContent h = do
render <- getUrlRenderParams
return $ toContent $ h render
let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
return $ toContent $ h renderFIXME
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo

5
Yesod/Internal.hs
View File

@ -51,8 +51,9 @@ import qualified Data.Text.Lazy.Encoding as LT
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import qualified Data.Ascii as A
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
#if GHC7
#define HAMLET hamlet
@ -76,7 +77,7 @@ instance Exception ErrorResponse
data Header =
AddCookie Int A.Ascii A.Ascii
| DeleteCookie A.Ascii
| Header A.CIAscii A.Ascii
| Header (CI A.Ascii) A.Ascii
deriving (Eq, Show)
langKey :: A.Ascii

15
Yesod/Internal/Dispatch.hs
View File

@ -20,11 +20,11 @@ import Data.Char (toLower)
import qualified Data.ByteString as S
import Yesod.Core (Yesod (joinPath, approot, cleanPath))
import Network.HTTP.Types (status301)
import qualified Data.Ascii as A
import Data.Text (Text)
import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder.Char8
import qualified Data.ByteString.Char8 as S8
{-|
@ -83,15 +83,14 @@ sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env =
return $ W.responseLBS status301
[ ("Content-Type", "text/plain")
, ("Location", A.fromAsciiBuilder dest')
, ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting"
where
dest = joinPath y (A.toAsciiBuilder $ approot y) segments' []
dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' []
dest' =
if S.null (W.rawQueryString env)
then dest
else A.unsafeFromBuilder
(A.toBuilder dest `mappend`
else (dest `mappend`
Blaze.ByteString.Builder.Char8.fromChar '?' `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
@ -154,7 +153,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
onSuccess <- newName "onSuccess"
req <- newName "req"
badMethod' <- [|badMethod|]
rm <- [|A.toString . W.requestMethod|]
rm <- [|S8.unpack . W.requestMethod|]
let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|]
@ -205,11 +204,11 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
fsp <- [|fromSinglePiece|]
let exp' = CaseE (fsp `AppE` VarE next)
[ Match
(ConP (mkName "Left") [WildP])
(ConP (mkName "Nothing") [])
(NormalB nothing)
[]
, Match
(ConP (mkName "Right") [VarP next'])
(ConP (mkName "Just") [VarP next'])
(NormalB innerExp)
[]
]

10
Yesod/Internal/Request.hs
View File

@ -10,8 +10,8 @@ import Yesod.Internal
import qualified Network.Wai as W
import System.Random (randomR, newStdGen)
import Web.Cookie (parseCookies)
import qualified Data.Ascii as A
import Data.Monoid (mempty)
import qualified Data.ByteString.Char8 as S8
parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session
@ -24,14 +24,14 @@ parseWaiRequest env session' key' = do
$ W.requestHeaders env
cookies' = parseCookies reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup (A.toString langKey) session' of
langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup (S8.unpack langKey) session' of
Nothing -> langs
Just x -> x : langs
langs'' = case lookup langKey cookies' of
Nothing -> langs'
Just x -> A.toString x : langs'
langs''' = case lookup (A.toString langKey) gets' of
Just x -> S8.unpack x : langs'
langs''' = case lookup (S8.unpack langKey) gets' of
Nothing -> langs''
Just x -> x : langs''
nonce <- case (key', lookup nonceKey session') of

5
Yesod/Internal/Session.hs
View File

@ -8,20 +8,19 @@ import Data.Serialize
import Data.Time
import Data.ByteString (ByteString)
import Control.Monad (guard)
import qualified Data.Ascii as A
encodeSession :: CS.Key
-> UTCTime -- ^ expire time
-> ByteString -- ^ remote host
-> [(String, String)] -- ^ session
-> A.Ascii -- ^ cookie value
-> ByteString -- ^ cookie value
encodeSession key expire rhost session' =
CS.encrypt key $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key
-> UTCTime -- ^ current time
-> ByteString -- ^ remote host field
-> A.Ascii -- ^ cookie value
-> ByteString -- ^ cookie value
-> Maybe [(String, String)]
decodeSession key now rhost encrypted = do
decrypted <- CS.decrypt key encrypted

2
Yesod/Request.hs
View File

@ -43,7 +43,7 @@ import Control.Monad.IO.Class
import Control.Monad (liftM)
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
import Data.Maybe (listToMaybe)
import qualified Data.Ascii as A
import qualified Network.HTTP.Types as A
type ParamName = String
type ParamValue = String

16
yesod-core.cabal
View File

@ -33,22 +33,22 @@ library
, bytestring >= 0.9.1.4 && < 0.10
, text >= 0.5 && < 0.12
, template-haskell
, web-routes-quasi >= 0.6.3.1 && < 0.7
, hamlet >= 0.7 && < 0.8
, blaze-builder >= 0.2.1 && < 0.3
, web-routes-quasi >= 0.7 && < 0.8
, hamlet >= 0.7.3 && < 0.8
, blaze-builder >= 0.2.1 && < 0.4
, transformers >= 0.2 && < 0.3
, clientsession >= 0.5 && < 0.6
, clientsession >= 0.6 && < 0.7
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.2 && < 0.4
, old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5
, monad-peel >= 0.1 && < 0.2
, enumerator >= 0.4 && < 0.5
, cookie >= 0.1 && < 0.2
, enumerator >= 0.4.7 && < 0.5
, cookie >= 0.2 && < 0.3
, blaze-html >= 0.4 && < 0.5
, ascii >= 0.0.2 && < 0.1
, http-types >= 0.5 && < 0.6
, http-types >= 0.6 && < 0.7
, case-insensitive >= 0.2 && < 0.3
exposed-modules: Yesod.Content
Yesod.Core
Yesod.Dispatch