From bc0bfac57b249baa2fd44c9e965d1c106905d4f4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 25 Dec 2010 21:27:03 +0200 Subject: [PATCH] Initial code import --- LICENSE | 25 ++++ Yesod/Helpers/Static.hs | 257 ++++++++++++++++++++++++++++++++++++++++ runtests.hs | 6 + test/.ignored | 0 test/bar/baz | 0 test/foo | 0 test/tmp/ignored | 0 yesod-static.cabal | 48 ++++++++ 8 files changed, 336 insertions(+) create mode 100644 LICENSE create mode 100644 Yesod/Helpers/Static.hs create mode 100644 runtests.hs create mode 100644 test/.ignored create mode 100644 test/bar/baz create mode 100644 test/foo create mode 100644 test/tmp/ignored create mode 100644 yesod-static.cabal diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/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/Helpers/Static.hs b/Yesod/Helpers/Static.hs new file mode 100644 index 00000000..dccb2a39 --- /dev/null +++ b/Yesod/Helpers/Static.hs @@ -0,0 +1,257 @@ +{-# 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 (..) + , StaticRoute (..) + -- * Lookup files in filesystem + , fileLookupDir + , staticFiles + -- * Embed files + , mkEmbedFiles + , getStaticHandler + -- * Hashing + , base64md5 +#if TEST + , testSuite +#endif + ) where + +import System.Directory +import Control.Monad +import Data.Maybe (fromMaybe) + +import Yesod.Handler +import Yesod.Content +import Yesod.Core + +import Control.Monad.IO.Class (liftIO) + +import Data.List (intercalate) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Web.Routes + +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 + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif + +-- | 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)] + } + +-- | 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 [String] [(String, String)] + deriving (Eq, Show, Read) + +type instance Route Static = StaticRoute + +instance YesodSubSite Static master where + getSubSite = Site + { handleSite = \_ (StaticRoute ps _) m -> + case m of + "GET" -> Just $ fmap chooseRep $ getStaticRoute ps + _ -> 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. +-- 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" + +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 +notHidden _ = True + +getFileList :: FilePath -> IO [[String]] +getFileList = 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 fp = do + fs <- qRunIO $ getFileList fp + concat `fmap` mapM go fs + where + replace' c + | 'A' <= c && c <= 'Z' = c + | 'a' <= c && c <= 'z' = c + | '0' <= c && c <= '9' = c + | otherwise = '_' + go f = do + let name = mkName $ intercalate "_" $ map (map replace') f + f' <- lift f + let sr = ConE $ mkName "StaticRoute" + hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f + let qs = ListE [TupE [LitE $ StringL hash, ListE []]] + return + [ SigD name $ ConT ''Route `AppT` ConT ''Static + , FunD name + [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] + ] + ] + +#if TEST + +testSuite :: Test +testSuite = testGroup "Yesod.Helpers.Static" + [ testCase "get file list" caseGetFileList + ] + +caseGetFileList :: Assertion +caseGetFileList = do + x <- getFileList "test" + x @?= [["foo"], ["bar", "baz"]] + +#endif + +-- | 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 go + . take 8 + . S8.unpack + . Data.ByteString.Base64.encode + . Data.Serialize.encode + . md5 + where + go '+' = '-' + go '/' = '_' + go c = c diff --git a/runtests.hs b/runtests.hs new file mode 100644 index 00000000..ccd8b724 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,6 @@ +import Test.Framework (defaultMain) + +import Yesod.Helpers.Static + +main :: IO () +main = defaultMain [testSuite] diff --git a/test/.ignored b/test/.ignored new file mode 100644 index 00000000..e69de29b diff --git a/test/bar/baz b/test/bar/baz new file mode 100644 index 00000000..e69de29b diff --git a/test/foo b/test/foo new file mode 100644 index 00000000..e69de29b diff --git a/test/tmp/ignored b/test/tmp/ignored new file mode 100644 index 00000000..e69de29b diff --git a/yesod-static.cabal b/yesod-static.cabal new file mode 100644 index 00000000..05438c12 --- /dev/null +++ b/yesod-static.cabal @@ -0,0 +1,48 @@ +name: yesod-static +version: 0.7.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.6 +build-type: Simple +homepage: http://docs.yesodweb.com/ + +flag test + description: Build the executable to run unit tests + default: False + +library + build-depends: base >= 4 && < 5 + , yesod-core >= 0.7 && < 0.8 + , 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 + , web-routes >= 0.23 && < 0.24 + , template-haskell + , directory >= 1.0 && < 1.2 + , transformers >= 0.2 && < 0.3 + exposed-modules: Yesod.Helpers.Static + ghc-options: -Wall + +executable runtests + if flag(test) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2 && < 3 + else + Buildable: False + ghc-options: -Wall + main-is: runtests.hs + +source-repository head + type: git + location: git://github.com/snoyberg/yesod-static.git