Match changes in web-routes-quasi

Yesod/Handler.hs

@@ -25,12 +25,13 @@ module Yesod.Handler
     , getUrlRender
     , runHandler
     , liftIO
-    , YesodApp
+    , YesodApp (..)
     , Routes
       -- * Special handlers
     , redirect
     , sendFile
     , notFound
+    , badMethod
     , permissionDenied
     , invalidArgs
       -- * Setting headers
@@ -59,10 +60,13 @@ type family Routes y
 
 data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String)
 
-type YesodApp yesod = (ErrorResponse -> Handler yesod ChooseRep)
+newtype YesodApp = YesodApp
-                   -> Request
+    { unYesodApp
-                   -> [ContentType]
+    :: (ErrorResponse -> YesodApp)
-                   -> IO Response
+    -> Request
+    -> [ContentType]
+    -> IO Response
+    }
 
 ------ Handler monad
 newtype Handler yesod a = Handler {
@@ -104,8 +108,8 @@ getYesod = Handler $ \(HandlerData _ yesod _) -> return ([], HCContent yesod)
 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 :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp
-runHandler handler y render eh rr cts = do
+runHandler handler y render = YesodApp $ \eh rr cts -> do
     let toErrorHandler =
             InternalError
           . (show :: Control.Exception.SomeException -> String)
@@ -113,7 +117,7 @@ runHandler handler y render eh rr cts = do
         (unHandler handler $ HandlerData rr y render)
         (\e -> return ([], HCError $ toErrorHandler e))
     let handleError e = do
-            Response _ hs ct c <- runHandler (eh e) y render safeEh rr cts
+            Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts
             let hs' = headers ++ hs
             return $ Response (getStatus e) hs' ct c
     let sendFile' ct fp = do
@@ -131,13 +135,10 @@ runHandler handler y render eh rr cts = do
             (ct, c) <- chooseRep a cts
             return $ Response W.Status200 headers ct c
 
-safeEh :: ErrorResponse -> Handler yesod ChooseRep
+safeEh :: ErrorResponse -> YesodApp
-safeEh er = do
+safeEh er = YesodApp $ \_ _ _ -> do
     liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
-    return $ chooseRep
+    return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error"
-        ( Tag "title" [] $ cs "Internal Server Error"
-        , toHtmlObject "Internal server error"
-        )
 
 ------ Special handlers
 specialResponse :: SpecialResponse -> Handler yesod a
@@ -154,6 +155,9 @@ sendFile ct = specialResponse . SendFile ct
 notFound :: Failure ErrorResponse m => m a
 notFound = failure NotFound
 
+badMethod :: Failure ErrorResponse m => m a
+badMethod = failure BadMethod
+
 permissionDenied :: Failure ErrorResponse m => m a
 permissionDenied = failure PermissionDenied
 

Yesod/Helpers/Static.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Helpers.Static
@@ -17,9 +18,12 @@
 --
 ---------------------------------------------------------
 module Yesod.Helpers.Static
-    ( serveStatic
+    ( FileLookup
-    , FileLookup
     , fileLookupDir
+    , siteStaticRoutes
+    , StaticRoutes
+    , staticArgs
+    , Static
     ) where
 
 import System.Directory (doesFileExist)
@@ -27,38 +31,50 @@ import Control.Monad
 
 import Yesod
 import Data.List (intercalate)
+import Network.Wai
 
 type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))
 
