diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b5a8853a..3eaba5db 100644 --- a/Yesod/Handler.hs +++ b/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) - -> 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 diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index ecb7d457..010f0647 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -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 diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 5476d16f..0fd78c43 100644 --- a/Yesod/Resource.hs +++ b/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 diff --git a/Yesod/Response.hs b/Yesod/Response.hs index f702bffd..ad4311ad 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -201,6 +201,7 @@ data ErrorResponse = | InternalError String | InvalidArgs [(ParamName, ParamError)] | PermissionDenied + | BadMethod deriving (Show, Eq) getStatus :: ErrorResponse -> W.Status diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index c5b891e4..f63c89b0 100644 --- a/Yesod/Yesod.hs +++ b/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 - -> 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