haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into wai-2.0

Browse Source 
Conflicts:
	yesod-static/yesod-static.cabal
This commit is contained in:
Michael Snoyman 2013-11-10 13:46:58 +02:00
commit 6f495fc758
35 changed files with 1361 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.travis.yml
View File

@ -2,12 +2,9 @@ language: haskell
install:
- cabal update
- cabal install mega-sdist hspec cabal-meta cabal-src
- git clone https://github.com/snoyberg/tagstream-conduit.git
- cd tagstream-conduit
- cabal-src-install --src-only
- cd ..
- cabal-meta install --force-reinstalls --enable-tests
- cabal install --force-reinstalls mega-sdist hspec cabal-meta cabal-src
- cabal-meta install --force-reinstalls
script:
- echo Done
- mega-sdist --test

38
README.md
View File

@ -9,7 +9,6 @@ An advanced web framework using the Haskell programming language. Featuring:
* techniques for constant-space memory consumption
* asynchronous IO
* this is built in to the Haskell programming language (like Erlang)
* handles a greater concurrent load than any other web application server
# Learn more: http://yesodweb.com/
@ -27,18 +26,19 @@ Your application is a cabal package and you use `cabal` to install its dependenc
Install conflicts are unfortunately common in Haskell development.
If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken.
You can prevent this by using sandbox tools: `cabal-dev` or `hsenv`.
You can prevent this by using cabal sandbox.
Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process.
[Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
Isolating an entire project is also a great idea, you just need some tools to help that process.
On Linux you can use Docker.
On any OS you can use a virtual machine. [Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
## Using cabal-dev
## Using cabal sandbox
cabal-dev creates a sandboxed environment for an individual cabal package.
Instead of using the `cabal` command, use the `cabal-dev` command which will use the sandbox.
To sandbox a project, type:
Use `yesod devel --dev` when developing your application.
cabal sandbox init
This ensures that future installs will be local to the sandboxed directory.
## Installing the latest development version from github for use with your application
@ -55,7 +55,7 @@ In your application folder, create a `sources.txt` file with the following conte
https://github.com/yesodweb/wai
`./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo.
Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev install`
Now run: `cabal-meta install`.
This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta)
If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first.
@ -64,23 +64,9 @@ If you aren't building from an application, remove the `./` and create a new dir
## hsenv (Linux and Mac OS X)
[hsenv](https://github.com/tmhedberg/hsenv) prevents your custom build of Yesod from interfering with your currently installed cabal packages:
[hsenv](https://github.com/tmhedberg/hsenv) also provides a sandbox, but works at the shell level.
Generally we recommend using cabal sandbox, but hsenv has tools for allowing you to use different versions of GHC, which may be useful for you.
* hsenv creates an isolated environment like cabal-dev
* hsenv works at the shell level, so every shell must activate the hsenv
* cabal-dev by default isolates a single cabal package, but hsenv isolates multiple packages together.
* cabal-dev can isolate multiple packages together by using the -s sandbox argument
## cabal-src
The cabal-src tool helps resolve dependency conflicts when installing local packages.
This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with:
cabal install cabal-src
Whenever you would use `cabal install` to install a local package, use `cabal-src-install` instead.
Our installer script now uses cabal-src-install when it is available.
## Cloning the repos
@ -100,7 +86,7 @@ done
## Building your changes to Yesod
Yesod is composed of 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
The traditional Yesod stack requires 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
### install package in all repos

13
yesod-auth/Yesod/Auth/Email.hs
View File

@ -172,6 +172,17 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
setTitleI Msg.ConfirmationEmailSentTitle
[whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
-- | Additional normalization of email addresses, besides standard canonicalization.
--
-- Default: do nothing. Note that in future versions of Yesod, the default
-- will change to lower casing the email address. At that point, you will
-- need to either ensure your database values are migrated to lower case,
-- or change this default back to doing nothing.
--
-- Since 1.2.3
normalizeEmailAddress :: site -> Text -> Text
normalizeEmailAddress _ = TS.toLower
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch $ \tm ->
@ -234,7 +245,7 @@ registerHelper allowUsername dest = do
loginErrorMessageI dest Msg.NoIdentifierProvided
Just x
| Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
return $ decodeUtf8With lenientDecode x'
return $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
| allowUsername -> return $ TS.strip x
| otherwise -> do
loginErrorMessageI dest Msg.InvalidEmailAddress

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.2.2.1
version: 1.2.3
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin

4
yesod-bin/GhcBuild.hs
View File

@ -39,7 +39,7 @@ import GHC.Paths (libdir)
import HscTypes (HscEnv (..), emptyHomePackageTable)
import qualified Module
import MonadUtils (liftIO)
import Panic (ghcError, panic)
import Panic (throwGhcException, panic)
import SrcLoc (Located, mkGeneralLocated)
import qualified StaticFlags
import StaticFlags (v_Ld_inputs)
@ -234,7 +234,7 @@ parseModeFlags args = do
Nothing -> doMakeMode
Just (m, _) -> m
errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
when (not (null errs)) $ ghcError $ errorsToGhcException errs
when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
return (mode, flags' ++ leftover, warns)
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])

12
yesod-bin/Options.hs
View File

@ -71,7 +71,7 @@ injectDefaultP env path p@(OptP o)
in parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
in OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
| (Option (OptReader names (CReader _ rdr) _) _) <- o =
p <|> either (const empty) pure (msum $ map (rdr <=< (maybe (Left $ ErrorMsg "Missing environment variable") Right . getEnvValue env path)) names)
p <|> either' (const empty) pure (msum $ map (rdr <=< (maybe (left $ ErrorMsg "Missing environment variable") right . getEnvValue env path)) names)
| (Option (FlagReader names a) _) <- o =
p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
| otherwise = p
@ -81,6 +81,16 @@ injectDefaultP env path (AltP p1 p2) =
AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
injectDefaultP _env _path b@(BindP {}) = b
#if MIN_VERSION_optparse_applicative(0,6,0)
right = ReadM . Right
left = ReadM . Left
either' f g (ReadM x) = either f g x
#else
right = Right
left = Left
either' = either
#endif
getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
getEnvValue _ _ _ = Nothing

7
yesod-bin/Scaffolding/Scaffolder.hs
View File

@ -67,8 +67,9 @@ validPN c
validPN '-' = True
validPN _ = False
scaffold :: IO ()
scaffold = do
scaffold :: Bool -- ^ bare directory instead of a new subdirectory?
-> IO ()
scaffold isBare = do
puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
project <- prompt $ \s ->
if all validPN s && not (null s) && s /= "test"
@ -90,7 +91,7 @@ scaffold = do
putStrLn "That's it! I'm creating your files now..."
let sink = unpackTemplate
(receiveFS $ fromString project)
(receiveFS $ if isBare then "." else fromString project)
(T.replace "PROJECTNAME" (T.pack project))
case ebackend of
Left req -> withManager $ \m -> do

7
yesod-bin/input/done.cg
View File

@ -24,9 +24,4 @@ Take part in the community: http://yesodweb.com/page/community
Start your project:
cd PROJECTNAME && cabal install && yesod devel
or if you use cabal-dev:
cd PROJECTNAME && cabal-dev install && yesod --dev devel
cd PROJECTNAME && cabal sandbox init && cabal install && yesod devel

14
yesod-bin/main.hs
View File

@ -16,6 +16,9 @@ import qualified Paths_yesod_bin
import Scaffolding.Scaffolder
import Options.Applicative.Builder.Internal (Mod, OptionFields)
#if MIN_VERSION_optparse_applicative(0,6,0)
import Options.Applicative.Types (ReadM (ReadM))
#endif
#ifndef WINDOWS
import Build (touch)
@ -42,7 +45,7 @@ data Options = Options
}
deriving (Show, Eq)
data Command = Init
data Command = Init { _initBare :: Bool }
| Configure
| Build { buildExtraArgs :: [String] }
| Touch
@ -89,7 +92,7 @@ main = do
] optParser'
let cabal xs = rawSystem' (cabalCommand o) xs
case optCommand o of
Init -> scaffold
Init bare -> scaffold bare
Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es)
Touch -> touch'
@ -109,7 +112,8 @@ optParser :: Parser Options
optParser = Options
<$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" )
<*> switch ( long "verbose" <> short 'v' <> help "More verbose output" )
<*> subparser ( command "init" (info (pure Init)
<*> subparser ( command "init"
(info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
(progDesc "Scaffold a new site"))
<> command "configure" (info (pure Configure)
(progDesc "Configure a project for building"))
@ -164,7 +168,11 @@ optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m =
nullOption $ value Nothing <> reader (success . str) <> m
where
#if MIN_VERSION_optparse_applicative(0,6,0)
success = ReadM . Right
#else
success = Right
#endif
-- | Like @rawSystem@, but exits if it receives a non-success result.
rawSystem' :: String -> [String] -> IO ()

2
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.2.3.2
version: 1.2.4
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

4
yesod-core/Yesod/Core/Json.hs
View File

@ -84,6 +84,10 @@ provideJson = provideRep . return . J.toJSON
-- If you want the raw JSON value, just ask for a @'J.Result'
-- 'J.Value'@.
--
-- Note that this function will consume the request body. As such, calling it
-- twice will result in a parse error on the second call, since the request
-- body will no longer be available.
--
-- /Since: 0.3.0/
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do

1
yesod-core/Yesod/Core/Widget.hs
View File

@ -47,6 +47,7 @@ module Yesod.Core.Widget
, handlerToWidget
-- * Internal
, whamletFileWithSettings
, asWidgetT
) where
import Data.Monoid

8
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.4.2
version: 1.2.5
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -41,7 +41,7 @@ library
, transformers >= 0.2.2 && < 0.4
, clientsession >= 0.9 && < 0.10
, random >= 1.0.0.2 && < 1.1
, cereal >= 0.3 && < 0.4
, cereal >= 0.3
, old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.2 && < 0.3
, containers >= 0.2
@ -91,6 +91,9 @@ library
-- This looks like a GHC bug
extensions: MultiParamTypeClasses
-- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
extensions: TemplateHaskell
test-suite tests
type: exitcode-stdio-1.0
main-is: test.hs
@ -118,6 +121,7 @@ test-suite tests
, lifted-base
, resourcet
ghc-options: -Wall
extensions: TemplateHaskell
source-repository head
type: git

34
yesod-form/Yesod/Form/Fields.hs
View File

@ -36,6 +36,8 @@ module Yesod.Form.Fields
, selectFieldList
, radioField
, radioFieldList
, checkboxesFieldList
, checkboxesField
, multiSelectField
, multiSelectFieldList
, Option (..)
@ -62,8 +64,8 @@ import qualified Text.Email.Validate as Email
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Network.URI (parseURI)
import Database.Persist.Sql (PersistField, PersistFieldSql)
import Database.Persist (Entity (..))
import Database.Persist.Sql (PersistField, PersistFieldSql (..))
import Database.Persist (Entity (..), SqlType (SqlString))
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Control.Monad (when, unless)
import Data.Maybe (listToMaybe, fromMaybe)
@ -166,7 +168,9 @@ $newline never
-- | A newtype wrapper around a 'Text' that converts newlines to HTML
-- br-tags.
newtype Textarea = Textarea { unTextarea :: Text }
deriving (Show, Read, Eq, PersistField, PersistFieldSql, Ord)
deriving (Show, Read, Eq, PersistField, Ord)
instance PersistFieldSql Textarea where
sqlType _ = SqlString
instance ToHtml Textarea where
toHtml =
unsafeByteString
@ -388,6 +392,28 @@ radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
-> Field (HandlerT site IO) a
radioFieldList = radioField . optionsPairs
checkboxesFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerT site IO) [a]
checkboxesFieldList = checkboxesField . optionsPairs
checkboxesField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) [a]
checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView =
\theId name attrs val isReq -> do
opts <- fmap olOptions $ handlerToWidget ioptlist
let optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
[whamlet|
<span ##{theId}>
$forall opt <- opts
<label>
<input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>
#{optionDisplay opt}
|]
}
radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
@ -437,6 +463,8 @@ $newline never
"yes" -> Right $ Just True
"on" -> Right $ Just True
"no" -> Right $ Just False
"true" -> Right $ Just True
"false" -> Right $ Just False
t -> Left $ SomeMessage $ MsgInvalidBool t
showVal = either (\_ -> False)

