diff --git a/yesod-static/.gitignore b/yesod-static/.gitignore new file mode 100644 index 00000000..849ddff3 --- /dev/null +++ b/yesod-static/.gitignore @@ -0,0 +1 @@ +dist/ diff --git a/yesod-static/LICENSE b/yesod-static/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/yesod-static/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod-static/README b/yesod-static/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/Setup.lhs b/yesod-static/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-static/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs new file mode 100644 index 00000000..36d1fa8a --- /dev/null +++ b/yesod-static/Yesod/Static.hs @@ -0,0 +1,292 @@ +{-# 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.Static + ( -- * Subsite + Static (..) + , StaticRoute (..) + -- * Smart constructor + , static + , embed + -- * Template Haskell helpers + , staticFiles + -- * Hashing + , base64md5 + ) where + +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) +import Data.Char (isLower, isDigit) + +import Network.Wai.Application.Static + ( StaticSettings (..) + , defaultWebAppSettings + , fileSystemLookup + , staticApp + , embeddedLookup + , toEmbedded + , pathFromPieces + , toPiece + , fixPathName + ) + +newtype Static = Static 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 :: FilePath -> Static +static fp = + --hashes <- mkHashMap fp + Static $ defaultWebAppSettings { + ssFolder = fileSystemLookup fp + } + +-- | Produces a 'Static' based on embedding file contents in the executable at +-- compile time. +embed :: FilePath -> Q Exp +embed fp = + [|Static (defaultWebAppSettings + { ssFolder = embeddedLookup (toEmbedded $(embedDir fp)) + })|] + +{- +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) + +type instance Route Static = StaticRoute + +instance RenderRoute StaticRoute where + renderRoute (StaticRoute x y) = (x, y) + +instance Yesod master => YesodDispatch Static master where + yesodDispatch (Static set) _ textPieces _ _ = Just $ + \req -> staticApp set req { pathInfo = textPieces } + +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 + +{- +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 = pathFromRawPieces dir pieces + h <- base64md5File file + return (file, S8.pack h) + +{- +mkPublicDevelEtag :: FilePath -> IO StaticSettings +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 StaticSettings +mkPublicProductionEtag dir = do + etags <- mkHashMap dir + return $ ETag $ \f -> return . M.lookup f $ etags +-} + +data StaticSite = StaticSite | PublicSite +mkStaticFiles :: FilePath -> Q [Dec] +mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True + +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' = intercalate "_" $ map (map replace') f + name = 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 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 (error "Yesod.Static: getSTaticHandler") route "GET" +-} + + +{- +calcHash :: FilePath -> IO String +calcHash fname = + withBinaryFile fname ReadMode hashHandle + where + hashHandle h = do s <- L.hGetContents h + return $! base64md5 s + -} + +-- FIXME Greg: Is this correct? Where is this function supposed to be? +pathFromRawPieces :: FilePath -> [String] -> FilePath +pathFromRawPieces fp = pathFromPieces fp . map (toPiece . pack . fixPathName) diff --git a/yesod-static/tests/data/.ignored b/yesod-static/tests/data/.ignored new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/data/bar/baz b/yesod-static/tests/data/bar/baz new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/data/foo b/yesod-static/tests/data/foo new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/data/tmp/ignored b/yesod-static/tests/data/tmp/ignored new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static/tests/runtests.hs b/yesod-static/tests/runtests.hs new file mode 100644 index 00000000..3186a8e2 --- /dev/null +++ b/yesod-static/tests/runtests.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +import Yesod.Helpers.Static + +import Test.Hspec +import Test.Hspec.HUnit () +-- import Test.Hspec.QuickCheck (prop) +import Test.HUnit ((@?=)) + +main :: IO () +main = hspecX specs + +specs :: IO [Spec] +specs = runSpecM $ do + context "get file list" $ do + ti "pieces" $ do + x <- getFileListPieces "tests/data" + x @?= [["foo"], ["bar", "baz"]] diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal new file mode 100644 index 00000000..3fb2fb43 --- /dev/null +++ b/yesod-static/yesod-static.cabal @@ -0,0 +1,51 @@ +name: yesod-static +version: 0.3.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +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/ + +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.9 && < 0.10 + , base64-bytestring >= 0.1.0.1 && < 0.2 + , pureMD5 >= 2.1.0.3 && < 2.2 + , cereal >= 0.3 && < 0.4 + , bytestring >= 0.9 && < 0.10 + , template-haskell + , directory >= 1.0 && < 1.2 + , transformers >= 0.2 && < 0.3 + , wai-app-static >= 0.3 && < 0.4 + , wai >= 0.4 && < 0.5 + , text >= 0.5 && < 1.0 + , file-embed >= 0.0.4.1 && < 0.5 + 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, + HUnit + ghc-options: -Wall + main-is: runtests.hs + +source-repository head + type: git + location: git://github.com/snoyberg/yesod-static.git