+data Static = Static FileLookup
+
+staticArgs :: FileLookup -> Static
+staticArgs = Static
+
+$(mkYesod "Static" [$parseRoutes|
+/* StaticRoute GET
+|])
+
 -- | A 'FileLookup' for files in a directory. Note that this function does not
 -- check if the requested path does unsafe things, eg expose hidden files. You
 -- should provide this checking elsewhere.
 --
 -- If you are just using this in combination with serveStatic, serveStatic
 -- provides this checking.
-fileLookupDir :: FilePath -> FileLookup
+fileLookupDir :: FilePath -> Static
-fileLookupDir dir fp = do
+fileLookupDir dir = Static $ \fp -> do
     let fp' = dir ++ '/' : fp
     exists <- doesFileExist fp'
     if exists
         then return $ Just $ Left fp'
         else return Nothing
 
-serveStatic :: FileLookup -> Method -> [String]
-            -> Handler y [(ContentType, Content)]
-serveStatic fl GET fp = getStatic fl fp
-serveStatic _ _ _ = notFound
-
 getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)]
 getStatic fl fp' = do
     when (any isUnsafe fp') notFound
+    wai <- waiRequest
+    when (requestMethod wai /= GET) badMethod
     let fp = intercalate "/" fp'
     content <- liftIO $ fl fp
     case content of
         Nothing -> notFound
         Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp''
         Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)]
-      where
+  where
-        isUnsafe [] = True
+    isUnsafe [] = True
-        isUnsafe ('.':_) = True
+    isUnsafe ('.':_) = True
-        isUnsafe _ = False
+    isUnsafe _ = False
+
+getStaticRoute :: [String] -> Handler Static [(ContentType, Content)]
+getStaticRoute fp = do
+    Static fl <- getYesod
+    getStatic fl fp

Yesod/Resource.hs

@@ -13,15 +13,13 @@ 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 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
+                         ''YesodApp
                          name'
                          "runHandler"
                          res
-    return $ ya : tySyn : yes : decs
+    return $ tySyn : yes : decs

Yesod/Response.hs

@@ -201,6 +201,7 @@ data ErrorResponse =
     | InternalError String
     | InvalidArgs [(ParamName, ParamError)]
     | PermissionDenied
+    | BadMethod
     deriving (Show, Eq)
 
 getStatus :: ErrorResponse -> W.Status

Yesod/Yesod.hs

@@ -17,7 +17,7 @@ import Data.Object.Json (unJsonDoc)
 import Yesod.Response
 import Yesod.Request
 import Yesod.Definitions
-import Yesod.Handler
+import Yesod.Handler hiding (badMethod)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as B8
 
@@ -41,10 +41,7 @@ import qualified Network.Wai.Handler.CGI as CGI
 import System.Environment (getEnvironment)
 
 class YesodSite y where
-    getSite :: ((String -> YesodApp y) -> YesodApp y) -- ^ get the method
+    getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp)
-            -> YesodApp y -- ^ bad method
-            -> y
-            -> Site (Routes y) (YesodApp y)
 
 data PageContent url = PageContent
     { pageTitle :: Hamlet url IO HtmlContent
@@ -70,8 +67,8 @@ class YesodSite a => Yesod a where
     clientSessionDuration = const 120
 
     -- | Output error response pages.
-    errorHandler :: ErrorResponse -> Handler a ChooseRep
+    errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep
-    errorHandler = defaultErrorHandler
+    errorHandler _ = defaultErrorHandler
 
     -- | Applies some form of layout to <title> and <body> contents of a page.
     applyLayout :: a
@@ -142,9 +139,7 @@ hamletToContent h = do
 getApproot :: Yesod y => Handler y Approot
 getApproot = approot `fmap` getYesod
 
-defaultErrorHandler :: Yesod y
+defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep
-                    => ErrorResponse
-                    -> Handler y ChooseRep
 defaultErrorHandler NotFound = do
     r <- waiRequest
     applyLayout' "Not Found" $ cs $ toHtmlObject
@@ -161,6 +156,8 @@ defaultErrorHandler (InternalError e) =
     applyLayout' "Internal Server Error" $ cs $ toHtmlObject
         [ ("Internal server error", e)
         ]
+defaultErrorHandler BadMethod =
+    applyLayout' "Bad Method" $ cs "Method Not Supported"
 
 toWaiApp :: Yesod y => y -> IO W.Application
 toWaiApp a = do
@@ -180,7 +177,8 @@ toWaiApp' :: Yesod y
           -> W.Request
           -> IO W.Response
 toWaiApp' y resource session env = do
-    let site = getSite getMethod badMethod y
+    let site = getSite
+        method = B8.unpack $ W.methodToBS $ W.requestMethod env
         types = httpAccept env
         pathSegments = filter (not . null) $ cleanupSegments resource
         eurl = parsePathSegments site pathSegments
@@ -190,14 +188,10 @@ toWaiApp' y resource session env = do
     onRequest y rr
     print pathSegments
     let ya = case eurl of
-                Left _ -> runHandler (errorHandler NotFound) y render
+                Left _ -> runHandler (errorHandler y NotFound) y render
-                Right url -> handleSite site render url
+                Right url -> handleSite site render url method badMethod y
-    ya errorHandler rr types >>= responseToWaiResponse
+    let eh er = runHandler (errorHandler y er) y render
-
+    unYesodApp ya eh rr types >>= responseToWaiResponse
-getMethod :: (String -> YesodApp y) -> YesodApp y
-getMethod f eh req cts =
-    let m = B8.unpack $ W.methodToBS $ W.requestMethod $ reqWaiRequest req
-     in f m eh req cts
 
 cleanupSegments :: [B.ByteString] -> [String]
 cleanupSegments = decodePathInfo . intercalate "/" . map B8.unpack
@@ -221,9 +215,8 @@ basicHandler port app = do
             SS.run port app
         Just _ -> CGI.run app
 
-badMethod :: YesodApp y
+badMethod :: YesodApp
-badMethod _ _ _ = return $ Response W.Status405 [] TypePlain
+badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts
-                $ cs "Method not supported"
 
 hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml
 hamletToRepHtml h = do

yesod.cabal

@@ -59,7 +59,7 @@ library
                      template-haskell,
                      failure >= 0.0.0 && < 0.1,
                      safe-failure >= 0.4.0 && < 0.5,
-                     web-routes >= 0.20 && < 0.21,
+                     web-routes >= 0.22 && < 0.23,
                      web-routes-quasi >= 0.0 && < 0.1,
                      hamlet >= 0.0 && < 0.1
     exposed-modules: Yesod