Began refactoring

.gitignore

@@ -1,4 +1,4 @@
-dist
+/dist/
 *.swp
 client_session_key.aes
 *.hi

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

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

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

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
+runHandler :: HasReps c
-               => GHandler sub master c
+           => GHandler sub master c
-               -> (Routes master -> String)
+           -> (Routes master -> String)
-               -> Routes sub
+           -> Maybe (Routes sub)
-               -> (Routes sub -> Routes master)
+           -> (Routes sub -> Routes master)
-               -> master
+           -> master
-               -> (master -> sub)
+           -> (master -> sub)
-               -> String
+           -> YesodApp
-               -> YesodApp
+runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do
-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
     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

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
+    , atomFeed
-    , template -- FIXME
+    , RepAtom (..)
     ) where
 
 import Yesod
@@ -27,12 +25,12 @@ import Data.Time.Clock (UTCTime)
 import Web.Encodings (formatW3)
 import Text.Hamlet.Monad
 
-{-
+newtype RepAtom = RepAtom Content
-atomFeed :: Yesod y => AtomFeed -> Handler y AtomFeedResponse
+instance HasReps RepAtom where
-atomFeed f = do
+    chooseRep (RepAtom c) _ = return (TypeAtom, c)
-    y <- getYesod
+
-    return $ AtomFeedResponse f $ approot y
+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 ()

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

Yesod/Helpers/Sitemap.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- 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
+showFreq :: SitemapChangeFreq -> String
-    convertSuccess Always  = "always"
+showFreq Always  = "always"
-    convertSuccess Hourly  = "hourly"
+showFreq Hourly  = "hourly"
-    convertSuccess Daily   = "daily"
+showFreq Daily   = "daily"
-    convertSuccess Weekly  = "weekly"
+showFreq Weekly  = "weekly"
-    convertSuccess Monthly = "monthly"
+showFreq Monthly = "monthly"
-    convertSuccess Yearly  = "yearly"
+showFreq Yearly  = "yearly"
-    convertSuccess Never   = "never"
+showFreq Never   = "never"
 {- FIXME
 instance ConvertSuccess SitemapChangeFreq Html where
     convertSuccess = (cs :: String -> Html) . cs
 -}
 
-data SitemapUrl = SitemapUrl
+data SitemapUrl url = SitemapUrl
-    { sitemapLoc :: Location
+    { 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
+sitemapNS :: [SitemapUrl url] -> HtmlContent
-    chooseRep = defChooseRep
+sitemapNS _ = cs "http://www.sitemaps.org/schemas/sitemap/0.9"
-        [ (TypeXml, return . cs)
-        ]
 
-sitemap :: Yesod y => [SitemapUrl] -> Handler y SitemapResponse
+template :: [SitemapUrl url] -> Hamlet url IO ()
-sitemap urls = do
+template = [$hamlet|
-    yesod <- getYesod
+%urlset!xmlns=$sitemapNS$
-    return $ SitemapResponse urls $ approot yesod
+    $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)]
+sitemap :: [SitemapUrl (Routes sub)] -> GHandler sub master RepXml
-robots = do
+sitemap = fmap RepXml . hamletToContent . template
-    yesod <- getYesod
+
-    return $ staticRep TypePlain $ "Sitemap: " ++ showLocation
+robots :: Routes sub -- ^ sitemap url
-                                      (approot yesod)
+       -> GHandler sub master RepPlain
-                                      (RelLoc "sitemap.xml")
+robots smurl = do
+    r <- getUrlRender
+    return $ RepPlain $ cs $ "Sitemap: " ++ r smurl

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

Yesod/Resource.hs

@@ -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]

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
 

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 Yesod.Handler
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as B8
 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 qualified Network.Wai as W
-import Network.Wai.Middleware.MethodOverride
+import Yesod.Definitions
-import Network.Wai.Middleware.Gzip
 
-import qualified Network.Wai.Handler.SimpleServer as SS
+import Web.Routes.Quasi (QuasiSite (..))
-import qualified Network.Wai.Handler.CGI as CGI
-import System.Environment (getEnvironment)
 
 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

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