2
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.3.2.1
version: 1.3.4
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>

2
yesod-platform/to-cabal.hs
View File

@ -3,7 +3,7 @@ import Control.Applicative ((<$>))
main = do
pkgs <- map (intercalate " == ")
. filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable"])
. filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable", "vault"])
. map words
. filter (not . null)
. lines

7
yesod-platform/yesod-platform.cabal
View File

@ -1,5 +1,5 @@
name: yesod-platform
version: 1.2.4.1
version: 1.2.4.4
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -58,7 +58,7 @@ library
, date-cache == 0.3.0
, dlist == 0.5
, email-validate == 1.0.0
, entropy == 0.2.2.2
, entropy == 0.2.2.4
, failure == 0.2.0.1
, fast-logger == 0.3.3
, file-embed == 0.0.4.9
@ -104,7 +104,7 @@ library
, silently == 1.2.4.1
, simple-sendfile == 0.2.12
, skein == 1.0.6
, socks == 0.5.1
, socks == 0.5.3
, stringsearch == 0.3.6.4
, system-fileio == 0.3.11
, system-filepath == 0.4.7
@ -118,7 +118,6 @@ library
, unordered-containers == 0.2.3.2
, utf8-light == 0.4.0.1
, utf8-string == 0.3.7
, vault == 0.3.0.0
, vector == 0.10.0.1
, void == 0.6.1
, wai == 1.4.0.2

183
yesod-static/Yesod/EmbeddedStatic.hs Normal file
View File

