diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Static --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- - --- | Serve static files from a Yesod app. --- --- This is most useful for standalone testing. When running on a production --- server (like Apache), just let the server do the static serving. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , Public (..) - , StaticRoute (..) - , PublicRoute (..) - -- * Smart constructor - , static - , publicProduction - , publicDevel - -- * Template Haskell helpers - , staticFiles - , publicFiles - {- - -- * Embed files - , getStaticHandler - -} - -- * Hashing - , base64md5 -#if TEST - , getFileListPieces -#endif - ) where - -import System.Directory -import qualified System.Time -import Control.Monad - -import Yesod.Handler -import Yesod.Core - -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize -import Data.Text (Text, pack) -import Data.Monoid (mempty) -import qualified Data.Map as M -import Data.IORef (readIORef, newIORef, writeIORef) - -import Network.Wai.Application.Static - ( StaticSettings (..), CacheSettings (..) - , defaultStaticSettings, defaultPublicSettings - , staticAppPieces - , pathFromPieces - ) - --- | generally static assets referenced in html files --- assets get a checksum query parameter appended for perfect caching --- * a far future expire date is set --- * a given asset revision will only ever be downloaded once (if the browser maintains its cache) --- if you don't want to see a checksum in the url- use Public -newtype Static = Static StaticSettings --- | same as Static, but there is no checksum query parameter appended --- generally html files and the favicon, but could be any file where you don't want the checksum parameter --- * the file checksum is used for an ETag. --- * this form of caching is not as good as the static- the browser can avoid downloading the file, but it always need to send a request with the etag value to the server to see if its copy is up to date -newtype Public = Public StaticSettings - --- | Default value of 'Static' for a given file folder. --- --- Does not have index files, uses default directory listings and default mime --- type list. -static :: String -> FilePath -> IO Static -static root fp = do - hashes <- mkHashMap fp - return $ Static $ (defaultStaticSettings (Forever $ isStaticRequest hashes)) { - ssFolder = fp - , ssMkRedirect = \_ newPath -> S8.append (S8.pack (root ++ "/")) newPath - } - where - isStaticRequest hashes reqf reqh = case M.lookup reqf hashes of - Nothing -> False - Just h -> h == reqh - --- | no directory listing -public :: String -> FilePath -> CacheSettings -> Public -public root fp cache = Public $ (defaultPublicSettings cache) { - ssFolder = fp - , ssMkRedirect = \_ newPath -> S8.append (S8.pack (root ++ "/")) newPath - } - -publicProduction :: String -> FilePath -> IO Public -publicProduction root fp = do - etags <- mkPublicProductionEtag fp - return $ public root fp etags - -publicDevel :: String -> FilePath -> IO Public -publicDevel root fp = do - etags <- mkPublicDevelEtag fp - return $ public root fp etags - - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [Text] [(Text, Text)] - deriving (Eq, Show, Read) -data PublicRoute = PublicRoute [Text] [(Text, Text)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute -type instance Route Public = PublicRoute - -instance RenderRoute StaticRoute where - renderRoute (StaticRoute x y) = (x, y) -instance RenderRoute PublicRoute where - renderRoute (PublicRoute x y) = (x, y) - -instance Yesod master => YesodDispatch Static master where - yesodDispatch (Static set) _ pieces _ _ = - Just $ staticAppPieces set pieces - -instance Yesod master => YesodDispatch Public master where - yesodDispatch (Public set) _ pieces _ _ = - Just $ staticAppPieces set pieces - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileListPieces :: FilePath -> IO [[String]] -getFileListPieces = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles dir = mkStaticFiles dir StaticSite - -publicFiles :: FilePath -> Q [Dec] -publicFiles dir = mkStaticFiles dir PublicSite - -mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString) -mkHashMap dir = do - fs <- getFileListPieces dir - hashAlist fs >>= return . M.fromList - where - hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)] - hashAlist fs = mapM hashPair fs - where - hashPair :: [String] -> IO (FilePath, S8.ByteString) - hashPair pieces = do let file = pathFromPieces dir (map pack pieces) - h <- base64md5File file - return (file, S8.pack h) - -mkPublicDevelEtag :: FilePath -> IO CacheSettings -mkPublicDevelEtag dir = do - etags <- mkHashMap dir - mtimeVar <- newIORef (M.empty :: M.Map FilePath System.Time.ClockTime) - return $ ETag $ \f -> - case M.lookup f etags of - Nothing -> return Nothing - Just checksum -> do - newt <- getModificationTime f - mtimes <- readIORef mtimeVar - oldt <- case M.lookup f mtimes of - Nothing -> writeIORef mtimeVar (M.insert f newt mtimes) >> return newt - Just ot -> return ot - return $ if newt /= oldt then Nothing else Just checksum - - -mkPublicProductionEtag :: FilePath -> IO CacheSettings -mkPublicProductionEtag dir = do - etags <- mkHashMap dir - return $ ETag $ \f -> return . M.lookup f $ etags - -data StaticSite = StaticSite | PublicSite -mkStaticFiles :: FilePath -> StaticSite -> Q [Dec] -mkStaticFiles fp StaticSite = mkStaticFiles' fp "StaticRoute" True -mkStaticFiles fp PublicSite = mkStaticFiles' fp "PublicRoute" False - -mkStaticFiles' :: FilePath -> -- ^ static directory - String -> -- ^ route constructor "StaticRoute" - Bool -> -- ^ append checksum query parameter - Q [Dec] -mkStaticFiles' fp routeConName makeHash = do - fs <- qRunIO $ getFileListPieces fp - concat `fmap` mapM mkRoute fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - mkRoute f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- [|map pack $(lift f)|] - let route = mkName routeConName - pack' <- [|pack|] - qs <- if makeHash - then do hash <- qRunIO $ base64md5File $ pathFromPieces fp (map pack f) - [|[(pack $(lift hash), mempty)]|] - else return $ ListE [] - return - [ SigD name $ ConT route - , FunD name - [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) [] - ] - ] - -base64md5File :: FilePath -> IO String -base64md5File file = do - contents <- L.readFile file - return $ base64md5 contents - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map tr - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - tr '+' = '-' - tr '/' = '_' - tr c = c - -{- FIXME --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" --} - diff --git a/Yesod/Static.hs b/Yesod/Static.hs new file mode 100644 --- /dev/null +++ b/Yesod/Static.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +--------------------------------------------------------- +-- +-- | Serve static files from a Yesod app. +-- +-- This is great for developming your application, but also for a dead-simple deployment. +-- Caching headers are automatically taken care of. +-- +-- If you are running a proxy server (like Apache or Nginx), +-- you may want to have that server do the static serving instead. +-- +-- In fact, in an ideal setup you'll serve your static files from a separate +-- domain name to save time on transmitting cookies. In that case, you may wish +-- to use 'urlRenderOverride' to redirect requests to this subsite to a +-- separate domain name. +module Yesod.Static + ( -- * Subsite + Static (..) + , StaticRoute (..) + -- * Smart constructor + , static + , staticDevel + , embed + -- * Template Haskell helpers + , staticFiles + , publicFiles + -- * Hashing + , base64md5 + ) where + +import Prelude hiding (FilePath) +import qualified Prelude +import System.Directory +--import qualified System.Time +import Control.Monad +import Data.FileEmbed (embedDir) + +import Yesod.Handler +import Yesod.Core + +import Data.List (intercalate) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Data.ByteString.Lazy as L +import Data.Digest.Pure.MD5 +import qualified Data.ByteString.Base64 +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Serialize +import Data.Text (Text, pack) +import Data.Monoid (mempty) +import qualified Data.Map as M +import Data.IORef (readIORef, newIORef, writeIORef) +import Network.Wai (pathInfo, rawPathInfo, responseLBS) +import Data.Char (isLower, isDigit) +import Data.List (foldl') +import qualified Data.ByteString as S +import Network.HTTP.Types (status301) +import System.PosixCompat.Files (getFileStatus, modificationTime) +import System.Posix.Types (EpochTime) + +import Network.Wai.Application.Static + ( StaticSettings (..) + , defaultWebAppSettings + , staticApp + , embeddedLookup + , toEmbedded + , toFilePath + , fromFilePath + , FilePath + , ETagLookup + , webAppSettingsWithLookup + ) + +newtype Static = Static StaticSettings + +-- | Default value of 'Static' for a given file folder. +-- +-- Does not have index files or directory listings. +-- Expects static files to *never* change +static :: Prelude.FilePath -> IO Static +static dir = do + hashLookup <- cachedETagLookup dir + return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup + +-- | like static, but checks to see if the file has changed +staticDevel :: Prelude.FilePath -> IO Static +staticDevel dir = do + hashLookup <- cachedETagLookupDevel dir + return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup + +-- | Produces a 'Static' based on embedding file contents in the executable at +-- compile time. +embed :: Prelude.FilePath -> Q Exp +embed fp = + [|Static (defaultWebAppSettings + { ssFolder = embeddedLookup (toEmbedded $(embedDir fp)) + })|] + + +-- | Manually construct a static route. +-- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. +-- For example, +-- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] +-- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' +-- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. +-- E.g. When generating image galleries. +data StaticRoute = StaticRoute [Text] [(Text, Text)] + deriving (Eq, Show, Read) + +type instance Route Static = StaticRoute + +instance RenderRoute StaticRoute where + renderRoute (StaticRoute x y) = (x, y) + +instance Yesod master => YesodDispatch Static master where + -- Need to append trailing slash to make relative links work + yesodDispatch _ _ [] _ _ = Just $ + \req -> return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] "" + + yesodDispatch (Static set) _ textPieces _ _ = Just $ + \req -> staticApp set req { pathInfo = textPieces } + +notHidden :: Prelude.FilePath -> Bool +notHidden "tmp" = False +notHidden s = + case s of + '.':_ -> False + _ -> True + +getFileListPieces :: Prelude.FilePath -> IO [[String]] +getFileListPieces = flip go id + where + go :: String -> ([String] -> [String]) -> IO [[String]] + go fp front = do + allContents <- filter notHidden `fmap` getDirectoryContents fp + let fullPath :: String -> String + fullPath f = fp ++ '/' : f + files <- filterM (doesFileExist . fullPath) allContents + let files' = map (front . return) files + dirs <- filterM (doesDirectoryExist . fullPath) allContents + dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs + return $ concat $ files' : dirs' + +-- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: +-- +-- > style_css = StaticRoute ["style.css"] [] +-- > js_script_js = StaticRoute ["js/script.js"] [] +staticFiles :: Prelude.FilePath -> Q [Dec] +staticFiles dir = mkStaticFiles dir + +-- | like staticFiles, but doesn't append an etag to the query string +-- This will compile faster, but doesn't achieve as great of caching. +-- The browser can avoid downloading the file, but it always needs to send a request with the etag value or the last-modified value to the server to see if its copy is up to dat +publicFiles :: Prelude.FilePath -> Q [Dec] +publicFiles dir = mkStaticFiles' dir "StaticRoute" False + + +mkHashMap :: Prelude.FilePath -> IO (M.Map FilePath S8.ByteString) +mkHashMap dir = do + fs <- getFileListPieces dir + hashAlist fs >>= return . M.fromList + where + hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)] + hashAlist fs = mapM hashPair fs + where + hashPair :: [String] -> IO (FilePath, S8.ByteString) + hashPair pieces = do let file = pathFromRawPieces dir pieces + h <- base64md5File file + return (toFilePath file, S8.pack h) + +pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath +pathFromRawPieces = + foldl' append + where + append a b = a ++ '/' : b + +cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup +cachedETagLookupDevel dir = do + etags <- mkHashMap dir + mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime) + return $ \f -> + case M.lookup f etags of + Nothing -> return Nothing + Just checksum -> do + fs <- getFileStatus $ fromFilePath f + let newt = modificationTime fs + mtimes <- readIORef mtimeVar + oldt <- case M.lookup f mtimes of + Nothing -> writeIORef mtimeVar (M.insert f newt mtimes) >> return newt + Just oldt -> return oldt + return $ if newt /= oldt then Nothing else Just checksum + + +cachedETagLookup :: Prelude.FilePath -> IO ETagLookup +cachedETagLookup dir = do + etags <- mkHashMap dir + return $ (\f -> return $ M.lookup f etags) + +mkStaticFiles :: Prelude.FilePath -> Q [Dec] +mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True + +mkStaticFiles' :: Prelude.FilePath -- ^ static directory + -> String -- ^ route constructor "StaticRoute" + -> Bool -- ^ append checksum query parameter + -> Q [Dec] +mkStaticFiles' fp routeConName makeHash = do + fs <- qRunIO $ getFileListPieces fp + concat `fmap` mapM mkRoute fs + where + replace' c + | 'A' <= c && c <= 'Z' = c + | 'a' <= c && c <= 'z' = c + | '0' <= c && c <= '9' = c + | otherwise = '_' + mkRoute f = do + let name' = intercalate "_" $ map (map replace') f + routeName = mkName $ + case () of + () + | null name' -> error "null-named file" + | isDigit (head name') -> '_' : name' + | isLower (head name') -> name' + | otherwise -> '_' : name' + f' <- [|map pack $(lift f)|] + let route = mkName routeConName + pack' <- [|pack|] + qs <- if makeHash + then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f + -- FIXME hash <- qRunIO . calcHash $ fp ++ '/' : intercalate "/" f + [|[(pack $(lift hash), mempty)]|] + else return $ ListE [] + return + [ SigD routeName $ ConT route + , FunD routeName + [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) [] + ] + ] + +base64md5File :: Prelude.FilePath -> IO String +base64md5File file = do + contents <- L.readFile file + return $ base64md5 contents + +-- | md5-hashes the given lazy bytestring and returns the hash as +-- base64url-encoded string. +-- +-- This function returns the first 8 characters of the hash. +base64md5 :: L.ByteString -> String +base64md5 = map tr + . take 8 + . S8.unpack + . Data.ByteString.Base64.encode + . Data.Serialize.encode + . md5 + where + tr '+' = '-' + tr '/' = '_' + tr c = c + +{- FIXME +-- | Dispatch static route for a subsite +-- +-- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. +-- Instead of a subsite route: +-- /static StaticR Static getStatic +-- Use a normal route: +-- /static/*Strings StaticR GET +-- +-- Then, define getStaticR something like: +-- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR +-- */ end CPP comment +getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep +getStaticHandler static toSubR pieces = do + toMasterR <- getRouteToMaster + toMasterHandler (toMasterR . toSubR) toSub route handler + where route = StaticRoute pieces [] + toSub _ = static + staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) + handler = fromMaybe notFound $ handleSite staticSite (error "Yesod.Static: getSTaticHandler") route "GET" +-} + + +{- +calcHash :: Prelude.FilePath -> IO String +calcHash fname = + withBinaryFile fname ReadMode hashHandle + where + hashHandle h = do s <- L.hGetContents h + return $! base64md5 s + -} diff --git a/yesod-static.cabal b/yesod-static.cabal --- a/yesod-static.cabal +++ b/yesod-static.cabal @@ -1,21 +1,26 @@ name: yesod-static -version: 0.2.0 +version: 0.3.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman -maintainer: Michael Snoyman +maintainer: Michael Snoyman , Greg Weber synopsis: Static file serving subsite for Yesod Web Framework. category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ +description: Static file serving subsite for Yesod Web Framework. +flag test + description: Build the executable to run unit tests + default: False + library build-depends: base >= 4 && < 5 , containers >= 0.4 , old-time >= 1.0 - , yesod-core >= 0.8 && < 0.9 + , yesod-core >= 0.9 && < 0.10 , base64-bytestring >= 0.1.0.1 && < 0.2 , pureMD5 >= 2.1.0.3 && < 2.2 , cereal >= 0.3 && < 0.4 @@ -23,10 +28,26 @@ , template-haskell , directory >= 1.0 && < 1.2 , transformers >= 0.2 && < 0.3 - , wai-app-static >= 0.2 && < 0.3 + , wai-app-static >= 0.3.2.1 && < 0.4 + , wai >= 0.4 && < 0.5 , text >= 0.5 && < 1.0 - exposed-modules: Yesod.Helpers.Static + , file-embed >= 0.0.4.1 && < 0.5 + , http-types >= 0.6.5 && < 0.7 + , unix-compat >= 0.2 && < 0.3 + exposed-modules: Yesod.Static ghc-options: -Wall + +test-suite runtests + hs-source-dirs: tests + main-is: runtests.hs + type: exitcode-stdio-1.0 + cpp-options: -DTEST + build-depends: yesod-static + , base >= 4 && < 5 + , hspec >= 0.6.1 && < 0.7 + , HUnit + ghc-options: -Wall + main-is: runtests.hs source-repository head type: git