Add 'yesod-static/' from commit 'afe3f11179698f4e28da0e00d0a6404cac3b1c43'

git-subtree-dir: yesod-static
git-subtree-mainline: 2c5286ac0f
git-subtree-split: afe3f11179

yesod-static/.gitignore

@@ -0,0 +1 @@
+dist/

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.

yesod-static/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

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 <michael@snoyman.com>
+-- 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)

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"]]

yesod-static/yesod-static.cabal

@@ -0,0 +1,51 @@
+name:            yesod-static
+version:         0.3.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+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