@ -0,0 +1,183 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | A subsite which serves static content which is embedded at compile time.
--
-- At compile time, you supply a list of files, directories, processing functions (like javascript
-- minification), and even custom content generators. You can also specify the specific relative
-- locations within the static subsite where these resources should appear. The 'mkEmbeddedStatic'
-- function then computes the resources and embeds them directly into the executable at
-- compile time, so that the original files do not need to be distributed along with
-- the executable. The content is also compressed and hashed at compile time, so that
-- during runtime the compressed content can be sent directly on the wire with the appropriate
-- HTTP header. The precomputed hash is used for an ETag so the client does not redownload
-- the content multiple times. There is also a development mode which does not embed the
-- contents but recomputes it on every request. A simple example using an embedded static
-- subsite is
-- <https://github.com/yesodweb/yesod/blob/master/yesod-static/sample-embed.hs static-embed.hs>.
--
-- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@
-- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type
-- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to
-- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in
-- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by
-- @Settings/StaticFiles.hs@ to link to your static content, and finally update
-- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which
-- contains the created 'EmbeddedStatic'.
--
-- It is recommended that you serve static resources from a separate domain to save time
-- on transmitting cookies. You can use 'urlRenderOverride' to do so, by redirecting
-- routes to this subsite to a different domain (but the same path) and then pointing the
-- alternative domain to this server. In addition, you might consider using a reverse
-- proxy like varnish or squid to cache the static content, but the embedded content in
-- this subsite is cached and served directly from memory so is already quite fast.
module Yesod.EmbeddedStatic (
-- * Subsite
EmbeddedStatic
, embeddedResourceR
, mkEmbeddedStatic
, embedStaticContent
-- * Generators
, module Yesod.EmbeddedStatic.Generators
) where
import Control.Applicative ((<$>))
import Data.IORef
import Data.Maybe (catMaybes)
import Language.Haskell.TH
import Network.HTTP.Types.Status (status404)
import Network.Wai (responseLBS, pathInfo)
import Network.Wai.Application.Static (staticApp)
import System.IO.Unsafe (unsafePerformIO)
import Yesod.Core
( HandlerT
, Yesod(..)
, YesodSubDispatch(..)
)
import Yesod.Core.Types
( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..)
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic.Internal
import Yesod.EmbeddedStatic.Generators
-- Haddock doesn't support associated types in instances yet so we can't
-- export EmbeddedResourceR directly.
-- | Construct a route to an embedded resource.
embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
embeddedResourceR = EmbeddedResourceR
instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) where
yesodSubDispatch YesodSubRunnerEnv {..} req = resp
where
master = yreSite ysreParentEnv
site = ysreGetSub master
resp = case pathInfo req of
("res":_) -> stApp site req
("widget":_) -> staticApp (widgetSettings site) req
_ -> return $ responseLBS status404 [] "Not Found"
-- | Create the haskell variable for the link to the entry
mkRoute :: ComputedEntry -> Q [Dec]
mkRoute (ComputedEntry { cHaskellName = Nothing }) = return []
mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do
routeType <- [t| Route EmbeddedStatic |]
link <- [| $(cLink c) |]
return [ SigD name routeType
, ValD (VarP name) (NormalB link) []
]
-- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators.
-- Each generator produces a list of entries to embed into the executable.
--
-- This template haskell splice creates a variable binding holding the resulting
-- 'EmbeddedStatic' and in addition creates variable bindings for all the routes
-- produced by the generators. For example, if a directory called static has
-- the following contents:
--
-- * js/jquery.js
--
-- * css/bootstrap.css
--
-- * img/logo.png
--
-- then a call to
--
-- > #ifdef DEVELOPMENT
-- > #define DEV_BOOL True
-- > #else
-- > #define DEV_BOOL False
-- > #endif
-- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"]
--
-- will produce variables
--
-- > myStatic :: EmbeddedStatic
-- > js_jquery_js :: Route EmbeddedStatic
-- > css_bootstrap_css :: Route EmbeddedStatic
-- > img_logo_png :: Route EmbeddedStatic
mkEmbeddedStatic :: Bool -- ^ development?
-> String -- ^ variable name for the created 'EmbeddedStatic'
-> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators")
-> Q [Dec]
mkEmbeddedStatic dev esName gen = do
entries <- concat <$> sequence gen
computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries
let settings = Static.mkSettings $ return $ map cStEntry computed
devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries
ioRef = [| unsafePerformIO $ newIORef M.empty |]
-- build the embedded static
esType <- [t| EmbeddedStatic |]
esCreate <- if dev
then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |]
else [| EmbeddedStatic (staticApp $! $settings) $ioRef |]
let es = [ SigD (mkName esName) esType
, ValD (VarP $ mkName esName) (NormalB esCreate) []
]
routes <- mapM mkRoute computed
return $ es ++ concat routes
-- | Use this for 'addStaticContent' to have the widget static content be served by
-- the embedded static subsite. For example,
--
-- > import Yesod
-- > import Yesod.EmbeddedStatic
-- > import Text.Jasmine (minifym)
-- >
-- > data MySite = { ..., getStatic :: EmbeddedStatic, ... }
-- >
-- > mkYesod "MySite" [parseRoutes|
-- > ...
-- > /static StaticR EmbeddedStatic getStatic
-- > ...
-- > |]
-- >
-- > instance Yesod MySite where
-- > ...
-- > addStaticContent = embedStaticContent getStatic StaticR mini
-- > where mini = if development then Right else minifym
-- > ...
embedStaticContent :: Yesod site
=> (site -> EmbeddedStatic) -- ^ How to retrieve the embedded static subsite from your site
-> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route
-> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier
-> AddStaticContent site
embedStaticContent = staticContentHelper

317
yesod-static/Yesod/EmbeddedStatic/Generators.hs Normal file
View File

