Match changes in web-routes-quasi
This commit is contained in:
Michael Snoyman
parent
4a8f674ba1
commit
4163c55e0d
@ -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)
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> IO Response
|
||||
newtype YesodApp = YesodApp
|
||||
{ unYesodApp
|
||||
:: (ErrorResponse -> YesodApp)
|
||||
-> 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 handler y render eh rr cts = do
|
||||
runHandler :: HasReps c => Handler yesod c -> yesod -> (Routes yesod -> String) -> YesodApp
|
||||
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 er = do
|
||||
safeEh :: ErrorResponse -> YesodApp
|
||||
safeEh er = YesodApp $ \_ _ _ -> do
|
||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
||||
return $ chooseRep
|
||||
( Tag "title" [] $ cs "Internal Server Error"
|
||||
, toHtmlObject "Internal server error"
|
||||
)
|
||||
return $ Response W.Status500 [] TypePlain $ cs "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
|
||||
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# 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 dir fp = do
|
||||
fileLookupDir :: FilePath -> Static
|
||||
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
|
||||
isUnsafe [] = True
|
||||
isUnsafe ('.':_) = True
|
||||
isUnsafe _ = False
|
||||
where
|
||||
isUnsafe [] = True
|
||||
isUnsafe ('.':_) = True
|
||||
isUnsafe _ = False
|
||||
|
||||
getStaticRoute :: [String] -> Handler Static [(ContentType, Content)]
|
||||
getStaticRoute fp = do
|
||||
Static fl <- getYesod
|
||||
getStatic fl fp
|
||||
|
||||
@ -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
|
||||
|
||||
@ -201,6 +201,7 @@ data ErrorResponse =
|
||||
| InternalError String
|
||||
| InvalidArgs [(ParamName, ParamError)]
|
||||
| PermissionDenied
|
||||
| BadMethod
|
||||
deriving (Show, Eq)
|
||||
|
||||
getStatus :: ErrorResponse -> W.Status
|
||||
|
||||
@ -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
|
||||
-> YesodApp y -- ^ bad method
|
||||
-> y
|
||||
-> Site (Routes y) (YesodApp y)
|
||||
getSite :: Site (Routes y) (String -> YesodApp -> y -> YesodApp)
|
||||
|
||||
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 = defaultErrorHandler
|
||||
errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep
|
||||
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
|
||||
=> ErrorResponse
|
||||
-> Handler y ChooseRep
|
||||
defaultErrorHandler :: Yesod y => 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
|
||||
Right url -> handleSite site render url
|
||||
ya errorHandler 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
|
||||
Left _ -> runHandler (errorHandler y NotFound) y render
|
||||
Right url -> handleSite site render url method badMethod y
|
||||
let eh er = runHandler (errorHandler y er) y render
|
||||
unYesodApp ya eh rr types >>= responseToWaiResponse
|
||||
|
||||
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 _ _ _ = return $ Response W.Status405 [] TypePlain
|
||||
$ cs "Method not supported"
|
||||
badMethod :: YesodApp
|
||||
badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts
|
||||
|
||||
hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml
|
||||
hamletToRepHtml h = do
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user