diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs new file mode 100644 --- /dev/null +++ b/Yesod/Helpers/Static.hs @@ -0,0 +1,198 @@ +{-# 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 (..) + -- * Smart constructor + , static + -- * Template Haskell helpers + , staticFiles + {- + -- * Embed files + , getStaticHandler + -} + -- * Hashing + , base64md5 +#if TEST + , testSuite +#endif + ) where + +import System.Directory +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 Network.Wai.Application.Static + ( defaultMimeTypeByExt, StaticSettings (..), staticAppPieces + , defaultListing + ) + +#if TEST +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +#endif + +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 = Static $ StaticSettings fp [] (Just defaultListing) + (return . defaultMimeTypeByExt) + +-- | 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 RenderRoute StaticRoute where + renderRoute (StaticRoute x y) = (x, y) + +instance Yesod master => YesodDispatch Static master where + yesodDispatch (Static set) _ pieces _ _ = + Just $ staticAppPieces set pieces + +{- 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" +-} + +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 --- /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/yesod-static.cabal b/yesod-static.cabal new file mode 100644 --- /dev/null +++ b/yesod-static.cabal @@ -0,0 +1,49 @@ +name: yesod-static +version: 0.0.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 + , wai-app-static >= 0.0.1 && < 0.1 + 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