@ -0,0 +1,317 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-}
-- | A generator is executed at compile time to load a list of entries
-- to embed into the subsite. This module contains several basic generators,
-- but the design of generators and entries is such that it is straightforward
-- to make custom generators for your own specific purposes, see <#g:4 this section>.
module Yesod.EmbeddedStatic.Generators (
-- * Generators
Location
, embedFile
, embedFileAt
, embedDir
, embedDirAt
, concatFiles
, concatFilesWith
-- * Compression options for 'concatFilesWith'
, jasmine
, uglifyJs
, yuiJavascript
, yuiCSS
, closureJs
, compressTool
, tryCompressTools
-- * Util
, pathToName
-- * Custom Generators
-- $example
) where
import Control.Applicative ((<$>))
import Control.Exception (try, SomeException)
import Control.Monad (forM, when)
import Control.Monad.Trans.Resource (runResourceT)
import Data.Char (isDigit, isLower)
import Data.Conduit (($$), (=$))
import Data.Conduit.Process (proc, conduitProcess)
import Data.Default (def)
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Network.Mime (defaultMimeLookup)
import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable)
import System.FilePath ((</>))
import Text.Jasmine (minifym)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C
import qualified Data.Text as T
import Yesod.EmbeddedStatic.Types
-- | Embed a single file. Equivalent to passing the same string twice to 'embedFileAt'.
embedFile :: FilePath -> Generator
embedFile f = embedFileAt f f
-- | Embed a single file at a given location within the static subsite and generate a
-- route variable based on the location via 'pathToName'. The @FilePath@ must be a relative
-- path to the directory in which you run @cabal build@. During development, the file located
-- at this filepath will be reloaded on every request. When compiling for production, the contents
-- of the file will be embedded into the executable and so the file does not need to be
-- distributed along with the executable.
embedFileAt :: Location -> FilePath -> Generator
embedFileAt loc f = do
let mime = defaultMimeLookup $ T.pack f
let entry = def {
ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = BL.readFile f
, ebDevelReload = [| BL.readFile $(litE $ stringL f) |]
}
return [entry]
-- | List all files recursively in a directory
getRecursiveContents :: Location -- ^ The directory to search
-> FilePath -- ^ The prefix to add to the filenames
-> IO [(Location,FilePath)]
getRecursiveContents prefix topdir = do
names <- getDirectoryContents topdir
let properNames = filter (`notElem` [".", ".."]) names
paths <- forM properNames $ \name -> do
let path = topdir </> name
let loc = if null prefix then name else prefix ++ "/" ++ name
isDirectory <- doesDirectoryExist path
if isDirectory
then getRecursiveContents loc path
else return [(loc, path)]
return (concat paths)
-- | Embed all files in a directory into the static subsite.
--
-- Equivalent to passing the empty string as the location to 'embedDirAt',
-- so the directory path itself is not part of the resource locations (and so
-- also not part of the generated route variable names).
embedDir :: FilePath -> Generator
embedDir = embedDirAt ""
-- | Embed all files in a directory to a given location within the static subsite.
--
-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in
-- which you run @cabal build@) is embedded into the static subsite at the given
-- location. Also, route variables will be created based on the final location
-- of each file. For example, if a directory \"static\" contains the files
--
-- * css/bootstrap.css
--
-- * js/jquery.js
--
-- * js/bootstrap.js
--
-- then @embedDirAt \"somefolder\" \"static\"@ will
--
-- * Make the file @static\/css\/bootstrap.css@ available at the location
-- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly
-- for the other two files.
--
-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@,
-- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@.
--
-- * During development, the files will be reloaded on every request. During
-- production, the contents of all files will be embedded into the executable.
--
-- * During development, files that are added to the directory while the server
-- is running will not be detected. You need to recompile the module which
-- contains the call to @mkEmbeddedStatic@. This will also generate new route
-- variables for the new files.
embedDirAt :: Location -> FilePath -> Generator
embedDirAt loc dir = do
files <- runIO $ getRecursiveContents loc dir
concat <$> mapM (uncurry embedFileAt) files
-- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to
-- 'concatFilesWith'.
concatFiles :: Location -> [FilePath] -> Generator
concatFiles loc files = concatFilesWith loc return files
-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given
-- function, embed it at the given location, and create a haskell variable name for the route based on
-- the location.
--
-- The processing function is only run when compiling for production, and the processing function is
-- executed at compile time. During development, on every request the files listed are reloaded,
-- concatenated, and served as a single resource at the given location without being processed.
concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator
concatFilesWith loc process files = do
let load = do putStrLn $ "Creating " ++ loc
BL.concat <$> mapM BL.readFile files >>= process
expFiles = listE $ map (litE . stringL) files
expCt = [| BL.concat <$> mapM BL.readFile $expFiles |]
mime = defaultMimeLookup $ T.pack loc
return [def { ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = load
, ebDevelReload = expCt
}]
-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'.
jasmine :: BL.ByteString -> IO BL.ByteString
jasmine ct = return $ either (const ct) id $ minifym ct
-- | Use <https://github.com/mishoo/UglifyJS2 UglifyJS2> to compress javascript.
-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@
-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from
-- standard input.
uglifyJs :: BL.ByteString -> IO BL.ByteString
uglifyJs = compressTool "uglifyjs" ["-m", "-c", "-"]
-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress javascript.
-- Assumes a script @yuicompressor@ is located in the path. If not, you can still
-- use something like
--
-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"]
yuiJavascript :: BL.ByteString -> IO BL.ByteString
yuiJavascript = compressTool "yuicompressor" ["--type", "js"]
-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress CSS.
-- Assumes a script @yuicompressor@ is located in the path.
yuiCSS :: BL.ByteString -> IO BL.ByteString
yuiCSS = compressTool "yuicompressor" ["--type", "css"]
-- | Use <https://developers.google.com/closure/compiler/ Closure> to compress
-- javascript using the default options. Assumes a script @closure@ is located in
-- the path. If not, you can still run using
--
-- > compressTool "java" ["-jar", "/path/to/compiler.jar"]
closureJs :: BL.ByteString -> IO BL.ByteString
closureJs = compressTool "closure" []
-- | Helper to convert a process into a compression function. The process
-- should be set up to take input from standard input and write to standard output.
compressTool :: FilePath -- ^ program
-> [String] -- ^ options
-> BL.ByteString -> IO BL.ByteString
compressTool f opts ct = do
mpath <- findExecutable f
when (isNothing mpath) $
fail $ "Unable to find " ++ f
let src = C.sourceList $ BL.toChunks ct
p = proc f opts
sink = C.consume
compressed <- runResourceT (src $$ conduitProcess p =$ sink)
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
-- | Try a list of processing functions (like the compressions above) one by one until
-- one succeeds (does not raise an exception). Once a processing function succeeds,
-- none of the remaining functions are used. If none succeeds, the input is just
-- returned unprocessed. This is helpful if you are distributing
-- code on hackage and do not know what compressors the user will have installed. You
-- can list several and they will be tried in order until one succeeds.
tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
tryCompressTools [] x = return x
tryCompressTools (p:ps) x = do
mres <- try $ p x
case mres of
Left (err :: SomeException) -> do
putStrLn $ show err
tryCompressTools ps x
Right res -> return res
-- | Clean up a path to make it a valid haskell name by replacing all non-letters
-- and non-numbers by underscores. In addition, if the path starts with a capital
-- letter or number add an initial underscore.
pathToName :: FilePath -> Name
pathToName f = routeName
where
replace c
| 'A' <= c && c <= 'Z' = c
| 'a' <= c && c <= 'z' = c
| '0' <= c && c <= '9' = c
| otherwise = '_'
name = map replace f
routeName = mkName $
case () of
()
| null name -> error "null-named file"
| isDigit (head name) -> '_' : name
| isLower (head name) -> name
| otherwise -> '_' : name
-- $example
-- Here is an example of creating your own custom generator.
-- Because of template haskell stage restrictions, you must define generators in a
-- different module from where you use them. The following generator will embed a
-- JSON document that contains the compile time.
--
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
-- >module CompileTime where
-- >
-- >import Data.Aeson
-- >import Data.Default
-- >import Data.Time
-- >import Yesod.EmbeddedStatic.Generators
-- >import Yesod.EmbeddedStatic.Types
-- >import qualified Data.ByteString.Lazy as BL
-- >
-- >getTime :: IO BL.ByteString
-- >getTime = do
-- > t <- getCurrentTime
-- > return $ encode $
-- > object [ "compile_time" .= show t ]
-- >
-- >timeGenerator :: Location -> Generator
-- >timeGenerator loc =
-- > return $ [def
-- > { ebHaskellName = Just $ pathToName loc
-- > , ebLocation = loc
-- > , ebMimeType = "application/json"
-- > , ebProductionContent = getTime
-- > , ebDevelReload = [| getTime |]
-- > }]
--
-- Notice how the @getTime@ action is given as both 'ebProductionContent' and
-- 'ebDevelReload'. The result is that during development, the @getTime@ action
-- will be re-executed on every request so the time returned will be different
-- for each reload. When compiling for production, the @getTime@ action will
-- be executed once at compile time to produce the content to embed and never
-- called at runtime.
--
-- Here is a small example yesod program using this generator. Try toggling
-- the development argument to @mkEmbeddedStatic@.
--
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-- >module Main where
-- >
-- >import Yesod
-- >import Yesod.EmbeddedStatic
-- >import CompileTime (timeGenerator)
-- >
-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"]
-- >
-- >-- The above will generate variables
-- >-- eStatic :: EmbeddedStatic
-- >-- compile_time_json :: Route EmbeddedStatic
-- >
-- >data MyApp = MyApp { getStatic :: EmbeddedStatic }
-- >
-- >mkYesod "MyApp" [parseRoutes|
-- >/ HomeR GET
-- >/static StaticR EmbeddedStatic getStatic
-- >|]
-- >
-- >instance Yesod MyApp
-- >
-- >getHomeR :: Handler Html
-- >getHomeR = defaultLayout $ [whamlet|
-- ><h1>Hello
-- ><p>Check the
-- > <a href=@{StaticR compile_time_json}>compile time
-- >|]
-- >
-- >main :: IO ()
-- >main = warp 3000 $ MyApp eStatic

