Initial migration to web-routes-quasi

Yesod/Handler.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeFamilies #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -21,8 +22,11 @@ module Yesod.Handler
     ( -- * Handler monad
       Handler
     , getYesod
+    , getUrlRender
     , runHandler
     , liftIO
+    , YesodApp
+    , Routes
       -- * Special handlers
     , redirect
     , sendFile
@@ -51,7 +55,14 @@ import Data.Object.Html
 import qualified Data.ByteString.Lazy as BL
 import qualified Network.Wai as W
 
-data HandlerData yesod = HandlerData Request yesod
+type family Routes y
+
+data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String)
+
+type YesodApp yesod = (ErrorResponse -> Handler yesod ChooseRep)
+                   -> Request
+                   -> [ContentType]
+                   -> IO Response
 
 ------ Handler monad
 newtype Handler yesod a = Handler {
@@ -84,27 +95,25 @@ instance MonadIO (Handler yesod) where
 instance Failure ErrorResponse (Handler yesod) where
     failure e = Handler $ \_ -> return ([], HCError e)
 instance RequestReader (Handler yesod) where
-    getRequest = Handler $ \(HandlerData rr _)
+    getRequest = Handler $ \(HandlerData rr _ _)
                         -> return ([], HCContent rr)
 
 getYesod :: Handler yesod yesod
-getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod)
+getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod)
 
-runHandler :: Handler yesod ChooseRep
-           -> (ErrorResponse -> Handler yesod ChooseRep)
-           -> Request
-           -> yesod
-           -> [ContentType]
-           -> IO Response
-runHandler handler eh rr y cts = do
+getUrlRender :: Handler yesod (Routes yesod -> String)
+getUrlRender = Handler $ \(HandlerData _ _ r) -> return ([], HCContent r)
+
+runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp yesod
+runHandler handler y render eh rr cts = do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
     (headers, contents) <- Control.Exception.catch
-        (unHandler handler $ HandlerData rr y)
+        (unHandler handler $ HandlerData rr y render)
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
-            Response _ hs ct c <- runHandler (eh e) safeEh rr y cts
+            Response _ hs ct c <- runHandler (eh e) y render safeEh rr cts
             let hs' = headers ++ hs
             return $ Response (getStatus e) hs' ct c
     let sendFile' ct fp = do
@@ -119,7 +128,7 @@ runHandler handler eh rr y cts = do
             (sendFile' ct fp)
             (handleError . toErrorHandler)
         HCContent a -> do
-            (ct, c) <- a cts
+            (ct, c) <- chooseRep a cts
             return $ Response W.Status200 headers ct c
 
 safeEh :: ErrorResponse -> Handler yesod ChooseRep

Yesod/Resource.hs

@@ -1,16 +1,29 @@
----------------------------------------------------------
---
--- Module        : Yesod.Resource
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Stable
--- Portability   : portable
---
--- Defines the ResourceName class.
---
----------------------------------------------------------
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Yesod.Resource
-    (
+    ( parseRoutes
+    , mkYesod
     ) where
+
+import Web.Routes.Quasi (parseRoutes, createRoutes, Resource (..))
+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 yaname = mkName $ name ++ "YesodApp"
+    let ya = TySynD yaname [] $ ConT ''YesodApp `AppT` ConT name'
+    let tySyn = TySynInstD ''Routes [ConT $ name'] (ConT $ mkName $ name ++ "Routes")
+    let hand = TySynD (mkName $ name ++ "Handler") [PlainTV $ mkName "a"]
+             $ ConT ''Handler `AppT` ConT name' `AppT` VarT (mkName "a")
+    let gsbod = NormalB $ VarE $ mkName $ "site" ++ name ++ "Routes"
+    let yes' = FunD (mkName "getSite") [Clause [] gsbod []]
+    let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']
+    decs <- createRoutes (name ++ "Routes")
+                         yaname
+                         name'
+                         "runHandler"
+                         res
+    return $ ya : tySyn : hand : yes : decs

Yesod/Yesod.hs

@@ -1,6 +1,7 @@
 -- | The basic typeclass for a Yesod application.
 module Yesod.Yesod
     ( Yesod (..)
+    , YesodSite (..)
     , YesodApproot (..)
     , applyLayout'
     , applyLayoutJson
@@ -20,6 +21,7 @@ import qualified Data.ByteString as B
 import Data.Maybe (fromMaybe)
 import Web.Mime
 import Web.Encodings (parseHttpAccept)
+import Web.Routes (Site (..))
 
 import qualified Network.Wai as W
 import Network.Wai.Middleware.CleanPath
@@ -32,11 +34,13 @@ import qualified Network.Wai.Handler.SimpleServer as SS
 import qualified Network.Wai.Handler.CGI as CGI
 import System.Environment (getEnvironment)
 
-class Yesod a where
-    -- | Please use the Quasi-Quoter, you\'ll be happier. For more information,
-    -- see the examples/fact.lhs sample.
-    resources :: Resource -> W.Method -> Handler a ChooseRep
+class YesodSite y where
+    getSite :: ((String -> YesodApp y) -> YesodApp y) -- ^ get the method
+            -> YesodApp y -- ^ bad method
+            -> y
+            -> Site (Routes y) (YesodApp y)
 
+class YesodSite a => Yesod a where
     -- | The encryption key to be used for encrypting client sessions.
     encryptKey :: a -> IO Word256
     encryptKey _ = getKey defaultKeyFile
@@ -62,6 +66,8 @@ class Yesod a where
     onRequest :: a -> Request -> IO ()
     onRequest _ _ = return ()
 
+    badMethod :: a -> YesodApp a
+
 class Yesod a => YesodApproot a where
     -- | An absolute URL to the root of the application.
     approot :: a -> Approot
@@ -133,12 +139,24 @@ toWaiApp' :: Yesod y
           -> W.Request
           -> IO W.Response
 toWaiApp' y resource session env = do
-    let types = httpAccept env
-        handler = resources (map cs resource) $ W.requestMethod env
-    rr <- parseWaiRequest env session
-    onRequest y rr
-    res <- runHandler handler errorHandler rr y types
-    responseToWaiResponse res
+    let site = getSite getMethod (badMethod y) y
+        types = httpAccept env
+        pathSegments = map cleanupSegment resource
+        eurl = parsePathSegments site pathSegments
+    case eurl of
+        Left _ -> error "FIXME: send 404 message"
+        Right url -> do
+            rr <- parseWaiRequest env session
+            onRequest y rr
+            let render = error "FIXME: render" -- use formatPathSegments
+            res <- handleSite site render url errorHandler rr types
+            responseToWaiResponse res
+
+getMethod :: (String -> YesodApp y) -> YesodApp y
+getMethod = error "FIXME: getMethod"
+
+cleanupSegment :: B.ByteString -> String
+cleanupSegment = error "FIXME: cleanupSegment"
 
 httpAccept :: W.Request -> [ContentType]
 httpAccept = map contentTypeFromBS

yesod.cabal

@@ -58,7 +58,9 @@ library
                      attempt >= 0.2.1 && < 0.3,
                      template-haskell,
                      failure >= 0.0.0 && < 0.1,
-                     safe-failure >= 0.4.0 && < 0.5
+                     safe-failure >= 0.4.0 && < 0.5,
+                     web-routes >= 0.20 && < 0.21,
+                     web-routes-quasi >= 0.0 && < 0.1
     exposed-modules: Yesod
                      Yesod.Request
                      Yesod.Response