Began refactoring

2010-04-20 15:35:41 -07:00 · 2010-04-20 15:35:41 -07:00 · e280e284f8
commit e280e284f8
parent c875c949fe
13 changed files with 248 additions and 286 deletions
--- a/.gitignore
+++ b/.gitignore
@ -1,4 +1,4 @@
-dist
+/dist/
 *.swp
 client_session_key.aes
 *.hi
--- 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
--- 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
--- a/Yesod/Dispatch.hs
+++ 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
--- 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
--- 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 ()
--- 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
--- 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
--- 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
--- a/Yesod/Resource.hs
+++ b/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]
--- 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

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