169
yesod-static/Yesod/EmbeddedStatic/Internal.hs Normal file
View File

@ -0,0 +1,169 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Yesod.EmbeddedStatic.Internal (
EmbeddedStatic(..)
, Route(..)
, ComputedEntry(..)
, devEmbed
, prodEmbed
, develApp
, AddStaticContent
, staticContentHelper
, widgetSettings
) where
import Control.Applicative ((<$>))
import Data.IORef
import Language.Haskell.TH
import Network.HTTP.Types (Status(..), status404, status200, status304)
import Network.Mime (MimeType)
import Network.Wai
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types
import Yesod.Core
( HandlerT
, ParseRoute(..)
, RenderRoute(..)
, Yesod(..)
, getYesod
, liftIO
)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.HashMap.Strict as M
import qualified WaiAppStatic.Storage.Embedded as Static
import Yesod.Static (base64md5)
import Yesod.EmbeddedStatic.Types
#if !MIN_VERSION_base(4,6,0)
-- copied from base
atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef' ref f = do
b <- atomicModifyIORef ref
(\x -> let (a, b) = f x
in (a, a `seq` b))
b `seq` return b
#endif
-- | The subsite for the embedded static file server.
data EmbeddedStatic = EmbeddedStatic {
stApp :: !Application
, widgetFiles :: !(IORef (M.HashMap T.Text File))
}
instance RenderRoute EmbeddedStatic where
data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)]
| EmbeddedWidgetR T.Text
deriving (Eq, Show, Read)
renderRoute (EmbeddedResourceR x y) = ("res":x, y)
renderRoute (EmbeddedWidgetR h) = (["widget",h], [])
instance ParseRoute EmbeddedStatic where
parseRoute (("res":x), y) = Just $ EmbeddedResourceR x y
parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h
parseRoute _ = Nothing
-- | At compile time, one of these is created for every 'Entry' created by
-- the generators. The cLink is a template haskell expression of type @Route EmbeddedStatic@.
data ComputedEntry = ComputedEntry {
cHaskellName :: Maybe Name -- ^ Optional haskell name to create a variable for the route
, cStEntry :: Static.EmbeddableEntry -- ^ The entry to be embedded into the executable
, cLink :: ExpQ -- ^ The route for this entry
}
mkStr :: String -> ExpQ
mkStr = litE . stringL
-- | Create a 'ComputedEntry' for development mode, reloading the content on every request.
devEmbed :: Entry -> IO ComputedEntry
devEmbed e = return computed
where
st = Static.EmbeddableEntry {
Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
, Static.eMimeType = ebMimeType e
, Static.eContent = Right [| $(ebDevelReload e) >>= \c ->
return (T.pack (base64md5 c), c) |]
}
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |]
computed = ComputedEntry (ebHaskellName e) st link
-- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable.
prodEmbed :: Entry -> IO ComputedEntry
prodEmbed e = do
ct <- ebProductionContent e
let hash = base64md5 ct
link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e))
[(T.pack "etag", T.pack $(mkStr hash))] |]
st = Static.EmbeddableEntry {
Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
, Static.eMimeType = ebMimeType e
, Static.eContent = Left (T.pack hash, ct)
}
return $ ComputedEntry (ebHaskellName e) st link
tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
tryExtraDevelFiles [] _ = return $ responseLBS status404 [] ""
tryExtraDevelFiles (f:fs) r = do
mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res"
case mct of
Nothing -> tryExtraDevelFiles fs r
Just (mime, ct) -> do
let hash = T.encodeUtf8 $ T.pack $ base64md5 ct
let headers = [ ("Content-Type", mime)
, ("ETag", hash)
]
case lookup "If-None-Match" (requestHeaders r) of
Just h | hash == h -> return $ responseLBS status304 headers ""
_ -> return $ responseLBS status200 headers ct
-- | Helper to create the development application at runtime
develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
develApp settings extra req = do
resp <- staticApp settings {ssMaxAge = NoMaxAge} req
if statusCode (responseStatus resp) == 404
then tryExtraDevelFiles extra req
else return resp
-- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
-> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
-- | Helper for embedStaticContent and embedLicensedStaticContent.
staticContentHelper :: Yesod site
=> (site -> EmbeddedStatic)
-> (Route EmbeddedStatic -> Route site)
-> (BL.ByteString -> Either a BL.ByteString)
-> AddStaticContent site
staticContentHelper getStatic staticR minify ext _ ct = do
wIORef <- widgetFiles . getStatic <$> getYesod
let hash = T.pack $ base64md5 ct
hash' = Just $ T.encodeUtf8 hash
filename = T.concat [hash, ".", ext]
content = case ext of
"js" -> either (const ct) id $ minify ct
_ -> ct
file = File
{ fileGetSize = fromIntegral $ BL.length content
, fileToResponse = \s h -> responseLBS s h content
, fileName = unsafeToPiece filename
, fileGetHash = return hash'
, fileGetModified = Nothing
}
liftIO $ atomicModifyIORef' wIORef $ \m ->
(M.insertWith (\old _ -> old) filename file m, ())
return $ Just $ Right (staticR $ EmbeddedWidgetR filename, [])
-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site.
widgetSettings :: EmbeddedStatic -> StaticSettings
widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile }
where
lookupFile [_,p] = do -- The first part of the path is "widget"
m <- readIORef $ widgetFiles es
return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m
lookupFile _ = return LRNotFound

67
yesod-static/Yesod/EmbeddedStatic/Types.hs Normal file
View File

