From e280e284f80afa0ada354c9dc4eec89df4db8482 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Apr 2010 15:35:41 -0700 Subject: [PATCH] Began refactoring --- .gitignore | 2 +- Yesod.hs | 5 +- Yesod/Definitions.hs | 13 +-- Yesod/Dispatch.hs | 171 ++++++++++++++++++++++++++++++++++++++ Yesod/Handler.hs | 48 ++--------- Yesod/Helpers/AtomFeed.hs | 26 ++---- Yesod/Helpers/Auth.hs | 17 ++-- Yesod/Helpers/Sitemap.hs | 80 +++++++----------- Yesod/Helpers/Static.hs | 2 +- Yesod/Resource.hs | 58 ------------- Yesod/Response.hs | 8 ++ Yesod/Yesod.hs | 102 ++--------------------- yesod.cabal | 2 +- 13 files changed, 248 insertions(+), 286 deletions(-) create mode 100644 Yesod/Dispatch.hs delete mode 100644 Yesod/Resource.hs diff --git a/.gitignore b/.gitignore index 00255d26..31291836 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ -dist +/dist/ *.swp client_session_key.aes *.hi diff --git a/Yesod.hs b/Yesod.hs index 29b2e1dc..baaf4880 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -19,7 +19,7 @@ module Yesod , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler - , module Yesod.Resource + , module Yesod.Dispatch , module Yesod.Form , module Web.Mime , module Yesod.Hamlet @@ -29,17 +29,16 @@ module Yesod ) where #if TEST -import Yesod.Resource hiding (testSuite) import Yesod.Response hiding (testSuite) import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) #else -import Yesod.Resource import Yesod.Response import Yesod.Request import Web.Mime #endif +import Yesod.Dispatch import Yesod.Form import Yesod.Yesod import Yesod.Definitions diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index c1e1d196..fb51a1ed 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -17,8 +17,6 @@ module Yesod.Definitions ( Approot , Language - , Location (..) - , showLocation -- * Constant values , authCookieName , authDisplayName @@ -37,22 +35,13 @@ type Approot = String type Language = String --- | A location string. Can either be given absolutely or as a suffix for the --- 'Approot'. -data Location = AbsLoc String | RelLoc String - --- | Display a 'Location' in absolute form. -showLocation :: Approot -> Location -> String -showLocation _ (AbsLoc s) = s -showLocation ar (RelLoc s) = ar ++ s - authCookieName :: String authCookieName = "IDENTIFIER" authDisplayName :: String authDisplayName = "DISPLAY_NAME" -encryptedCookies :: [ByteString] +encryptedCookies :: [ByteString] -- FIXME make this extensible encryptedCookies = [pack authDisplayName, pack authCookieName] langKey :: String diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs new file mode 100644 index 00000000..74eaee8d --- /dev/null +++ b/Yesod/Dispatch.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Dispatch + ( -- * Quasi-quoted routing + parseRoutes + , mkYesod + , mkYesodSub + -- * Convert to WAI + , toWaiApp + , basicHandler + ) where + +import Yesod.Handler +import Yesod.Response +import Yesod.Definitions +import Yesod.Yesod +import Yesod.Request + +import Web.Routes.Quasi +import Language.Haskell.TH.Syntax + +import qualified Network.Wai as W +import Network.Wai.Middleware.CleanPath +import Network.Wai.Middleware.ClientSession +import Network.Wai.Middleware.Jsonp +import Network.Wai.Middleware.MethodOverride +import Network.Wai.Middleware.Gzip + +import qualified Network.Wai.Handler.SimpleServer as SS +import qualified Network.Wai.Handler.CGI as CGI +import System.Environment (getEnvironment) + +import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe) +import Web.Encodings (parseHttpAccept) +import Web.Mime +import Data.List (intercalate) +import Web.Routes (encodePathInfo, decodePathInfo) + +mkYesod :: String -> [Resource] -> Q [Dec] +mkYesod name = mkYesodGeneral name [] False + +mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] +mkYesodSub name clazzes = mkYesodGeneral name clazzes True + +explodeHandler :: HasReps c + => GHandler sub master c + -> (Routes master -> String) + -> Routes sub + -> (Routes sub -> Routes master) + -> master + -> (master -> sub) + -> YesodApp + -> String + -> YesodApp +explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f + +mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q [Dec] +mkYesodGeneral name clazzes isSub res = do + let name' = mkName name + let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") + let site = mkName $ "site" ++ name + let gsbod = NormalB $ VarE site + let yes' = FunD (mkName "getSite") [Clause [] gsbod []] + let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] + explode <- [|explodeHandler|] + CreateRoutesResult x _ z <- createRoutes $ CreateRoutesSettings + { crRoutes = mkName $ name ++ "Routes" + , crApplication = ConT ''YesodApp + , crArgument = ConT $ mkName name + , crExplode = explode + , crResources = res + , crSite = site + } + let master = if isSub + then VarT (mkName "master") + else ConT (mkName name) + murl = ConT ''Routes `AppT` master + sub = ConT $ mkName name + surl = ConT ''Routes `AppT` sub + let yType = ConT ''QuasiSite + `AppT` ConT ''YesodApp + `AppT` surl + `AppT` sub + `AppT` murl + `AppT` master + let ctx = if isSub + then map (\c -> ClassP c [master]) clazzes + else [] + tvs = if isSub then [PlainTV $ mkName "master"] else [] + let y' = SigD site $ ForallT tvs ctx yType + return $ (if isSub then id else (:) yes) $ [y', z, tySyn, x] + +toWaiApp :: Yesod y => y -> IO W.Application +toWaiApp a = do + key' <- encryptKey a + let mins = clientSessionDuration a + return $ gzip + $ jsonp + $ methodOverride + $ cleanPath + $ \thePath -> clientsession encryptedCookies key' mins + $ toWaiApp' a thePath + +toWaiApp' :: Yesod y + => y + -> [B.ByteString] + -> [(B.ByteString, B.ByteString)] + -> W.Request + -> IO W.Response +toWaiApp' y resource session env = do + let site = getSite + method = B.unpack $ W.methodToBS $ W.requestMethod env + types = httpAccept env + pathSegments = filter (not . null) $ cleanupSegments resource + eurl = quasiParse site pathSegments + render u = approot y ++ '/' + : encodePathInfo (fixSegs $ quasiRender site u) + rr <- parseWaiRequest env session + onRequest y rr + print pathSegments -- FIXME remove + let ya = case eurl of + Nothing -> runHandler (errorHandler y NotFound) + render + Nothing + id + y + id + Just url -> quasiDispatch site + render + url + id + y + id + (badMethodApp method) + method + let eh er = runHandler (errorHandler y er) render eurl id y id + unYesodApp ya eh rr types >>= responseToWaiResponse + +cleanupSegments :: [B.ByteString] -> [String] +cleanupSegments = decodePathInfo . intercalate "/" . map B.unpack + +httpAccept :: W.Request -> [ContentType] +httpAccept = map contentTypeFromBS + . parseHttpAccept + . fromMaybe B.empty + . lookup W.Accept + . W.requestHeaders + +-- | Runs an application with CGI if CGI variables are present (namely +-- PATH_INFO); otherwise uses SimpleServer. +basicHandler :: Int -- ^ port number + -> W.Application -> IO () +basicHandler port app = do + vars <- getEnvironment + case lookup "PATH_INFO" vars of + Nothing -> do + putStrLn $ "http://localhost:" ++ show port ++ "/" + SS.run port app + Just _ -> CGI.run app + +badMethodApp :: String -> YesodApp +badMethodApp m = YesodApp $ \eh req cts + -> unYesodApp (eh $ BadMethod m) eh req cts + +fixSegs :: [String] -> [String] +fixSegs [] = [] +fixSegs [x] + | any (== '.') x = [x] + | otherwise = [x, ""] -- append trailing slash +fixSegs (x:xs) = x : fixSegs xs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a6a14f76..ead83da9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -30,9 +30,6 @@ module Yesod.Handler , getRoute , getRouteMaster , runHandler - , runHandler' - , runHandlerSub - , runHandlerSub' , liftIO , YesodApp (..) , Routes @@ -145,25 +142,15 @@ getRouteMaster = do d <- getData return $ handlerToMaster d <$> handlerRoute d -runHandlerSub' :: HasReps c - => GHandler sub master c - -> (Routes master -> String) - -> Routes sub - -> (Routes sub -> Routes master) - -> master - -> (master -> sub) - -> String - -> YesodApp -runHandlerSub' handler mrender surl tomurl marg tosarg _method = - runHandlerSub handler (marg, tosarg, tomurl, mrender) (Just surl) (mrender . tomurl) - -runHandlerSub :: HasReps c - => GHandler sub master c - -> (master, master -> sub, Routes sub -> Routes master, Routes master -> String) - -> Maybe (Routes sub) - -> (Routes sub -> String) - -> YesodApp -runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts -> do +runHandler :: HasReps c + => GHandler sub master c + -> (Routes master -> String) + -> Maybe (Routes sub) + -> (Routes sub -> Routes master) + -> master + -> (master -> sub) + -> YesodApp +runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String) @@ -196,23 +183,6 @@ runHandlerSub handler (ma, tosa, tomr, mrender) sroute _ = YesodApp $ \eh rr cts (ct, c) <- chooseRep a cts return $ Response W.Status200 headers ct c -runHandler' :: HasReps c - => Handler yesod c - -> yesod - -> Routes yesod - -> (Routes yesod -> String) - -> YesodApp -runHandler' handler y route render = runHandler handler y (Just route) render - -runHandler :: HasReps c - => Handler yesod c - -> yesod - -> Maybe (Routes yesod) - -> (Routes yesod -> String) - -> YesodApp -runHandler handler y route render = - runHandlerSub handler (y, id, id, render) route render - safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index fd404b45..373bef34 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- @@ -18,8 +16,8 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) - --, atomFeed - , template -- FIXME + , atomFeed + , RepAtom (..) ) where import Yesod @@ -27,12 +25,12 @@ import Data.Time.Clock (UTCTime) import Web.Encodings (formatW3) import Text.Hamlet.Monad -{- -atomFeed :: Yesod y => AtomFeed -> Handler y AtomFeedResponse -atomFeed f = do - y <- getYesod - return $ AtomFeedResponse f $ approot y --} +newtype RepAtom = RepAtom Content +instance HasReps RepAtom where + chooseRep (RepAtom c) _ = return (TypeAtom, c) + +atomFeed :: AtomFeed (Routes sub) -> GHandler sub master RepAtom +atomFeed = fmap RepAtom . hamletToContent . template data AtomFeed url = AtomFeed { atomTitle :: String @@ -41,12 +39,6 @@ data AtomFeed url = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry url] } -{- FIXME -instance HasReps (AtomFeed url) where - chooseRep = defChooseRep - [ (TypeAtom, return . cs) - ] --} data AtomFeedEntry url = AtomFeedEntry { atomEntryLink :: url @@ -55,7 +47,7 @@ data AtomFeedEntry url = AtomFeedEntry , atomEntryContent :: HtmlContent } -xmlns :: a -> HtmlContent +xmlns :: AtomFeed url -> HtmlContent xmlns _ = cs "http://www.w3.org/2005/Atom" template :: AtomFeed url -> Hamlet url IO () diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 1530ec3e..04147fc3 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -5,7 +5,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME I'd like to get rid of this +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth @@ -39,7 +40,6 @@ import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 import Data.Maybe ---FIXME import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) import Control.Applicative ((<$>)) @@ -48,17 +48,15 @@ import Control.Applicative ((<$>)) data LoginType = OpenId | Rpxnow -class Yesod y => YesodAuth y where - onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth y () - data Auth = Auth { defaultDest :: String - --, onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master () + , onRpxnowLogin :: forall master. Yesod master + => Rpxnow.Identifier -> GHandler Auth master () , rpxnowApiKey :: Maybe String , defaultLoginType :: LoginType } -$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes| +$(mkYesodSub "Auth" [''Yesod] [$parseRoutes| /check Check GET /logout Logout GET /openid OpenIdR GET @@ -129,7 +127,7 @@ getOpenIdComplete = do redirectToDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -handleRpxnowR :: YesodAuth master => GHandler Auth master () +handleRpxnowR :: Yesod master => GHandler Auth master () handleRpxnowR = do ay <- getYesod apiKey <- case rpxnowApiKey ay of @@ -148,7 +146,8 @@ handleRpxnowR = do (s:_) -> s (d:_) -> d ident <- liftIO $ Rpxnow.authenticate apiKey token - onRpxnowLogin ident + auth <- getYesod + onRpxnowLogin auth ident header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident redirectToDest RedirectTemporary dest diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 95e32c22..542224a2 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap @@ -20,13 +18,11 @@ module Yesod.Helpers.Sitemap , robots , SitemapUrl (..) , SitemapChangeFreq (..) - , SitemapResponse (..) ) where import Yesod ---FIXME import Web.Encodings (formatW3) +import Web.Encodings (formatW3) import Data.Time (UTCTime) -import Data.Convertible.Text data SitemapChangeFreq = Always | Hourly @@ -35,57 +31,45 @@ data SitemapChangeFreq = Always | Monthly | Yearly | Never -instance ConvertSuccess SitemapChangeFreq String where - convertSuccess Always = "always" - convertSuccess Hourly = "hourly" - convertSuccess Daily = "daily" - convertSuccess Weekly = "weekly" - convertSuccess Monthly = "monthly" - convertSuccess Yearly = "yearly" - convertSuccess Never = "never" +showFreq :: SitemapChangeFreq -> String +showFreq Always = "always" +showFreq Hourly = "hourly" +showFreq Daily = "daily" +showFreq Weekly = "weekly" +showFreq Monthly = "monthly" +showFreq Yearly = "yearly" +showFreq Never = "never" {- FIXME instance ConvertSuccess SitemapChangeFreq Html where convertSuccess = (cs :: String -> Html) . cs -} -data SitemapUrl = SitemapUrl - { sitemapLoc :: Location +data SitemapUrl url = SitemapUrl + { sitemapLoc :: url , sitemapLastMod :: UTCTime , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double } -data SitemapResponse = SitemapResponse [SitemapUrl] Approot -instance ConvertSuccess SitemapResponse Content where - convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs -{- FIXME -instance ConvertSuccess SitemapResponse Html where - convertSuccess (SitemapResponse urls ar) = - Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls - where - sitemapNS = "http://www.sitemaps.org/schemas/sitemap/0.9" - helper :: SitemapUrl -> Html - helper (SitemapUrl loc modTime freq pri) = - Tag "url" [] $ HtmlList - [ Tag "loc" [] $ cs $ showLocation ar loc - , Tag "lastmod" [] $ cs $ formatW3 modTime - , Tag "changefreq" [] $ cs freq - , Tag "priority" [] $ cs $ show pri - ] --} -instance HasReps SitemapResponse where - chooseRep = defChooseRep - [ (TypeXml, return . cs) - ] +sitemapNS :: [SitemapUrl url] -> HtmlContent +sitemapNS _ = cs "http://www.sitemaps.org/schemas/sitemap/0.9" -sitemap :: Yesod y => [SitemapUrl] -> Handler y SitemapResponse -sitemap urls = do - yesod <- getYesod - return $ SitemapResponse urls $ approot yesod +template :: [SitemapUrl url] -> Hamlet url IO () +template = [$hamlet| +%urlset!xmlns=$sitemapNS$ + $forall id url + %url + %loc @url.sitemapLoc@ + %lastmod $url.sitemapLastMod.formatW3.cs$ + %changefreq $url.sitemapChangeFreq.showFreq.cs$ + %priority $url.priority.show.cs$ +|] -robots :: Yesod yesod => Handler yesod [(ContentType, Content)] -robots = do - yesod <- getYesod - return $ staticRep TypePlain $ "Sitemap: " ++ showLocation - (approot yesod) - (RelLoc "sitemap.xml") +sitemap :: [SitemapUrl (Routes sub)] -> GHandler sub master RepXml +sitemap = fmap RepXml . hamletToContent . template + +robots :: Routes sub -- ^ sitemap url + -> GHandler sub master RepPlain +robots smurl = do + r <- getUrlRender + return $ RepPlain $ cs $ "Sitemap: " ++ r smurl diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 23dbd047..e7ce3f76 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in web-routes-quasi --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs deleted file mode 100644 index 67453d5c..00000000 --- a/Yesod/Resource.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Resource - ( parseRoutes - , mkYesod - , mkYesodSub - ) where - -import Web.Routes.Quasi -import Yesod.Handler -import Language.Haskell.TH.Syntax -import Yesod.Yesod - -mkYesod :: String -> [Resource] -> Q [Dec] -mkYesod name res = do - let name' = mkName name - let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes") - let site = mkName $ "site" ++ name - let gsbod = NormalB $ VarE site - let yes' = FunD (mkName "getSite") [Clause [] gsbod []] - let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes'] - CreateRoutesResult x y z <- createRoutes $ CreateRoutesSettings - { crRoutes = mkName $ name ++ "Routes" - , crApplication = ConT ''YesodApp - , crArgument = ConT $ mkName name - , crExplode = VarE $ mkName "runHandler'" - , crResources = res - , crSite = site - } - return [tySyn, yes, x, {-y, -}z] - -mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] -mkYesodSub name ctxs res = do - let name' = mkName name - let site = mkName $ "site" ++ name - let tySyn = TySynInstD ''Routes [ConT name'] (ConT $ mkName $ name ++ "Routes") - let sa = ConT (mkName name) - let man = mkName "master" - let ma = VarT man -- FIXME - let sr = ConT $ mkName $ name ++ "Routes" - let mr = ConT ''Routes `AppT` VarT man - let arg = TupleT 4 - `AppT` ma - `AppT` (ArrowT `AppT` ma `AppT` sa) - `AppT` (ArrowT `AppT` sr `AppT` mr) - `AppT` (ArrowT `AppT` mr `AppT` ConT ''String) - CreateRoutesResult x (SigD yname y) z <- createRoutes $ CreateRoutesSettings - { crRoutes = mkName $ name ++ "Routes" - , crApplication = ConT ''YesodApp - , crArgument = arg - , crExplode = VarE $ mkName "runHandlerSub'" - , crResources = res - , crSite = site - } - let helper claz = ClassP claz [VarT man] - let ctxs' = map helper ctxs - let y' = ForallT [PlainTV man] ctxs' y - return [tySyn, x, {-SigD yname y',-} z] diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 2c48a9bb..792092d2 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -31,6 +31,8 @@ module Yesod.Response , RepHtml (..) , RepJson (..) , RepHtmlJson (..) + , RepPlain (..) + , RepXml (..) -- * Response type , Response (..) -- * Special responses @@ -157,6 +159,12 @@ instance HasReps RepHtmlJson where [ (TypeHtml, html) , (TypeJson, json) ] +newtype RepPlain = RepPlain Content +instance HasReps RepPlain where + chooseRep (RepPlain c) _ = return (TypePlain, c) +newtype RepXml = RepXml Content +instance HasReps RepXml where + chooseRep (RepXml c) _ = return (TypeXml, c) data Response = Response W.Status [Header] ContentType Content diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 30df8353..d40b1464 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -5,40 +5,22 @@ module Yesod.Yesod , YesodSite (..) , simpleApplyLayout , getApproot - , toWaiApp - , basicHandler ) where import Yesod.Response import Yesod.Request -import Yesod.Definitions import Yesod.Hamlet -import Yesod.Handler hiding (badMethod) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 +import Yesod.Handler import Data.Convertible.Text import Control.Arrow ((***)) - -import Data.Maybe (fromMaybe) -import Web.Mime -import Web.Encodings (parseHttpAccept) -import Web.Routes (Site (..), encodePathInfo, decodePathInfo) -import Web.Routes.Quasi (QuasiSite (..)) -import Data.List (intercalate) - -import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath import Network.Wai.Middleware.ClientSession -import Network.Wai.Middleware.Jsonp -import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.Gzip +import qualified Network.Wai as W +import Yesod.Definitions -import qualified Network.Wai.Handler.SimpleServer as SS -import qualified Network.Wai.Handler.CGI as CGI -import System.Environment (getEnvironment) +import Web.Routes.Quasi (QuasiSite (..)) class YesodSite y where - getSite :: QuasiSite YesodApp (Routes y) y (Routes master) master + getSite :: QuasiSite YesodApp (Routes y) y (Routes y) y class YesodSite a => Yesod a where -- | The encryption key to be used for encrypting client sessions. @@ -134,77 +116,3 @@ defaultErrorHandler (BadMethod m) = %h1 Method Not Supported %p Method "$cs$" not supported |] m - -toWaiApp :: Yesod y => y -> IO W.Application -toWaiApp a = do - key' <- encryptKey a - let mins = clientSessionDuration a - return $ gzip - $ jsonp - $ methodOverride - $ cleanPath - $ \thePath -> clientsession encryptedCookies key' mins - $ toWaiApp' a thePath - -toWaiApp' :: Yesod y - => y - -> [B.ByteString] - -> [(B.ByteString, B.ByteString)] - -> W.Request - -> IO W.Response -toWaiApp' y resource session env = do - let site = getSite - method = B8.unpack $ W.methodToBS $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) $ cleanupSegments resource - eurl = quasiParse site pathSegments - render u = approot y ++ '/' - : encodePathInfo (fixSegs $ quasiRender site u) - rr <- parseWaiRequest env session - onRequest y rr - print pathSegments -- FIXME remove - let ya = case eurl of - Nothing -> runHandler (errorHandler y NotFound) y Nothing render - Just url -> quasiDispatch site - render - url - id - y - id - (badMethod method) - method - let eh er = runHandler (errorHandler y er) y eurl render - unYesodApp ya eh rr types >>= responseToWaiResponse - -cleanupSegments :: [B.ByteString] -> [String] -cleanupSegments = decodePathInfo . intercalate "/" . map B8.unpack - -httpAccept :: W.Request -> [ContentType] -httpAccept = map contentTypeFromBS - . parseHttpAccept - . fromMaybe B.empty - . lookup W.Accept - . W.requestHeaders - --- | Runs an application with CGI if CGI variables are present (namely --- PATH_INFO); otherwise uses SimpleServer. -basicHandler :: Int -- ^ port number - -> W.Application -> IO () -basicHandler port app = do - vars <- getEnvironment - case lookup "PATH_INFO" vars of - Nothing -> do - putStrLn $ "http://localhost:" ++ show port ++ "/" - SS.run port app - Just _ -> CGI.run app - -badMethod :: String -> YesodApp -badMethod m = YesodApp $ \eh req cts - -> unYesodApp (eh $ BadMethod m) eh req cts - -fixSegs :: [String] -> [String] -fixSegs [] = [] -fixSegs [x] - | any (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash -fixSegs (x:xs) = x : fixSegs xs diff --git a/yesod.cabal b/yesod.cabal index 2f4b8da8..067a0e5c 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -68,7 +68,7 @@ library Yesod.Form Yesod.Hamlet Yesod.Handler - Yesod.Resource + Yesod.Dispatch Yesod.Yesod Yesod.Helpers.Auth Yesod.Helpers.Static