Using wai-app-static (not sure if it will stick yet), does not fully work
This commit is contained in:
Michael Snoyman
parent
3b2a3881e6
commit
2db05e2055
@ -29,10 +29,8 @@ module Yesod.Helpers.Static
|
||||
Static (..)
|
||||
, StaticRoute (..)
|
||||
-- * Lookup files in filesystem
|
||||
, fileLookupDir
|
||||
, staticFiles
|
||||
-- * Embed files
|
||||
, mkEmbedFiles
|
||||
, getStaticHandler
|
||||
-- * Hashing
|
||||
, base64md5
|
||||
@ -48,8 +46,10 @@ import Data.Maybe (fromMaybe)
|
||||
import Yesod.Handler
|
||||
import Yesod.Content
|
||||
import Yesod.Core
|
||||
import Yesod.Request
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Control.Monad.Trans.Class as Trans
|
||||
|
||||
import Data.List (intercalate)
|
||||
import Language.Haskell.TH
|
||||
@ -62,6 +62,9 @@ import qualified Data.ByteString.Base64
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.Serialize
|
||||
|
||||
import Network.Wai.Application.Static
|
||||
(defaultMimeTypeByExt, StaticSettings (..), staticApp, defaultListing)
|
||||
|
||||
#if TEST
|
||||
import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
@ -71,9 +74,8 @@ import Test.HUnit hiding (Test)
|
||||
-- | A function for looking up file contents. For serving from the file system,
|
||||
-- see 'fileLookupDir'.
|
||||
data Static = Static
|
||||
{ staticLookup :: FilePath -> IO (Maybe (Either FilePath Content))
|
||||
-- | Mapping from file extension to content type. See 'typeByExt'.
|
||||
, staticTypes :: [(String, ContentType)]
|
||||
{ staticPrefix :: FilePath
|
||||
-- FIXME why not just put in a StaticSettings here?
|
||||
}
|
||||
|
||||
-- | Manually construct a static route.
|
||||
@ -92,54 +94,21 @@ instance YesodSubSite Static master where
|
||||
getSubSite = Site
|
||||
{ handleSite = \_ (StaticRoute ps _) m ->
|
||||
case m of
|
||||
"GET" -> Just $ fmap chooseRep $ getStaticRoute ps
|
||||
"GET" -> Just $ do
|
||||
Static prefix <- getYesodSub
|
||||
req <- waiRequest
|
||||
res <- Trans.lift $ staticApp StaticSettings
|
||||
{ ssFolder = prefix
|
||||
, ssIndices = []
|
||||
, ssListing = Just defaultListing
|
||||
, ssGetMimeType = return . defaultMimeTypeByExt
|
||||
} req
|
||||
sendWaiResponse res
|
||||
_ -> Nothing
|
||||
, formatPathSegments = \(StaticRoute x y) -> (x, y)
|
||||
, parsePathSegments = \x -> Right $ StaticRoute x []
|
||||
}
|
||||
|
||||
-- | Lookup files in a specific directory.
|
||||
--
|
||||
-- If you are just using this in combination with the static subsite (you
|
||||
-- probably are), the handler itself checks that no unsafe paths are being
|
||||
-- requested. In particular, no path segments may begin with a single period,
|
||||
-- so hidden files and parent directories are safe.
|
||||
--
|
||||
-- For the second argument to this function, you can just use 'typeByExt'.
|
||||
fileLookupDir :: FilePath -> [(String, ContentType)] -> Static
|
||||
fileLookupDir dir = Static $ \fp -> do
|
||||
let fp' = dir ++ '/' : fp
|
||||
exists <- doesFileExist fp'
|
||||
if exists
|
||||
then return $ Just $ Left fp'
|
||||
else return Nothing
|
||||
|
||||
-- | Lookup files in a specific directory, and embed them into the haskell source.
|
||||
--
|
||||
-- A variation of fileLookupDir which allows subsites distributed via cabal to include
|
||||
-- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler
|
||||
-- for dispatching static content for a subsite.
|
||||
mkEmbedFiles :: FilePath -> Q Exp
|
||||
mkEmbedFiles d = do
|
||||
fs <- qRunIO $ getFileList d
|
||||
clauses <- mapM (mkClause . intercalate "/") fs
|
||||
defC <- defaultClause
|
||||
return $ static $ clauses ++ [defC]
|
||||
where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f
|
||||
f = mkName "f"
|
||||
fun clauses = FunD f clauses
|
||||
defaultClause = do
|
||||
b <- [| return Nothing |]
|
||||
return $ Clause [WildP] (NormalB b) []
|
||||
|
||||
mkClause p = do
|
||||
content <- qRunIO $ readFile $ d ++ '/':p
|
||||
let pat = LitP $ StringL p
|
||||
foldAppE = foldl1 AppE
|
||||
content' = return $ LitE $ StringL $ content
|
||||
body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |]
|
||||
return $ Clause [pat] body []
|
||||
|
||||
-- | Dispatch static route for a subsite
|
||||
--
|
||||
-- Subsites with static routes can't (yet) define Static routes the same way "master" sites can.
|
||||
@ -160,26 +129,6 @@ getStaticHandler static toSubR pieces = do
|
||||
staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep))
|
||||
handler = fromMaybe notFound $ handleSite staticSite undefined route "GET"
|
||||
|
||||
getStaticRoute :: [String]
|
||||
-> GHandler Static master (ContentType, Content)
|
||||
getStaticRoute fp' = do
|
||||
Static fl ctypes <- getYesodSub
|
||||
when (any isUnsafe fp') notFound
|
||||
let fp = intercalate "/" fp'
|
||||
content <- liftIO $ fl fp
|
||||
case content of
|
||||
Nothing -> notFound
|
||||
Just (Left fp'') -> do
|
||||
let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes
|
||||
sendFile ctype fp''
|
||||
Just (Right bs) -> do
|
||||
let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes
|
||||
return (ctype, bs)
|
||||
where
|
||||
isUnsafe [] = True
|
||||
isUnsafe ('.':_) = True
|
||||
isUnsafe _ = False
|
||||
|
||||
notHidden :: FilePath -> Bool
|
||||
notHidden ('.':_) = False
|
||||
notHidden "tmp" = False
|
||||
|
||||
@ -26,6 +26,7 @@ library
|
||||
, template-haskell
|
||||
, directory >= 1.0 && < 1.2
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, wai-app-static >= 0.0 && < 0.1
|
||||
exposed-modules: Yesod.Helpers.Static
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user