@ -0,0 +1,67 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module Yesod.EmbeddedStatic.Types(
Location
, Generator
-- ** Entry
, Entry
, ebHaskellName
, ebLocation
, ebMimeType
, ebProductionContent
, ebDevelReload
, ebDevelExtraFiles
) where
import Data.Default
import Language.Haskell.TH
import Network.Mime (MimeType)
import qualified Data.ByteString.Lazy as BL
-- | A location is a relative path within the static subsite at which resource(s) are made available.
-- The location can include slashes to simulate directories but must not start or end with a slash.
type Location = String
-- | A single resource embedded into the executable at compile time.
--
-- This data type is a settings type. For more information, see
-- <http://www.yesodweb.com/book/settings-types>.
data Entry = Entry {
ebHaskellName :: Maybe Name
-- ^ An optional haskell name. If the name is present, a variable
-- of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the
-- given name will be created which points to this resource.
, ebLocation :: Location -- ^ The location to serve the resource from.
, ebMimeType :: MimeType -- ^ The mime type of the resource.
, ebProductionContent :: IO BL.ByteString
-- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False,
-- then at compile time this action will be executed to load the content.
-- During development, this action will not be executed.
, ebDevelReload :: ExpQ
-- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@.
-- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True,
-- this action is executed on every request to compute the content. Most of the
-- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but
-- occasionally you might want additional processing inside the 'ebProductionContent'
-- function like javascript/css minification to only happen when building for production.
, ebDevelExtraFiles :: Maybe ExpQ
-- ^ Occasionally, during development an entry needs extra files/resources available
-- that are not present during production (for example, image files that are embedded
-- into the CSS at production but left unembedded during development). If present,
-- @ebDevelExtraFiles@ must be a template haskell expression of type
-- @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@. That is, a function
-- taking as input the list of path pieces and optionally returning a mime type
-- and content.
}
-- | When using 'def', you must fill in at least 'ebLocation'.
instance Default Entry where
def = Entry { ebHaskellName = Nothing
, ebLocation = "xxxx"
, ebMimeType = "application/octet-stream"
, ebProductionContent = return BL.empty
, ebDevelReload = [| return BL.empty |]
, ebDevelExtraFiles = Nothing
}
-- | An embedded generator is executed at compile time to produce the entries to embed.
type Generator = Q [Entry]

10
yesod-static/Yesod/Static.hs
View File

@ -35,7 +35,6 @@ module Yesod.Static
-- * Smart constructor
, static
, staticDevel
, embed
-- * Combining CSS/JS
-- $combining
, combineStylesheets'
@ -54,6 +53,8 @@ module Yesod.Static
, publicFiles
-- * Hashing
, base64md5
-- * Embed
, embed
#ifdef TEST_EXPORT
, getFileListPieces
#endif
@ -134,8 +135,11 @@ staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
-- | Produce a 'Static' based on embedding all of the static
-- files' contents in the executable at compile time.
-- | Produce a 'Static' based on embedding all of the static files' contents in the
-- executable at compile time.
--
-- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful.
--
-- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs
-- you will need to change the scaffolded addStaticContent. Otherwise, some of your
-- assets will be 404'ed. This is because by default yesod will generate compile those

53
yesod-static/sample-embed.hs
View File

@ -1,23 +1,42 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
import Yesod.Static
import Yesod.Dispatch
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-- | This embeds just a single file; it embeds the source code file
-- \"sample-embed.hs\" from the current directory so when you compile,
-- the sample-embed.hs file must be in the current directory.
--
-- Try toggling the development argument to 'mkEmbeddedStatic'. When the
-- development argument is true the file \"sample-embed.hs\" is reloaded
-- from disk on every request (try changing it after you start the server).
-- When development is false, the contents are embedded and the sample-embed.hs
-- file does not even need to be present during runtime.
module Main where
import Yesod.Core
import Network.Wai.Handler.Warp (run)
import Yesod.EmbeddedStatic
staticFiles "."
mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"]
data Sample = Sample
getStatic _ = $(embed "tests")
mkYesod "Sample" [parseRoutes|
/ RootR GET
/static StaticR Static getStatic
-- The above will generate variables
-- eStatic :: EmbeddedStatic
-- sample_embed_hs :: Route EmbeddedStatic
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/ HomeR GET
/static StaticR EmbeddedStatic getStatic
|]
instance Yesod Sample where approot _ = ""
getRootR = do
redirectText RedirectPermanent "static"
return ()
instance Yesod MyApp where
addStaticContent = embedStaticContent getStatic StaticR Right
main = toWaiApp Sample >>= run 3000
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
toWidget [julius|console.log("Hello World");|]
[whamlet|
<h1>Hello
<p>Check the
<a href=@{StaticR sample_embed_hs}>embedded file
|]
main :: IO ()
main = warp 3000 $ MyApp eStatic

95
yesod-static/test/EmbedDevelTest.hs Normal file
View File

@ -0,0 +1,95 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
module EmbedDevelTest where
-- Tests the development mode of the embedded static subsite by
-- using a custom generator testGen.
import Data.Maybe (isNothing)
import EmbedTestGenerator
import EmbedProductionTest (findEtag)
import Network.Wai.Test (SResponse(simpleHeaders))
import Test.HUnit (assertBool)
import Test.Hspec (Spec)
import Yesod.Core
import Yesod.EmbeddedStatic
import Yesod.Test
mkEmbeddedStatic True "eDev" [testGen]
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/static StaticR EmbeddedStatic getStatic
|]
instance Yesod MyApp
noCacheControl :: YesodExample site ()
noCacheControl = withResponse $ \r -> do
liftIO $ assertBool "Cache-Control exists" $
isNothing $ lookup "Cache-Control" $ simpleHeaders r
liftIO $ assertBool "Expires exists" $
isNothing $ lookup "Expires" $ simpleHeaders r
embedDevSpecs :: Spec
embedDevSpecs = yesodSpec (MyApp eDev) $ do
ydescribe "Embedded Development Entries" $ do
yit "e1 loads" $ do
get $ StaticR e1
statusIs 200
assertHeader "Content-Type" "text/plain"
noCacheControl
bodyEquals "e1 devel"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR e1
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e2 with simulated directory" $ do
get $ StaticR e2
statusIs 200
assertHeader "Content-Type" "abcdef"
noCacheControl
bodyEquals "e2 devel"
yit "e3 without haskell name" $ do
get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
statusIs 200
assertHeader "Content-Type" "yyy"
noCacheControl
bodyEquals "e3 devel"
yit "e4 loads" $ do
get $ StaticR e4
statusIs 200
assertHeader "Content-Type" "text/plain"
noCacheControl
bodyEquals "e4 devel"
yit "e4 extra development dev1" $ do
get $ StaticR $ embeddedResourceR ["dev1"] []
statusIs 200
assertHeader "Content-Type" "mime"
noCacheControl
bodyEquals "dev1 content"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR $ embeddedResourceR ["dev1"] []
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e4 extra development with path" $ do
get $ StaticR $ embeddedResourceR ["dir", "dev2"] []
statusIs 200
assertHeader "Content-Type" "mime2"
noCacheControl
bodyEquals "dev2 content"
yit "extra development file 404" $ do
get $ StaticR $ embeddedResourceR ["xxxxxxxxxx"] []
statusIs 404

118
yesod-static/test/EmbedProductionTest.hs Normal file
View File

