Attempting to use SendFile throughout

This commit is contained in:
Michael Snoyman 2010-01-25 02:16:55 +02:00
parent ec5b9863d5
commit 90e197ae46
5 changed files with 18 additions and 24 deletions

View File

@ -26,6 +26,7 @@ module Yesod.Handler
--, ToHandler (..) --, ToHandler (..)
-- * Special handlers -- * Special handlers
, redirect , redirect
, sendFile
, notFound , notFound
, permissionDenied , permissionDenied
, invalidArgs , invalidArgs
@ -37,7 +38,6 @@ module Yesod.Handler
import Yesod.Request import Yesod.Request
import Yesod.Response import Yesod.Response
import Yesod.Rep
import Yesod.Template import Yesod.Template
import Web.Mime import Web.Mime
@ -140,6 +140,9 @@ errorResponse er = Handler $ \_ -> return ([], HCError er)
redirect :: RedirectType -> String -> Handler yesod a redirect :: RedirectType -> String -> Handler yesod a
redirect rt = specialResponse . Redirect rt redirect rt = specialResponse . Redirect rt
sendFile :: ContentType -> FilePath -> Handler yesod a
sendFile ct = specialResponse . SendFile ct
-- | Return a 404 not found page. Also denotes no handler available. -- | Return a 404 not found page. Also denotes no handler available.
notFound :: Handler yesod a notFound :: Handler yesod a
notFound = errorResponse NotFound notFound = errorResponse NotFound

View File

@ -24,13 +24,13 @@ module Yesod.Helpers.Static
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Control.Applicative ((<$>))
import Control.Monad import Control.Monad
import Yesod import Yesod
import Data.List (intercalate) import Data.List (intercalate)
type FileLookup = FilePath -> IO (Maybe B.ByteString) -- FIXME this type is getting ugly...
type FileLookup = FilePath -> IO (Maybe (Either FilePath B.ByteString))
-- | A 'FileLookup' for files in a directory. Note that this function does not -- | 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 -- check if the requested path does unsafe things, eg expose hidden files. You
@ -43,7 +43,7 @@ fileLookupDir dir fp = do
let fp' = dir ++ '/' : fp let fp' = dir ++ '/' : fp
exists <- doesFileExist fp' exists <- doesFileExist fp'
if exists if exists
then Just <$> B.readFile fp' -- FIXME replace lazy I/O when possible then return $ Just $ Left fp'
else return Nothing else return Nothing
serveStatic :: FileLookup -> Verb -> [String] serveStatic :: FileLookup -> Verb -> [String]
@ -58,7 +58,8 @@ getStatic fl fp' = do
content <- liftIO $ fl fp content <- liftIO $ fl fp
case content of case content of
Nothing -> notFound Nothing -> notFound
Just bs -> return [(typeByExt $ ext fp, cs bs)] 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

View File

@ -32,7 +32,6 @@ module Yesod.Rep
, Template (..) , Template (..)
, TemplateFile (..) , TemplateFile (..)
, Static (..) , Static (..)
, StaticFile (..)
#if TEST #if TEST
, testSuite , testSuite
#endif #endif
@ -40,7 +39,6 @@ module Yesod.Rep
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.Text.Lazy (Text) import Data.Text.Lazy (Text)
import qualified Data.ByteString.Lazy as BL
import Web.Mime import Web.Mime
#if TEST #if TEST
@ -102,19 +100,6 @@ data Static = Static ContentType ByteString
instance HasReps Static where instance HasReps Static where
chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs) chooseRep (Static ct bs) _ = return (ct, Content $ const $ return bs)
data StaticFile = StaticFile ContentType FilePath
instance HasReps StaticFile where
chooseRep (StaticFile ct fp) _ = do
bs <- BL.readFile fp
return (ct, Content $ const $ return bs)
-- Useful instances of HasReps
instance HasReps HtmlObject where
chooseRep = defChooseRep
[ (TypeHtml, return . cs . unHtmlDoc . cs)
, (TypeJson, return . cs . unJsonDoc . cs)
]
#if TEST #if TEST
caseChooseRepHO :: Assertion caseChooseRepHO :: Assertion
caseChooseRepHO = do caseChooseRepHO = do

View File

@ -47,6 +47,7 @@ import Data.Maybe (mapMaybe)
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.Text.Lazy (Text) import Data.Text.Lazy (Text)
import Yesod.Definitions import Yesod.Definitions
import Data.Object.Json
import Web.Encodings (formatW3) import Web.Encodings (formatW3)
import qualified Hack import qualified Hack
@ -61,7 +62,6 @@ import Data.Object.Html
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
#endif #endif
import Data.Convertible.Text (cs)
import Web.Mime import Web.Mime
newtype Content = Content { unContent :: [Language] -> IO ByteString } newtype Content = Content { unContent :: [Language] -> IO ByteString }
@ -79,8 +79,7 @@ instance ConvertSuccess XmlDoc Content where
type ChooseRep = [ContentType] -> IO (ContentType, Content) type ChooseRep = [ContentType] -> IO (ContentType, Content)
-- | Any type which can be converted to representations. There must be at least -- | Any type which can be converted to representations.
-- one representation for each type.
class HasReps a where class HasReps a where
chooseRep :: a -> ChooseRep chooseRep :: a -> ChooseRep
@ -114,6 +113,13 @@ instance HasReps [(ContentType, Content)] where
(x:_) -> x (x:_) -> x
_ -> error "chooseRep [(ContentType, Content)] of empty" _ -> error "chooseRep [(ContentType, Content)] of empty"
-- FIXME remove this instance? only good for debugging, maybe special debugging newtype?
instance HasReps HtmlObject where
chooseRep = defChooseRep
[ (TypeHtml, return . cs . unHtmlDoc . cs)
, (TypeJson, return . cs . unJsonDoc . cs)
]
data Response = Response Int [Header] ContentType Content data Response = Response Int [Header] ContentType Content
-- | Different types of redirects. -- | Different types of redirects.

View File

@ -6,7 +6,6 @@ module Yesod.Yesod
, toHackApp , toHackApp
) where ) where
import Yesod.Rep
import Data.Object.Html (toHtmlObject) import Data.Object.Html (toHtmlObject)
import Yesod.Response import Yesod.Response
import Yesod.Request import Yesod.Request