@ -0,0 +1,118 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
module EmbedProductionTest where
-- Tests the production mode of the embedded static subsite by
-- using a custom generator testGen. Also tests that the widget
-- content is embedded properly.
import Data.Maybe (isJust)
import EmbedTestGenerator
import Network.Wai.Test (SResponse(simpleHeaders))
import Test.HUnit (assertFailure, assertBool)
import Test.Hspec (Spec)
import Yesod.Core
import Yesod.EmbeddedStatic
import Yesod.Test
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
mkEmbeddedStatic False "eProduction" [testGen]
data MyApp = MyApp { getStatic :: EmbeddedStatic }
mkYesod "MyApp" [parseRoutes|
/ HomeR GET
/static StaticR EmbeddedStatic getStatic
|]
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
toWidget [julius|console.log("Hello World");|]
[whamlet|<h1>Hello|]
instance Yesod MyApp where
addStaticContent = embedStaticContent getStatic StaticR Right
findEtag :: YesodExample site B.ByteString
findEtag = withResponse $ \r ->
case lookup "ETag" (simpleHeaders r) of
Nothing -> liftIO (assertFailure "No etag found") >> error ""
Just e -> return e
hasCacheControl :: YesodExample site ()
hasCacheControl = withResponse $ \r -> do
liftIO $ assertBool "Cache-Control missing" $
isJust $ lookup "Cache-Control" $ simpleHeaders r
liftIO $ assertBool "Expires missing" $
isJust $ lookup "Expires" $ simpleHeaders r
embedProductionSpecs :: Spec
embedProductionSpecs = yesodSpec (MyApp eProduction) $ do
ydescribe "Embedded Production Entries" $ do
yit "e1 loads" $ do
get $ StaticR e1
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e1 production"
tag <- findEtag
request $ do
setMethod "GET"
setUrl $ StaticR e1
addRequestHeader ("If-None-Match", tag)
statusIs 304
yit "e1 with custom built path" $ do
get $ StaticR $ embeddedResourceR ["e1"] []
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e1 production"
yit "e2 with simulated directory" $ do
get $ StaticR e2
statusIs 200
assertHeader "Content-Type" "abcdef"
hasCacheControl
bodyEquals "e2 production"
yit "e2 with custom built directory path" $ do
get $ StaticR $ embeddedResourceR ["dir", "e2"] []
statusIs 200
assertHeader "Content-Type" "abcdef"
hasCacheControl
bodyEquals "e2 production"
yit "e3 without haskell name" $ do
get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
statusIs 200
assertHeader "Content-Type" "yyy"
hasCacheControl
bodyEquals "e3 production"
yit "e4 is embedded" $ do
get $ StaticR e4
statusIs 200
assertHeader "Content-Type" "text/plain"
hasCacheControl
bodyEquals "e4 production"
yit "e4 extra development files are not embedded" $ do
get $ StaticR $ embeddedResourceR ["dev1"] []
statusIs 404
ydescribe "Embedded Widget Content" $
yit "Embedded Javascript" $ do
get HomeR
statusIs 200
[script] <- htmlQuery "script"
let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is "
get $ TL.toStrict $ TL.decodeUtf8 src
statusIs 200
hasCacheControl
assertHeader "Content-Type" "application/javascript"
bodyEquals "console.log(\"Hello World\");"

62
yesod-static/test/EmbedTestGenerator.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module EmbedTestGenerator (testGen) where
import Data.Default
import Network.Mime (MimeType)
import Yesod.EmbeddedStatic.Types
import Yesod.EmbeddedStatic.Generators (pathToName)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString.Lazy as BL
e1, e2, e3, e4 :: Entry
-- Basic entry
e1 = def
{ ebHaskellName = Just $ pathToName "e1"
, ebLocation = "e1"
, ebMimeType = "text/plain"
, ebProductionContent = return $ TL.encodeUtf8 "e1 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |]
, ebDevelExtraFiles = Nothing
}
-- Test simulated directory in location
e2 = def
{ ebHaskellName = Just $ pathToName "e2"
, ebLocation = "dir/e2"
, ebMimeType = "abcdef"
, ebProductionContent = return $ TL.encodeUtf8 "e2 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |]
, ebDevelExtraFiles = Nothing
}
-- Test empty haskell name
e3 = def
{ ebHaskellName = Nothing
, ebLocation = "xxxx/e3"
, ebMimeType = "yyy"
, ebProductionContent = return $ TL.encodeUtf8 "e3 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |]
, ebDevelExtraFiles = Nothing
}
devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
devExtra ["dev1"] = return $ Just ("mime", "dev1 content")
devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content")
devExtra _ = return Nothing
-- Entry with devel extra files
e4 = def
{ ebHaskellName = Just $ pathToName "e4"
, ebLocation = "e4"
, ebMimeType = "text/plain"
, ebProductionContent = return $ TL.encodeUtf8 "e4 production"
, ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |]
, ebDevelExtraFiles = Just [| devExtra |]
}
testGen :: Generator
testGen = return [e1, e2, e3, e4]

92
yesod-static/test/FileGeneratorTests.hs Normal file
View File

@ -0,0 +1,92 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module FileGeneratorTests (fileGenSpecs) where
import Control.Exception
import Control.Monad (forM_)
import GeneratorTestUtil
import Test.Hspec
import Test.HUnit (assertFailure, assertEqual)
import Yesod.EmbeddedStatic.Generators
import qualified Data.ByteString.Lazy as BL
-- | Embeds the LICENSE file
license :: GenTestResult
license = $(embedFile "LICENSE" >>=
testOneEntry (Just "_LICENSE") "LICENSE" (BL.readFile "LICENSE")
)
licenseAt :: GenTestResult
licenseAt = $(embedFileAt "abc.txt" "LICENSE" >>=
testOneEntry (Just "abc_txt") "abc.txt" (BL.readFile "LICENSE")
)
embDir :: [GenTestResult]
embDir = $(embedDir "test/embed-dir" >>=
testEntries
[ (Just "abc_def_txt", "abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
, (Just "lorem_txt", "lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
, (Just "foo", "foo", BL.readFile "test/embed-dir/foo")
]
)
embDirAt :: [GenTestResult]
embDirAt = $(embedDirAt "xxx" "test/embed-dir" >>=
testEntries
[ (Just "xxx_abc_def_txt", "xxx/abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
, (Just "xxx_lorem_txt", "xxx/lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
, (Just "xxx_foo", "xxx/foo", BL.readFile "test/embed-dir/foo")
]
)
concatR :: GenTestResult
concatR = $(concatFiles "out.txt" [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
testOneEntry (Just "out_txt") "out.txt" (return "Yesod Rocks\nBar\n")
)
-- The transform function should only run at compile for the production content
concatWithR :: GenTestResult
concatWithR = $(concatFilesWith "out2.txt"
(\x -> return $ x `BL.append` "Extra")
[ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
testOneEntry (Just "out2_txt") "out2.txt" (return "Yesod Rocks\nBar\nExtra")
)
fileGenSpecs :: Spec
fileGenSpecs = do
describe "Embed File" $ do
it "embeds a single file" $
assertGenResult (BL.readFile "LICENSE") license
it "embeds a single file at a location" $
assertGenResult (BL.readFile "LICENSE") licenseAt
describe "Embed Directory" $ do
it "embeds a directory" $
forM_ [embDir, embDirAt] $ \d -> case d of
[GenError e] -> assertFailure e
[def, foo, lorem] -> do
assertGenResult (BL.readFile "test/embed-dir/abc/def.txt") def
assertGenResult (BL.readFile "test/embed-dir/foo") foo
assertGenResult (BL.readFile "test/embed-dir/lorem.txt") lorem
_ -> assertFailure "Bad directory list"
describe "Concat Files" $ do
it "simple concat" $
assertGenResult (return "Yesod Rocks\nBar\n") concatR
it "concat with processing function" $
assertGenResult (return "Yesod Rocks\nBar\n") concatWithR -- no Extra since this is development
describe "Compress" $ do
it "compress tool function" $ do
out <- compressTool "runhaskell" [] "main = putStrLn \"Hello World\""
assertEqual "" "Hello World\n" out
it "tryCompressTools" $ do
out <- flip tryCompressTools "abcdef"
[ const $ throwIO $ ErrorCall "An expected error"
, const $ return "foo"
, const $ return "bar"
]
assertEqual "" "foo" out
out2 <- flip tryCompressTools "abcdef"
[ const $ throwIO $ ErrorCall "An expected error"]
assertEqual "" "abcdef" out2

59
yesod-static/test/GeneratorTestUtil.hs Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module GeneratorTestUtil where
import Control.Applicative
import Control.Monad (when)
import Data.List (sortBy)
import Language.Haskell.TH
import Test.HUnit
import Yesod.EmbeddedStatic.Types
import qualified Data.ByteString.Lazy as BL
-- We test the generators by executing them at compile time
-- and sticking the result into the GenTestResult. We then
-- test the GenTestResult at runtime. But to test the ebDevelReload
-- we must run the action at runtime so that is also embedded.
-- Because of template haskell stage restrictions, this code
-- needs to be in a separate module.
data GenTestResult = GenError String
| GenSuccessWithDevel (IO BL.ByteString)
-- | Creates a GenTestResult at compile time by testing the entry.
testEntry :: Maybe String -> Location -> IO BL.ByteString -> Entry -> ExpQ
testEntry name _ _ e | ebHaskellName e /= (mkName <$> name) =
[| GenError ("haskell name " ++ $(litE $ stringL $ show $ ebHaskellName e)
++ " /= "
++ $(litE $ stringL $ show name)) |]
testEntry _ loc _ e | ebLocation e /= loc =
[| GenError ("location " ++ $(litE $ stringL $ show $ ebLocation e)) |]
testEntry _ _ act e = do
expected <- runIO act
actual <- runIO $ ebProductionContent e
if expected == actual
then [| GenSuccessWithDevel $(ebDevelReload e) |]
else [| GenError "production content" |]
testOneEntry :: Maybe String -> Location -> IO BL.ByteString -> [Entry] -> ExpQ
testOneEntry name loc ct [e] = testEntry name loc ct e
testOneEntry _ _ _ _ = [| GenError "not exactly one entry" |]
-- | Tests a list of entries
testEntries :: [(Maybe String, Location, IO BL.ByteString)] -> [Entry] -> ExpQ
testEntries a b | length a /= length b = [| [GenError "lengths differ"] |]
testEntries a b = listE $ zipWith f a' b'
where
a' = sortBy (\(_,l1,_) (_,l2,_) -> compare l1 l2) a
b' = sortBy (\e1 e2 -> ebLocation e1 `compare` ebLocation e2) b
f (name, loc, ct) e = testEntry name loc ct e
-- | Use this at runtime to assert the 'GenTestResult' is OK
assertGenResult :: (IO BL.ByteString) -- ^ expected development content
-> GenTestResult -- ^ test result created at compile time
-> Assertion
assertGenResult _ (GenError e) = assertFailure ("invalid " ++ e)
assertGenResult mexpected (GenSuccessWithDevel mactual) = do
expected <- mexpected
actual <- mactual
when (expected /= actual) $
assertFailure "invalid devel content"

1
yesod-static/test/embed-dir/abc/def.txt Normal file
View File

@ -0,0 +1 @@
Yesod Rocks

1
yesod-static/test/embed-dir/foo Normal file
View File

@ -0,0 +1 @@
Bar

6
yesod-static/test/embed-dir/lorem.txt Normal file
View File

@ -0,0 +1,6 @@
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor
incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis
nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.
Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu
fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in
culpa qui officia deserunt mollit anim id est laborum.

9
yesod-static/test/tests.hs
View File

@ -2,6 +2,13 @@
import Test.Hspec
import YesodStaticTest (specs)
import EmbedProductionTest (embedProductionSpecs)
import EmbedDevelTest (embedDevSpecs)
import FileGeneratorTests (fileGenSpecs)
main :: IO ()
main = hspec specs
main = hspec $ do
specs
embedProductionSpecs
embedDevSpecs
fileGenSpecs

37
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static
version: 1.2.0.1
version: 1.2.1
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -12,12 +12,16 @@ build-type: Simple
homepage: http://www.yesodweb.com/
description: Static file serving subsite for Yesod Web Framework.
extra-source-files:
test/YesodStaticTest.hs
test/tests.hs
sample.hs
sample-embed.hs
test/*.hs
test/fs/bar/baz
test/fs/tmp/ignored
test/fs/.ignored
test/fs/foo
test/embed-dir/foo
test/embed-dir/lorem.txt
test/embed-dir/abc/def.txt
library
build-depends: base >= 4 && < 5
@ -30,7 +34,7 @@ library
, template-haskell
, directory >= 1.0
, transformers >= 0.2.2
, wai-app-static >= 1.3
, wai-app-static >= 1.3.2
, wai >= 1.3
, text >= 0.9
, file-embed >= 0.0.4.1 && < 0.5
@ -43,8 +47,22 @@ library
, system-fileio >= 0.3
, data-default
, shakespeare-css >= 1.0.3
, mime-types >= 0.1
, hjsmin
, process-conduit >= 1.0 && < 1.1
, filepath >= 1.3
, resourcet >= 0.4
, unordered-containers >= 0.2
exposed-modules: Yesod.Static
Yesod.EmbeddedStatic
Yesod.EmbeddedStatic.Generators
Yesod.EmbeddedStatic.Types
other-modules: Yesod.EmbeddedStatic.Internal
ghc-options: -Wall
extensions: TemplateHaskell
test-suite tests
hs-source-dirs: ., test
@ -53,6 +71,10 @@ test-suite tests
cpp-options: -DTEST_EXPORT
build-depends: base
, hspec >= 1.3
, yesod-test >= 1.2
, wai-test
, HUnit
-- copy from above
, containers
, old-time
@ -76,8 +98,15 @@ test-suite tests
, system-fileio
, data-default
, shakespeare-css
, mime-types
, hjsmin
, process-conduit
, filepath
, resourcet
, unordered-containers
ghc-options: -Wall
extensions: TemplateHaskell
source-repository head
type: git

2
yesod/Yesod/Default/Config.hs
View File

@ -70,7 +70,7 @@ parseArgConfig = do
getPort front (arg:rest) = getPort (front . (arg:)) rest
capitalize [] = []
capitalize (x:xs) = toUpper x : map toLower xs
capitalize (x:xs) = toUpper x : xs
-- | Load the app config from command line parameters, using the given
-- @ConfigSettings.

2
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod
version: 1.2.2.1
version: 1.2.3
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>