Merge branch 'master' of https://github.com/yesodweb/yesod into testable
This commit is contained in:
commit
5d9c068a8e
2
scripts
2
scripts
@ -1 +1 @@
|
||||
Subproject commit f56426fada59012329f23c928a2d7f9c3a515d75
|
||||
Subproject commit e791ced0395245e30d37b5098a27bba5e818ecb7
|
||||
182
yesod-core/Yesod/Config.hs
Normal file
182
yesod-core/Yesod/Config.hs
Normal file
@ -0,0 +1,182 @@
|
||||
module Yesod.Config
|
||||
( AppConfig(..)
|
||||
, PostgresConf(..)
|
||||
, SqliteConf(..)
|
||||
, MongoConf(..)
|
||||
, loadConfig
|
||||
, loadPostgresql
|
||||
, loadSqlite
|
||||
, loadMongo
|
||||
) where
|
||||
|
||||
import Control.Monad (join, forM)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Object
|
||||
import Data.Object.Yaml
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | Dynamic per-environment configuration which can be loaded at
|
||||
-- run-time negating the need to recompile between environments.
|
||||
data AppConfig e = AppConfig
|
||||
{ appEnv :: e
|
||||
, appPort :: Int
|
||||
, appRoot :: Text
|
||||
} deriving (Show)
|
||||
|
||||
-- separate types means more code here, but it's easier to use in the
|
||||
-- scaffold
|
||||
|
||||
-- | Information required to connect to a postgres database
|
||||
data PostgresConf = PostgresConf
|
||||
{ pgConnStr :: Text
|
||||
, pgPoolSize :: Int
|
||||
}
|
||||
|
||||
-- | Information required to connect to a sqlite database
|
||||
data SqliteConf = SqliteConf
|
||||
{ sqlDatabase :: Text
|
||||
, sqlPoolSize :: Int
|
||||
}
|
||||
|
||||
-- | Information required to connect to a mongo database
|
||||
data MongoConf = MongoConf
|
||||
{ mgDatabase :: String
|
||||
, mgHost :: String
|
||||
, mgPoolSize :: Int
|
||||
}
|
||||
|
||||
-- | Load an @'AppConfig'@ from @config\/settings.yml@.
|
||||
--
|
||||
-- Some examples:
|
||||
--
|
||||
-- > -- typical local development
|
||||
-- > Development:
|
||||
-- > host: localhost
|
||||
-- > port: 3000
|
||||
-- >
|
||||
-- > -- ssl: will default false
|
||||
-- > -- approot: will default to "http://localhost:3000"
|
||||
--
|
||||
-- > -- typical outward-facing production box
|
||||
-- > Production:
|
||||
-- > host: www.example.com
|
||||
-- >
|
||||
-- > -- ssl: will default false
|
||||
-- > -- port: will default 80
|
||||
-- > -- approot: will default "http://www.example.com"
|
||||
--
|
||||
-- > -- maybe you're reverse proxying connections to the running app
|
||||
-- > -- on some other port
|
||||
-- > Production:
|
||||
-- > port: 8080
|
||||
-- > approot: "http://example.com"
|
||||
-- >
|
||||
-- > -- approot is specified so that the non-80 port is not appended
|
||||
-- > -- automatically.
|
||||
--
|
||||
loadConfig :: Show e => e -> IO (AppConfig e)
|
||||
loadConfig env = withYamlEnvironment "config/settings.yml" env $ \e -> do
|
||||
let mssl = lookupScalar "ssl" e
|
||||
let mhost = lookupScalar "host" e
|
||||
let mport = lookupScalar "port" e
|
||||
let mapproot = lookupScalar "approot" e
|
||||
|
||||
-- set some default arguments
|
||||
let ssl = maybe False toBool mssl
|
||||
port <- safeRead "port" $ fromMaybe (if ssl then "443" else "80") mport
|
||||
|
||||
approot <- case (mhost, mapproot) of
|
||||
(_ , Just ar) -> return ar
|
||||
(Just host, _ ) -> return $ (if ssl then "https://" else "http://") ++ host ++ (addPort ssl port)
|
||||
_ -> fail "You must supply either a host or approot"
|
||||
|
||||
return $ AppConfig
|
||||
{ appEnv = env
|
||||
, appPort = port
|
||||
, appRoot = T.pack approot
|
||||
}
|
||||
|
||||
where
|
||||
toBool :: String -> Bool
|
||||
toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"])
|
||||
|
||||
addPort :: Bool -> Int -> String
|
||||
addPort True 443 = ""
|
||||
addPort False 80 = ""
|
||||
addPort _ p = ":" ++ show p
|
||||
|
||||
-- | Load a @'PostgresConf'@ from @config\/postgresql.yml@.
|
||||
--
|
||||
-- > Production:
|
||||
-- > user: jsmith
|
||||
-- > password: secret
|
||||
-- > host: localhost
|
||||
-- > port: 5432
|
||||
-- > database: some_db
|
||||
-- > poolsize: 100
|
||||
--
|
||||
loadPostgresql :: Show e => e -> IO PostgresConf
|
||||
loadPostgresql env = withYamlEnvironment "config/postgresql.yml" env $ \e -> do
|
||||
db <- lookupScalar "database" e
|
||||
pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
|
||||
|
||||
-- TODO: default host/port?
|
||||
connparts <- forM ["user", "password", "host", "port"] $ \k -> do
|
||||
v <- lookupScalar k e
|
||||
return $ k ++ "=" ++ v ++ " "
|
||||
|
||||
conn <- return $ concat connparts
|
||||
|
||||
return $ PostgresConf (T.pack $ conn ++ " dbname=" ++ db) pool
|
||||
|
||||
-- | Load a @'SqliteConf'@ from @config\/sqlite.yml@.
|
||||
--
|
||||
-- > Production:
|
||||
-- > database: foo.s3db
|
||||
-- > poolsize: 100
|
||||
--
|
||||
loadSqlite :: Show e => e -> IO SqliteConf
|
||||
loadSqlite env = withYamlEnvironment "config/sqlite.yml" env $ \e -> do
|
||||
db <- lookupScalar "database" e
|
||||
pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
|
||||
|
||||
return $ SqliteConf (T.pack db) pool
|
||||
|
||||
-- | Load a @'MongoConf'@ from @config\/mongoDB.yml@.
|
||||
--
|
||||
-- > Production:
|
||||
-- > database: some_db
|
||||
-- > host: localhost
|
||||
-- > poolsize: 100
|
||||
--
|
||||
loadMongo :: Show e => e -> IO MongoConf
|
||||
loadMongo env = withYamlEnvironment "config/mongoDB.yml" env $ \e -> do
|
||||
db <- lookupScalar "database" e
|
||||
host <- lookupScalar "host" e
|
||||
pool <- safeRead "poolsize" =<< lookupScalar "poolsize" e
|
||||
|
||||
return $ MongoConf db host pool
|
||||
|
||||
-- | Loads the configuration block in the passed file named by the
|
||||
-- passed environment, yeilds to the passed function as a mapping.
|
||||
--
|
||||
-- Errors in the case of a bad load or if your function returns
|
||||
-- @Nothing@.
|
||||
withYamlEnvironment :: (IsYamlScalar v, Show e)
|
||||
=> FilePath -- ^ the yaml file
|
||||
-> e -- ^ the environment you want to load
|
||||
-> ([(String, Object String v)] -> IO a) -- ^ what to do with the mapping
|
||||
-> IO a
|
||||
withYamlEnvironment fp env f = do
|
||||
obj <- join $ decodeFile fp
|
||||
envs <- fromMapping obj
|
||||
conf <- lookupMapping (show env) envs
|
||||
f conf
|
||||
|
||||
-- | Returns 'fail' if read fails
|
||||
safeRead :: Monad m => String -> String -> m Int
|
||||
safeRead name s = case reads s of
|
||||
(i, _):_ -> return i
|
||||
[] -> fail $ concat ["Invalid value for ", name, ": ", s]
|
||||
@ -33,6 +33,7 @@ module Yesod.Core
|
||||
, module Yesod.Request
|
||||
, module Yesod.Widget
|
||||
, module Yesod.Message
|
||||
, module Yesod.Config
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Core
|
||||
@ -42,6 +43,7 @@ import Yesod.Handler
|
||||
import Yesod.Request
|
||||
import Yesod.Widget
|
||||
import Yesod.Message
|
||||
import Yesod.Config
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Text (Text)
|
||||
|
||||
@ -54,6 +54,8 @@ library
|
||||
, case-insensitive >= 0.2 && < 0.4
|
||||
, parsec >= 2 && < 3.2
|
||||
, directory >= 1 && < 1.2
|
||||
, data-object >= 0.3 && < 0.4
|
||||
, data-object-yaml >= 0.3 && < 0.4
|
||||
-- for logger. Probably logger should be a separate package
|
||||
, strict-concurrency >= 0.2.4 && < 0.2.5
|
||||
|
||||
@ -65,6 +67,7 @@ library
|
||||
Yesod.Request
|
||||
Yesod.Widget
|
||||
Yesod.Message
|
||||
Yesod.Config
|
||||
Yesod.Internal.TestApi
|
||||
other-modules: Yesod.Internal
|
||||
Yesod.Internal.Core
|
||||
|
||||
25
yesod-default/LICENSE
Normal file
25
yesod-default/LICENSE
Normal file
@ -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.
|
||||
0
yesod-default/README
Normal file
0
yesod-default/README
Normal file
7
yesod-default/Setup.lhs
Executable file
7
yesod-default/Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
||||
75
yesod-default/Yesod/Default/Config.hs
Normal file
75
yesod-default/Yesod/Default/Config.hs
Normal file
@ -0,0 +1,75 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Yesod.Default.Config
|
||||
( DefaultEnv(..)
|
||||
, ArgConfig(..)
|
||||
, defaultArgConfig
|
||||
, fromArgs
|
||||
, fromArgsWith
|
||||
, loadDevelopmentConfig
|
||||
|
||||
-- reexport
|
||||
, module Yesod.Config
|
||||
) where
|
||||
|
||||
import Yesod.Config
|
||||
import Data.Char (toUpper, toLower)
|
||||
import System.Console.CmdArgs hiding (args)
|
||||
|
||||
-- | A yesod-provided @'AppEnv'@, allows for Development, Testing, and
|
||||
-- Production environments
|
||||
data DefaultEnv = Development
|
||||
| Testing
|
||||
| Staging
|
||||
| Production deriving (Read, Show, Enum, Bounded)
|
||||
|
||||
-- | Setup commandline arguments for environment and port
|
||||
data ArgConfig = ArgConfig
|
||||
{ environment :: String
|
||||
, port :: Int
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
-- | A default @'ArgConfig'@ if using the provided @'DefaultEnv'@ type.
|
||||
defaultArgConfig :: ArgConfig
|
||||
defaultArgConfig =
|
||||
ArgConfig
|
||||
{ environment = "development"
|
||||
&= help ("application environment, one of: " ++ environments)
|
||||
&= typ "ENVIRONMENT"
|
||||
, port = def
|
||||
&= help "the port to listen on"
|
||||
&= typ "PORT"
|
||||
}
|
||||
|
||||
where
|
||||
environments :: String
|
||||
environments = foldl1 (\a b -> a ++ ", " ++ b)
|
||||
. map ((map toLower) . show)
|
||||
$ ([minBound..maxBound] :: [DefaultEnv])
|
||||
|
||||
-- | Load an @'AppConfig'@ using the @'DefaultEnv'@ environments from
|
||||
-- commandline arguments.
|
||||
fromArgs :: IO (AppConfig DefaultEnv)
|
||||
fromArgs = fromArgsWith defaultArgConfig
|
||||
|
||||
fromArgsWith :: (Read e, Show e) => ArgConfig -> IO (AppConfig e)
|
||||
fromArgsWith argConfig = do
|
||||
args <- cmdArgs argConfig
|
||||
|
||||
env <-
|
||||
case reads $ capitalize $ environment args of
|
||||
(e, _):_ -> return e
|
||||
[] -> error $ "Invalid environment: " ++ environment args
|
||||
|
||||
config <- loadConfig env
|
||||
|
||||
return $ if port args /= 0
|
||||
then config { appPort = port args }
|
||||
else config
|
||||
|
||||
where
|
||||
capitalize [] = []
|
||||
capitalize (x:xs) = toUpper x : map toLower xs
|
||||
|
||||
-- | Load your development config (when using @'DefaultEnv'@)
|
||||
loadDevelopmentConfig :: IO (AppConfig DefaultEnv)
|
||||
loadDevelopmentConfig = loadConfig Development
|
||||
63
yesod-default/Yesod/Default/Main.hs
Normal file
63
yesod-default/Yesod/Default/Main.hs
Normal file
@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Yesod.Default.Main
|
||||
( defaultMain
|
||||
, defaultDevelApp
|
||||
, defaultDevelAppWith
|
||||
) where
|
||||
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Logger (Logger, makeLogger, logString, logLazyText, flushLogger)
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
|
||||
-- | Run your app, taking environment and port settings from the
|
||||
-- commandline.
|
||||
--
|
||||
-- Use @'fromArgs'@ when using the provided @'DefaultEnv'@ type, or
|
||||
-- @'fromArgsWith'@ when using a custom type
|
||||
--
|
||||
-- > main :: IO ()
|
||||
-- > main = defaultMain fromArgs withMySite
|
||||
--
|
||||
-- or
|
||||
--
|
||||
-- > main :: IO ()
|
||||
-- > main = defaultMain (fromArgsWith customArgConfig) withMySite
|
||||
--
|
||||
defaultMain :: (Show e, Read e) => IO (AppConfig e) -> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -> IO ()
|
||||
defaultMain load withSite = do
|
||||
config <- load
|
||||
logger <- makeLogger
|
||||
withSite config logger $ run (appPort config)
|
||||
|
||||
-- | Run your development app using the provided @'DefaultEnv'@ type
|
||||
--
|
||||
-- > withDevelAppPort :: Dynamic
|
||||
-- > withDevelAppPort = toDyn $ defaultDevelApp withMySite
|
||||
--
|
||||
defaultDevelApp :: (AppConfig DefaultEnv -> Logger -> (Application -> IO ()) -> IO ())
|
||||
-> ((Int, Application) -> IO ())
|
||||
-> IO ()
|
||||
defaultDevelApp = defaultDevelAppWith loadDevelopmentConfig
|
||||
|
||||
-- | Run your development app using a custom environment type and loader
|
||||
-- function
|
||||
--
|
||||
-- > withDevelAppPort :: Dynamic
|
||||
-- > withDevelAppPort = toDyn $ (defaultDevelAppWith customLoadAppConfig) withMySite
|
||||
--
|
||||
defaultDevelAppWith :: (Show e, Read e)
|
||||
=> IO (AppConfig e) -- ^ A means to load your development @'AppConfig'@
|
||||
-> (AppConfig e -> Logger -> (Application -> IO ()) -> IO ()) -- ^ Your @withMySite@ function
|
||||
-> ((Int, Application) -> IO ()) -> IO ()
|
||||
defaultDevelAppWith load withSite f = do
|
||||
conf <- load
|
||||
logger <- makeLogger
|
||||
let p = appPort conf
|
||||
logString logger $ "Devel application launched, listening on port " ++ show p
|
||||
withSite conf logger $ \app -> f (p, debugHandle (logHandle logger) app)
|
||||
flushLogger logger
|
||||
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
43
yesod-default/Yesod/Default/Util.hs
Normal file
43
yesod-default/Yesod/Default/Util.hs
Normal file
@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | Various utilities used in the scaffolded site.
|
||||
module Yesod.Default.Util
|
||||
( addStaticContentExternal
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Yesod.Core -- purposely using complete import so that Haddock will see addStaticContent
|
||||
import Control.Monad (unless)
|
||||
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
||||
|
||||
-- | An implementation of 'addStaticContent' which stores the contents in an
|
||||
-- external file. Files are created in the given static folder with names based
|
||||
-- on a hash of their content. This allows expiration dates to be set far in
|
||||
-- the future without worry of users receiving stale content.
|
||||
addStaticContentExternal
|
||||
:: (L.ByteString -> Either a L.ByteString) -- ^ javascript minifier
|
||||
-> (L.ByteString -> String) -- ^ hash function to determine file name
|
||||
-> FilePath -- ^ location of static directory. files will be placed within a "tmp" subfolder
|
||||
-> ([Text] -> Route master) -- ^ route constructor, taking a list of pieces
|
||||
-> Text -- ^ filename extension
|
||||
-> Text -- ^ mime type
|
||||
-> L.ByteString -- ^ file contents
|
||||
-> GHandler sub master (Maybe (Either Text (Route master, [(Text, Text)])))
|
||||
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
exists <- liftIO $ doesFileExist fn'
|
||||
unless exists $ liftIO $ L.writeFile fn' content'
|
||||
return $ Just $ Right (toRoute ["tmp", pack fn], [])
|
||||
where
|
||||
fn, statictmp, fn' :: FilePath
|
||||
-- by basing the hash off of the un-minified content, we avoid a costly
|
||||
-- minification if the file already exists
|
||||
fn = hash content ++ '.' : unpack ext'
|
||||
statictmp = staticDir ++ "/tmp/"
|
||||
fn' = statictmp ++ fn
|
||||
|
||||
content' :: L.ByteString
|
||||
content'
|
||||
| ext' == "js" = either (const content) id $ minify content
|
||||
| otherwise = content
|
||||
36
yesod-default/yesod-default.cabal
Normal file
36
yesod-default/yesod-default.cabal
Normal file
@ -0,0 +1,36 @@
|
||||
name: yesod-default
|
||||
version: 0.3.1
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Patrick Brisbin
|
||||
maintainer: Patrick Brisbin <pbrisbin@gmail.com>
|
||||
synopsis: Default config and main functions for your yesod application
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: Convenient wrappers for your the configuration and
|
||||
execution of your yesod application
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, cmdargs >= 0.8 && < 0.9
|
||||
, warp >= 0.4 && < 0.5
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, bytestring >= 0.9 && < 0.10
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, text >= 0.9 && < 1.0
|
||||
, directory >= 1.0 && < 1.2
|
||||
|
||||
exposed-modules: Yesod.Default.Config
|
||||
, Yesod.Default.Main
|
||||
, Yesod.Default.Util
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/yesodweb/yesod.git
|
||||
@ -31,6 +31,7 @@ module Yesod.Form.Functions
|
||||
, check
|
||||
, checkBool
|
||||
, checkM
|
||||
, customErrorMessage
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
@ -309,3 +310,8 @@ checkM f field = field
|
||||
Right Nothing -> return $ Right Nothing
|
||||
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
|
||||
}
|
||||
|
||||
-- | Allows you to overwrite the error message on parse error.
|
||||
customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a
|
||||
customErrorMessage msg field = field { fieldParse = \ts -> fmap (either
|
||||
(const $ Left msg) Right) $ fieldParse field ts }
|
||||
|
||||
@ -29,6 +29,7 @@ module Yesod.Static
|
||||
, embed
|
||||
-- * Template Haskell helpers
|
||||
, staticFiles
|
||||
, staticFilesList
|
||||
, publicFiles
|
||||
-- * Hashing
|
||||
, base64md5
|
||||
@ -155,6 +156,25 @@ getFileListPieces = flip go id
|
||||
staticFiles :: Prelude.FilePath -> Q [Dec]
|
||||
staticFiles dir = mkStaticFiles dir
|
||||
|
||||
-- | Same as 'staticFiles', but takes an explicit list of files to create
|
||||
-- identifiers for. The files are given relative to the static folder. For
|
||||
-- example, to get the files \"static/js/jquery.js\" and
|
||||
-- \"static/css/normalize.css\", you would use:
|
||||
--
|
||||
-- > staticFilesList "static" ["js/jquery.js"], ["css/normalize.css"]]
|
||||
--
|
||||
-- This can be useful when you have a very large number of static files, but
|
||||
-- only need to refer to a few of them from Haskell.
|
||||
staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]
|
||||
staticFilesList dir fs =
|
||||
mkStaticFilesList dir (map split fs) "StaticRoute" True
|
||||
where
|
||||
split :: Prelude.FilePath -> [String]
|
||||
split [] = []
|
||||
split x =
|
||||
let (a, b) = break (== '/') x
|
||||
in a : split (drop 1 b)
|
||||
|
||||
-- | like staticFiles, but doesn't append an etag to the query string
|
||||
-- This will compile faster, but doesn't achieve as great of caching.
|
||||
-- The browser can avoid downloading the file, but it always needs to send a request with the etag value or the last-modified value to the server to see if its copy is up to dat
|
||||
@ -212,6 +232,15 @@ mkStaticFiles' :: Prelude.FilePath -- ^ static directory
|
||||
-> Q [Dec]
|
||||
mkStaticFiles' fp routeConName makeHash = do
|
||||
fs <- qRunIO $ getFileListPieces fp
|
||||
mkStaticFilesList fp fs routeConName makeHash
|
||||
|
||||
mkStaticFilesList
|
||||
:: Prelude.FilePath -- ^ static directory
|
||||
-> [[String]] -- ^ list of files to create identifiers for
|
||||
-> String -- ^ route constructor "StaticRoute"
|
||||
-> Bool -- ^ append checksum query parameter
|
||||
-> Q [Dec]
|
||||
mkStaticFilesList fp fs routeConName makeHash = do
|
||||
concat `fmap` mapM mkRoute fs
|
||||
where
|
||||
replace' c
|
||||
@ -233,7 +262,6 @@ mkStaticFiles' fp routeConName makeHash = do
|
||||
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
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-static
|
||||
version: 0.3.0.1
|
||||
version: 0.3.1
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
|
||||
@ -66,8 +66,8 @@ devel isDevel = do
|
||||
checkCabalFile gpd
|
||||
|
||||
_ <- if isDevel
|
||||
then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel"]
|
||||
else rawSystem "cabal" ["configure", "-fdevel"]
|
||||
then rawSystem "cabal-dev" ["configure", "--cabal-install-arg=-fdevel", "--disable-library-profiling"]
|
||||
else rawSystem "cabal" ["configure", "-fdevel", "--disable-library-profiling"]
|
||||
|
||||
T.writeFile "dist/devel.hs" (develFile pid)
|
||||
|
||||
|
||||
@ -94,10 +94,6 @@ scaffold = do
|
||||
MongoDB -> $(codegen $ "mongoDBConnPool")
|
||||
Tiny -> ""
|
||||
|
||||
settingsTextImport = case backend of
|
||||
Postgresql -> "import Data.Text (Text, pack, concat)\nimport Prelude hiding (concat)"
|
||||
_ -> "import Data.Text (Text, pack)"
|
||||
|
||||
packages =
|
||||
if backend == MongoDB
|
||||
then " , persistent-mongoDB >= 0.6.1 && < 0.7\n , mongoDB >= 1.1\n , bson >= 0.1.5\n"
|
||||
@ -124,6 +120,7 @@ scaffold = do
|
||||
mkDir "Model"
|
||||
mkDir "deploy"
|
||||
mkDir "Settings"
|
||||
mkDir "messages"
|
||||
|
||||
writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile")
|
||||
|
||||
@ -143,24 +140,25 @@ scaffold = do
|
||||
writeFile' "LICENSE" $(codegen "LICENSE")
|
||||
writeFile' ("Foundation.hs") $ ifTiny $(codegen "tiny/Foundation.hs") $(codegen "Foundation.hs")
|
||||
writeFile' "Application.hs" $ ifTiny $(codegen "tiny/Application.hs") $(codegen "Application.hs")
|
||||
writeFile' "Handler/Root.hs" $ ifTiny $(codegen "tiny/Handler/Root.hs") $(codegen "Handler/Root.hs")
|
||||
writeFile' "Handler/Root.hs" $(codegen "Handler/Root.hs")
|
||||
unless isTiny $ writeFile' "Model.hs" $(codegen "Model.hs")
|
||||
writeFile' "Settings.hs" $ ifTiny $(codegen "tiny/Settings.hs") $(codegen "Settings.hs")
|
||||
writeFile' "Settings/StaticFiles.hs" $(codegen "Settings/StaticFiles.hs")
|
||||
writeFile' "cassius/default-layout.cassius"
|
||||
$(codegen "cassius/default-layout.cassius")
|
||||
writeFile' "lucius/default-layout.lucius"
|
||||
$(codegen "lucius/default-layout.lucius")
|
||||
writeFile' "hamlet/default-layout.hamlet"
|
||||
$(codegen "hamlet/default-layout.hamlet")
|
||||
writeFile' "hamlet/boilerplate-layout.hamlet"
|
||||
$(codegen "hamlet/boilerplate-layout.hamlet")
|
||||
writeFile' "static/css/normalize.css"
|
||||
$(codegen "static/css/normalize.css")
|
||||
writeFile' "hamlet/homepage.hamlet" $ ifTiny $(codegen "tiny/hamlet/homepage.hamlet") $(codegen "hamlet/homepage.hamlet")
|
||||
writeFile' "lucius/normalize.lucius"
|
||||
$(codegen "lucius/normalize.lucius")
|
||||
writeFile' "hamlet/homepage.hamlet" $(codegen "hamlet/homepage.hamlet")
|
||||
writeFile' "config/routes" $ ifTiny $(codegen "tiny/config/routes") $(codegen "config/routes")
|
||||
writeFile' "cassius/homepage.cassius" $(codegen "cassius/homepage.cassius")
|
||||
writeFile' "lucius/homepage.lucius" $(codegen "lucius/homepage.lucius")
|
||||
writeFile' "julius/homepage.julius" $(codegen "julius/homepage.julius")
|
||||
unless isTiny $ writeFile' "config/models" $(codegen "config/models")
|
||||
|
||||
writeFile' "messages/en.msg" $(codegen "messages/en.msg")
|
||||
|
||||
S.writeFile (dir ++ "/config/favicon.ico")
|
||||
$(runIO (S.readFile "scaffold/config/favicon.ico.cg") >>= \bs -> do
|
||||
pack <- [|S.pack|]
|
||||
|
||||
@ -12,11 +12,12 @@ import Foundation
|
||||
import Settings
|
||||
import Settings.StaticFiles (static)
|
||||
import Yesod.Auth
|
||||
import Yesod.Logger (makeLogger, flushLogger, Logger, logString, logLazyText)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main
|
||||
import Yesod.Logger (Logger)
|
||||
import Database.Persist.~importGenericDB~
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Dynamic (Dynamic, toDyn)
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
|
||||
#ifndef WINDOWS
|
||||
import qualified System.Posix.Signals as Signal
|
||||
@ -44,7 +45,7 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
with~sitearg~ :: AppConfig -> Logger -> (Application -> IO a) -> IO ()
|
||||
with~sitearg~ :: AppConfig DefaultEnv -> Logger -> (Application -> IO a) -> IO ()
|
||||
with~sitearg~ conf logger f = do
|
||||
s <- static Settings.staticDir
|
||||
Settings.withConnectionPool conf $ \p -> do~runMigration~
|
||||
@ -63,16 +64,4 @@ with~sitearg~ conf logger f = do
|
||||
|
||||
-- for yesod devel
|
||||
withDevelAppPort :: Dynamic
|
||||
withDevelAppPort =
|
||||
toDyn go
|
||||
where
|
||||
go :: ((Int, Application) -> IO ()) -> IO ()
|
||||
go f = do
|
||||
conf <- Settings.loadConfig Settings.Development
|
||||
let port = appPort conf
|
||||
logger <- makeLogger
|
||||
logString logger $ "Devel application launched, listening on port " ++ show port
|
||||
with~sitearg~ conf logger $ \app -> f (port, debugHandle (logHandle logger) app)
|
||||
flushLogger logger
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
module Foundation
|
||||
( ~sitearg~ (..)
|
||||
, ~sitearg~Route (..)
|
||||
, ~sitearg~Message (..)
|
||||
, resources~sitearg~
|
||||
, Handler
|
||||
, Widget
|
||||
@ -22,19 +23,19 @@ import Settings.StaticFiles
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.OpenId
|
||||
import Yesod.Auth.Email
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Logger (Logger, logLazyText)
|
||||
import qualified Settings
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Database.Persist.~importGenericDB~
|
||||
import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
|
||||
import Model
|
||||
import Data.Maybe (isJust)
|
||||
import Control.Monad (join, unless)
|
||||
import Control.Monad (join)
|
||||
import Network.Mail.Mime
|
||||
import qualified Data.Text.Lazy.Encoding
|
||||
import Text.Jasmine (minifym)
|
||||
import qualified Data.Text as T
|
||||
import Web.ClientSession (getKey)
|
||||
import Text.Blaze.Renderer.Utf8 (renderHtml)
|
||||
import Text.Hamlet (shamlet)
|
||||
@ -45,12 +46,15 @@ import Text.Shakespeare.Text (stext)
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ settings :: Settings.AppConfig
|
||||
{ settings :: AppConfig DefaultEnv
|
||||
, getLogger :: Logger
|
||||
, getStatic :: Static -- ^ Settings for static file serving.
|
||||
, connPool :: Settings.ConnectionPool -- ^ Database connection pool.
|
||||
}
|
||||
|
||||
-- Set up i18n messages. See the message folder.
|
||||
mkMessage "~sitearg~" "messages" "en"
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
-- http://www.yesodweb.com/book/handler
|
||||
@ -75,7 +79,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes")
|
||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
||||
-- of settings which can be configured by overriding methods here.
|
||||
instance Yesod ~sitearg~ where
|
||||
approot = Settings.appRoot . settings
|
||||
approot = appRoot . settings
|
||||
|
||||
-- Place the session key file in the config folder
|
||||
encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
|
||||
@ -84,7 +88,8 @@ instance Yesod ~sitearg~ where
|
||||
mmsg <- getMessage
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
addCassius $(cassiusFile "default-layout")
|
||||
toWidget $(luciusFile "normalize")
|
||||
toWidget $(luciusFile "default-layout")
|
||||
hamletToRepHtml $(hamletFile "default-layout")
|
||||
|
||||
-- This is done to provide an optimization for serving static files from
|
||||
@ -103,21 +108,7 @@ instance Yesod ~sitearg~ where
|
||||
-- and names them based on a hash of their content. This allows
|
||||
-- expiration dates to be set far in the future without worry of
|
||||
-- users receiving stale content.
|
||||
addStaticContent ext' _ content = do
|
||||
let fn = base64md5 content ++ '.' : T.unpack ext'
|
||||
let content' =
|
||||
if ext' == "js"
|
||||
then case minifym content of
|
||||
Left _ -> content
|
||||
Right y -> y
|
||||
else content
|
||||
let statictmp = Settings.staticDir ++ "/tmp/"
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
let fn' = statictmp ++ fn
|
||||
exists <- liftIO $ doesFileExist fn'
|
||||
unless exists $ liftIO $ L.writeFile fn' content'
|
||||
return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
|
||||
|
||||
addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist ~sitearg~ where
|
||||
|
||||
@ -12,7 +12,6 @@ import Foundation
|
||||
-- inclined, or create a single monolithic file.
|
||||
getRootR :: Handler RepHtml
|
||||
getRootR = do
|
||||
mu <- maybeAuth
|
||||
defaultLayout $ do
|
||||
h2id <- lift newIdent
|
||||
setTitle "~project~ homepage"
|
||||
|
||||
@ -18,9 +18,6 @@ module Settings
|
||||
, runConnectionPool
|
||||
, staticRoot
|
||||
, staticDir
|
||||
, loadConfig
|
||||
, AppEnvironment(..)
|
||||
, AppConfig(..)
|
||||
) where
|
||||
|
||||
import qualified Text.Hamlet as S
|
||||
@ -32,75 +29,11 @@ import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Database.Persist.~importPersist~
|
||||
import Yesod (liftIO, MonadControlIO, addWidget, addCassius, addJulius, addLucius, whamletFile)
|
||||
import Yesod.Default.Config
|
||||
import Data.Monoid (mempty)
|
||||
import System.Directory (doesFileExist)
|
||||
~settingsTextImport~
|
||||
import Data.Object
|
||||
import qualified Data.Object.Yaml as YAML
|
||||
import Control.Monad (join)
|
||||
import Data.Text (Text)
|
||||
|
||||
data AppEnvironment = Test
|
||||
| Development
|
||||
| Staging
|
||||
| Production
|
||||
deriving (Eq, Show, Read, Enum, Bounded)
|
||||
|
||||
-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
|
||||
-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
|
||||
--
|
||||
-- By convention these settings should be overwritten by any command line arguments.
|
||||
-- See config/Foundation.hs for command line arguments
|
||||
-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
|
||||
--
|
||||
data AppConfig = AppConfig {
|
||||
appEnv :: AppEnvironment
|
||||
|
||||
, appPort :: Int
|
||||
|
||||
-- | Your application will keep a connection pool and take connections from
|
||||
-- there as necessary instead of continually creating new connections. This
|
||||
-- value gives the maximum number of connections to be open at a given time.
|
||||
-- If your application requests a connection when all connections are in
|
||||
-- use, that request will fail. Try to choose a number that will work well
|
||||
-- with the system resources available to you while providing enough
|
||||
-- connections for your expected load.
|
||||
--
|
||||
-- Connections are returned to the pool as quickly as possible by
|
||||
-- Yesod to avoid resource exhaustion. A connection is only considered in
|
||||
-- use while within a call to runDB.
|
||||
, connectionPoolSize :: Int
|
||||
|
||||
-- | The base URL for your application. This will usually be different for
|
||||
-- development and production. Yesod automatically constructs URLs for you,
|
||||
-- so this value must be accurate to create valid links.
|
||||
-- Please note that there is no trailing slash.
|
||||
--
|
||||
-- You probably want to change this! If your domain name was "yesod.com",
|
||||
-- you would probably want it to be:
|
||||
-- > "http://yesod.com"
|
||||
, appRoot :: Text
|
||||
} deriving (Show)
|
||||
|
||||
loadConfig :: AppEnvironment -> IO AppConfig
|
||||
loadConfig env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
hostS <- lookupScalar "host" settings
|
||||
port <- fmap read $ lookupScalar "port" settings
|
||||
connectionPoolSizeS <- lookupScalar "connectionPoolSize" settings
|
||||
return $ AppConfig {
|
||||
appEnv = env
|
||||
, appPort = port
|
||||
, appRoot = pack $ hostS ++ addPort port
|
||||
, connectionPoolSize = read connectionPoolSizeS
|
||||
}
|
||||
where
|
||||
addPort :: Int -> String
|
||||
#ifdef PRODUCTION
|
||||
addPort _ = ""
|
||||
#else
|
||||
addPort p = ":" ++ (show p)
|
||||
#endif
|
||||
|
||||
-- Static setting below. Changing these requires a recompile
|
||||
|
||||
@ -122,7 +55,7 @@ staticDir = "static"
|
||||
-- have to make a corresponding change here.
|
||||
--
|
||||
-- To see how this value is used, see urlRenderOverride in Foundation.hs
|
||||
staticRoot :: AppConfig -> Text
|
||||
staticRoot :: AppConfig DefaultEnv -> Text
|
||||
staticRoot conf = [st|#{appRoot conf}/static|]
|
||||
|
||||
|
||||
|
||||
@ -1,3 +0,0 @@
|
||||
body
|
||||
font-family: sans-serif
|
||||
|
||||
@ -4,6 +4,7 @@ Default: &defaults
|
||||
host: localhost
|
||||
port: 27017
|
||||
database: ~project~
|
||||
poolsize: 10
|
||||
|
||||
Development:
|
||||
<<: *defaults
|
||||
@ -14,8 +15,10 @@ Test:
|
||||
|
||||
Staging:
|
||||
database: ~project~_staging
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
Production:
|
||||
database: ~project~_production
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
@ -4,6 +4,7 @@ Default: &defaults
|
||||
host: localhost
|
||||
port: 5432
|
||||
database: ~project~
|
||||
poolsize: 10
|
||||
|
||||
Development:
|
||||
<<: *defaults
|
||||
@ -14,7 +15,10 @@ Test:
|
||||
|
||||
Staging:
|
||||
database: ~project~_staging
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
Production:
|
||||
database: ~project~_production
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
Default: &defaults
|
||||
host: "http://localhost"
|
||||
host: "localhost"
|
||||
port: 3000
|
||||
connectionPoolSize: 10
|
||||
|
||||
Development:
|
||||
<<: *defaults
|
||||
@ -13,4 +12,5 @@ Staging:
|
||||
<<: *defaults
|
||||
|
||||
Production:
|
||||
approot: "http://www.example.com"
|
||||
<<: *defaults
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
Default: &defaults
|
||||
database: ~project~.sqlite3
|
||||
poolsize: 10
|
||||
|
||||
Development:
|
||||
<<: *defaults
|
||||
@ -10,8 +11,10 @@ Test:
|
||||
|
||||
Staging:
|
||||
database: ~project~_staging.sqlite3
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
Production:
|
||||
database: ~project~_production.sqlite3
|
||||
poolsize: 100
|
||||
<<: *defaults
|
||||
|
||||
@ -15,7 +15,6 @@
|
||||
|
||||
<title>#{pageTitle pc}
|
||||
|
||||
<link rel="stylesheet" href=@{StaticR css_normalize_css}>
|
||||
^{pageHead pc}
|
||||
|
||||
<!--[if lt IE 9]>
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
<html
|
||||
<head
|
||||
<title>#{pageTitle pc}
|
||||
<link rel="stylesheet" href=@{StaticR css_normalize_css}>
|
||||
^{pageHead pc}
|
||||
<body
|
||||
$maybe msg <- mmsg
|
||||
|
||||
@ -1,13 +1,2 @@
|
||||
<h1>Hello
|
||||
<h1>_{MsgHello}
|
||||
<h2 ##{h2id}>You do not have Javascript enabled.
|
||||
$maybe u <- mu
|
||||
<p
|
||||
You are logged in as #{userIdent $ snd u}. #
|
||||
<a href=@{AuthR LogoutR}>Logout
|
||||
.
|
||||
$nothing
|
||||
<p
|
||||
You are not logged in. #
|
||||
<a href=@{AuthR LoginR}>Login now
|
||||
.
|
||||
|
||||
|
||||
4
yesod/scaffold/lucius/default-layout.lucius.cg
Normal file
4
yesod/scaffold/lucius/default-layout.lucius.cg
Normal file
@ -0,0 +1,4 @@
|
||||
body {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
h1
|
||||
h1 {
|
||||
text-align: center
|
||||
h2##{h2id}
|
||||
}
|
||||
h2##{h2id} {
|
||||
color: #990
|
||||
}
|
||||
|
||||
@ -1,68 +1,6 @@
|
||||
{-# LANGUAGE CPP, DeriveDataTypeable #-}
|
||||
import Settings (AppEnvironment(..), AppConfig(..), loadConfig)
|
||||
import Application (with~sitearg~)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import System.Console.CmdArgs hiding (args)
|
||||
import Data.Char (toUpper, toLower)
|
||||
|
||||
#ifndef PRODUCTION
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
import Yesod.Logger (logString, logLazyText, flushLogger, makeLogger)
|
||||
#else
|
||||
import Yesod.Logger (makeLogger)
|
||||
#endif
|
||||
import Yesod.Default.Config (fromArgs)
|
||||
import Yesod.Default.Main (defaultMain)
|
||||
import Application (with~sitearg~)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
logger <- makeLogger
|
||||
args <- cmdArgs argConfig
|
||||
env <- getAppEnv args
|
||||
config <- loadConfig env
|
||||
let c = if port args /= 0
|
||||
then config { appPort = port args }
|
||||
else config
|
||||
|
||||
#if PRODUCTION
|
||||
with~sitearg~ c logger $ run (appPort c)
|
||||
#else
|
||||
logString logger $ (show env) ++ " application launched, listening on port " ++ show (appPort c)
|
||||
with~sitearg~ c logger $ run (appPort c) . debugHandle (logHandle logger)
|
||||
flushLogger logger
|
||||
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
#endif
|
||||
|
||||
data ArgConfig = ArgConfig
|
||||
{ environment :: String
|
||||
, port :: Int
|
||||
} deriving (Show, Data, Typeable)
|
||||
|
||||
argConfig :: ArgConfig
|
||||
argConfig = ArgConfig
|
||||
{ environment = def
|
||||
&= help ("application environment, one of: " ++ (foldl1 (\a b -> a ++ ", " ++ b) environments))
|
||||
&= typ "ENVIRONMENT"
|
||||
, port = def
|
||||
&= typ "PORT"
|
||||
}
|
||||
|
||||
environments :: [String]
|
||||
environments = map ((map toLower) . show) ([minBound..maxBound] :: [AppEnvironment])
|
||||
|
||||
-- | retrieve the -e environment option
|
||||
getAppEnv :: ArgConfig -> IO AppEnvironment
|
||||
getAppEnv cfg = do
|
||||
let e = if environment cfg /= ""
|
||||
then environment cfg
|
||||
else
|
||||
#if PRODUCTION
|
||||
"production"
|
||||
#else
|
||||
"development"
|
||||
#endif
|
||||
return $ read $ capitalize e
|
||||
|
||||
where
|
||||
capitalize [] = []
|
||||
capitalize (x:xs) = toUpper x : map toLower xs
|
||||
main = defaultMain fromArgs with~sitearg~
|
||||
|
||||
1
yesod/scaffold/messages/en.msg.cg
Normal file
1
yesod/scaffold/messages/en.msg.cg
Normal file
@ -0,0 +1 @@
|
||||
Hello: Hello
|
||||
@ -1,16 +1,8 @@
|
||||
runConnectionPool :: MonadControlIO m => Action m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runMongoDBConn (ConfirmWrites [u"j" =: True])
|
||||
|
||||
withConnectionPool :: (MonadControlIO m, Applicative m) => AppConfig -> (ConnectionPool -> m b) -> m b
|
||||
withConnectionPool :: (MonadControlIO m, Applicative m) => AppConfig DefaultEnv -> (ConnectionPool -> m b) -> m b
|
||||
withConnectionPool conf f = do
|
||||
(database,host) <- liftIO $ loadConnParams (appEnv conf)
|
||||
withMongoDBPool (u database) host (connectionPoolSize conf) f
|
||||
where
|
||||
-- | The database connection parameters.
|
||||
-- loadConnParams :: AppEnvironment -> IO (Database, HostName)
|
||||
loadConnParams env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/mongoDB.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
database <- lookupScalar "database" settings
|
||||
host <- lookupScalar "host" settings
|
||||
return (database, host)
|
||||
dbConf <- liftIO $ loadMongo (appEnv conf)
|
||||
withMongoDBPool (u $ mgDatabase dbConf) (mgHost dbConf) (mgPoolSize dbConf) f
|
||||
|
||||
|
||||
@ -1,23 +1,10 @@
|
||||
runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
|
||||
withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool :: MonadControlIO m => AppConfig DefaultEnv -> (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool conf f = do
|
||||
cs <- liftIO $ loadConnStr (appEnv conf)
|
||||
with~upper~Pool cs (connectionPoolSize conf) f
|
||||
where
|
||||
-- | The database connection string. The meaning of this string is backend-
|
||||
-- specific.
|
||||
loadConnStr :: AppEnvironment -> IO Text
|
||||
loadConnStr env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/~backendLower~.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
database <- lookupScalar "database" settings :: IO Text
|
||||
|
||||
connPart <- fmap concat $ (flip mapM) ["user", "password", "host", "port"] $ \key -> do
|
||||
value <- lookupScalar key settings
|
||||
return $ [st| #{key}=#{value} |]
|
||||
return $ [st|#{connPart} dbname=#{database}|]
|
||||
dbConf <- liftIO $ load~upper~ (appEnv conf)
|
||||
with~upper~Pool (pgConnStr dbConf) (pgPoolSize dbConf) f
|
||||
|
||||
-- Example of making a dynamic configuration static
|
||||
-- use /return $(mkConnStr Production)/ instead of loadConnStr
|
||||
|
||||
@ -37,6 +37,8 @@ library
|
||||
Settings.StaticFiles
|
||||
Handler.Root
|
||||
|
||||
ghc-options: -Wall -threaded -O0
|
||||
|
||||
executable ~project~
|
||||
if flag(devel)
|
||||
Buildable: False
|
||||
@ -45,7 +47,7 @@ executable ~project~
|
||||
cpp-options: -DPRODUCTION
|
||||
ghc-options: -Wall -threaded -O2
|
||||
else
|
||||
ghc-options: -Wall -threaded
|
||||
ghc-options: -Wall -threaded -O0
|
||||
|
||||
if os(windows)
|
||||
cpp-options: -DWINDOWS
|
||||
@ -58,6 +60,7 @@ executable ~project~
|
||||
, yesod-core
|
||||
, yesod-auth
|
||||
, yesod-static
|
||||
, yesod-default
|
||||
, blaze-html
|
||||
, yesod-form
|
||||
, mime-mail
|
||||
|
||||
@ -1,18 +1,10 @@
|
||||
runConnectionPool :: MonadControlIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
|
||||
withConnectionPool :: MonadControlIO m => AppConfig -> (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool :: MonadControlIO m => AppConfig DefaultEnv -> (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool conf f = do
|
||||
cs <- liftIO $ loadConnStr (appEnv conf)
|
||||
with~upper~Pool cs (connectionPoolSize conf) f
|
||||
where
|
||||
-- | The database connection string. The meaning of this string is backend-
|
||||
-- specific.
|
||||
loadConnStr :: AppEnvironment -> IO Text
|
||||
loadConnStr env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/~backendLower~.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
lookupScalar "database" settings
|
||||
dbConf <- liftIO $ load~upper~ (appEnv conf)
|
||||
with~upper~Pool (sqlDatabase dbConf) (sqlPoolSize dbConf) f
|
||||
|
||||
-- Example of making a dynamic configuration static
|
||||
-- use /return $(mkConnStr Production)/ instead of loadConnStr
|
||||
|
||||
@ -11,11 +11,12 @@ module Application
|
||||
import Foundation
|
||||
import Settings
|
||||
import Yesod.Static
|
||||
import Yesod.Logger (makeLogger, flushLogger, Logger, logLazyText, logString)
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Main (defaultDevelApp)
|
||||
import Yesod.Logger (Logger)
|
||||
import Data.ByteString (ByteString)
|
||||
import Network.Wai (Application)
|
||||
import Data.Dynamic (Dynamic, toDyn)
|
||||
import Network.Wai.Middleware.Debug (debugHandle)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
import Handler.Root
|
||||
@ -37,7 +38,7 @@ getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString)
|
||||
-- performs initialization and creates a WAI application. This is also the
|
||||
-- place to put your migrate statements to have automatic database
|
||||
-- migrations handled by Yesod.
|
||||
with~sitearg~ :: AppConfig -> Logger -> (Application -> IO a) -> IO a
|
||||
with~sitearg~ :: AppConfig DefaultEnv -> Logger -> (Application -> IO a) -> IO a
|
||||
with~sitearg~ conf logger f = do
|
||||
#ifdef PRODUCTION
|
||||
s <- static Settings.staticDir
|
||||
@ -49,16 +50,4 @@ with~sitearg~ conf logger f = do
|
||||
|
||||
-- for yesod devel
|
||||
withDevelAppPort :: Dynamic
|
||||
withDevelAppPort =
|
||||
toDyn go
|
||||
where
|
||||
go :: ((Int, Application) -> IO ()) -> IO ()
|
||||
go f = do
|
||||
conf <- Settings.loadConfig Settings.Development
|
||||
let port = appPort conf
|
||||
logger <- makeLogger
|
||||
logString logger $ "Devel application launched, listening on port " ++ show port
|
||||
with~sitearg~ conf logger $ \app -> f (port, debugHandle (logHandle logger) app)
|
||||
flushLogger logger
|
||||
where
|
||||
logHandle logger msg = logLazyText logger msg >> flushLogger logger
|
||||
withDevelAppPort = toDyn $ defaultDevelApp with~sitearg~
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
|
||||
module Foundation
|
||||
( ~sitearg~ (..)
|
||||
, ~sitearg~Route (..)
|
||||
, ~sitearg~Message (..)
|
||||
, resources~sitearg~
|
||||
, Handler
|
||||
, Widget
|
||||
@ -14,17 +15,15 @@ module Foundation
|
||||
) where
|
||||
|
||||
import Yesod.Core
|
||||
import Yesod.Default.Config
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Static (Static, base64md5, StaticRoute(..))
|
||||
import Settings.StaticFiles
|
||||
import Yesod.Logger (Logger, logLazyText)
|
||||
import qualified Settings
|
||||
import System.Directory
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Settings (hamletFile, cassiusFile, luciusFile, juliusFile, widgetFile)
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Text as T
|
||||
import Web.ClientSession (getKey)
|
||||
|
||||
-- | The site argument for your application. This can be a good place to
|
||||
@ -32,11 +31,14 @@ import Web.ClientSession (getKey)
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
-- access to the data present here.
|
||||
data ~sitearg~ = ~sitearg~
|
||||
{ settings :: Settings.AppConfig
|
||||
{ settings :: AppConfig DefaultEnv
|
||||
, getLogger :: Logger
|
||||
, getStatic :: Static -- ^ Settings for static file serving.
|
||||
}
|
||||
|
||||
-- Set up i18n messages. See the message folder.
|
||||
mkMessage "~sitearg~" "messages" "en"
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
-- http://docs.yesodweb.com/book/web-routes-quasi/
|
||||
@ -61,7 +63,7 @@ mkYesodData "~sitearg~" $(parseRoutesFile "config/routes")
|
||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
||||
-- of settings which can be configured by overriding methods here.
|
||||
instance Yesod ~sitearg~ where
|
||||
approot = Settings.appRoot . settings
|
||||
approot = appRoot . settings
|
||||
|
||||
-- Place the session key file in the config folder
|
||||
encryptKey _ = fmap Just $ getKey "config/client_session_key.aes"
|
||||
@ -70,7 +72,8 @@ instance Yesod ~sitearg~ where
|
||||
mmsg <- getMessage
|
||||
pc <- widgetToPageContent $ do
|
||||
widget
|
||||
addCassius $(cassiusFile "default-layout")
|
||||
toWidget $(luciusFile "normalize")
|
||||
toWidget $(luciusFile "default-layout")
|
||||
hamletToRepHtml $(hamletFile "default-layout")
|
||||
|
||||
-- This is done to provide an optimization for serving static files from
|
||||
@ -86,11 +89,4 @@ instance Yesod ~sitearg~ where
|
||||
-- and names them based on a hash of their content. This allows
|
||||
-- expiration dates to be set far in the future without worry of
|
||||
-- users receiving stale content.
|
||||
addStaticContent ext' _ content = do
|
||||
let fn = base64md5 content ++ '.' : T.unpack ext'
|
||||
let statictmp = Settings.staticDir ++ "/tmp/"
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
let fn' = statictmp ++ fn
|
||||
exists <- liftIO $ doesFileExist fn'
|
||||
unless exists $ liftIO $ L.writeFile fn' content
|
||||
return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], [])
|
||||
addStaticContent = addStaticContentExternal (const $ Left ()) base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
|
||||
|
||||
@ -1,18 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
|
||||
module Handler.Root where
|
||||
|
||||
import Foundation
|
||||
|
||||
-- This is a handler function for the GET request method on the RootR
|
||||
-- resource pattern. All of your resource patterns are defined in
|
||||
-- config/routes
|
||||
--
|
||||
-- The majority of the code you will write in Yesod lives in these handler
|
||||
-- functions. You can spread them across multiple files if you are so
|
||||
-- inclined, or create a single monolithic file.
|
||||
getRootR :: Handler RepHtml
|
||||
getRootR = do
|
||||
defaultLayout $ do
|
||||
h2id <- lift newIdent
|
||||
setTitle "~project~ homepage"
|
||||
addWidget $(widgetFile "homepage")
|
||||
@ -14,9 +14,6 @@ module Settings
|
||||
, widgetFile
|
||||
, staticRoot
|
||||
, staticDir
|
||||
, loadConfig
|
||||
, AppEnvironment(..)
|
||||
, AppConfig(..)
|
||||
) where
|
||||
|
||||
import qualified Text.Hamlet as S
|
||||
@ -27,60 +24,10 @@ import qualified Text.Shakespeare.Text as S
|
||||
import Text.Shakespeare.Text (st)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Yesod.Widget (addWidget, addCassius, addJulius, addLucius, whamletFile)
|
||||
import Yesod.Default.Config
|
||||
import Data.Monoid (mempty)
|
||||
import System.Directory (doesFileExist)
|
||||
~settingsTextImport~
|
||||
import Data.Object
|
||||
import qualified Data.Object.Yaml as YAML
|
||||
import Control.Monad (join)
|
||||
|
||||
data AppEnvironment = Test
|
||||
| Development
|
||||
| Staging
|
||||
| Production
|
||||
deriving (Eq, Show, Read, Enum, Bounded)
|
||||
|
||||
-- | Dynamic per-environment configuration loaded from the YAML file Settings.yaml.
|
||||
-- Use dynamic settings to avoid the need to re-compile the application (between staging and production environments).
|
||||
--
|
||||
-- By convention these settings should be overwritten by any command line arguments.
|
||||
-- See config/~sitearg~.hs for command line arguments
|
||||
-- Command line arguments provide some convenience but are also required for hosting situations where a setting is read from the environment (appPort on Heroku).
|
||||
--
|
||||
data AppConfig = AppConfig {
|
||||
appEnv :: AppEnvironment
|
||||
|
||||
, appPort :: Int
|
||||
|
||||
-- | The base URL for your application. This will usually be different for
|
||||
-- development and production. Yesod automatically constructs URLs for you,
|
||||
-- so this value must be accurate to create valid links.
|
||||
-- Please note that there is no trailing slash.
|
||||
--
|
||||
-- You probably want to change this! If your domain name was "yesod.com",
|
||||
-- you would probably want it to be:
|
||||
-- > "http://yesod.com"
|
||||
, appRoot :: Text
|
||||
} deriving (Show)
|
||||
|
||||
loadConfig :: AppEnvironment -> IO AppConfig
|
||||
loadConfig env = do
|
||||
allSettings <- (join $ YAML.decodeFile ("config/settings.yml" :: String)) >>= fromMapping
|
||||
settings <- lookupMapping (show env) allSettings
|
||||
hostS <- lookupScalar "host" settings
|
||||
port <- fmap read $ lookupScalar "port" settings
|
||||
return $ AppConfig {
|
||||
appEnv = env
|
||||
, appPort = port
|
||||
, appRoot = pack $ hostS ++ addPort port
|
||||
}
|
||||
where
|
||||
addPort :: Int -> String
|
||||
#ifdef PRODUCTION
|
||||
addPort _ = ""
|
||||
#else
|
||||
addPort p = ":" ++ (show p)
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | The location of static files on your system. This is a file system
|
||||
-- path. The default value works properly with your scaffolded site.
|
||||
@ -100,7 +47,7 @@ staticDir = "static"
|
||||
-- have to make a corresponding change here.
|
||||
--
|
||||
-- To see how this value is used, see urlRenderOverride in ~project~.hs
|
||||
staticRoot :: AppConfig -> Text
|
||||
staticRoot :: AppConfig DefaultEnv -> Text
|
||||
staticRoot conf = [st|#{appRoot conf}/static|]
|
||||
|
||||
-- The rest of this file contains settings which rarely need changing by a
|
||||
|
||||
@ -1,2 +0,0 @@
|
||||
<h1>Hello
|
||||
<h2 ##{h2id}>You do not have Javascript enabled.
|
||||
@ -48,6 +48,7 @@ executable ~project~
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 0.9 && < 0.10
|
||||
, yesod-static
|
||||
, yesod-default
|
||||
, clientsession
|
||||
, wai-extra
|
||||
, directory
|
||||
|
||||
@ -17,8 +17,8 @@ homepage: http://www.yesodweb.com/
|
||||
|
||||
extra-source-files:
|
||||
input/*.cg
|
||||
scaffold/cassius/default-layout.cassius.cg
|
||||
scaffold/cassius/homepage.cassius.cg
|
||||
scaffold/lucius/default-layout.lucius.cg
|
||||
scaffold/lucius/homepage.lucius.cg
|
||||
scaffold/Model.hs.cg
|
||||
scaffold/Foundation.hs.cg
|
||||
scaffold/LICENSE.cg
|
||||
@ -26,11 +26,9 @@ extra-source-files:
|
||||
scaffold/tiny/Foundation.hs.cg
|
||||
scaffold/tiny/project.cabal.cg
|
||||
scaffold/tiny/Application.hs.cg
|
||||
scaffold/tiny/hamlet/homepage.hamlet.cg
|
||||
scaffold/tiny/Handler/Root.hs.cg
|
||||
scaffold/tiny/config/routes.cg
|
||||
scaffold/tiny/Settings.hs.cg
|
||||
scaffold/static/css/normalize.css.cg
|
||||
scaffold/lucius/normalize.lucius.cg
|
||||
scaffold/postgresqlConnPool.cg
|
||||
scaffold/sqliteConnPool.cg
|
||||
scaffold/.ghci.cg
|
||||
@ -52,6 +50,7 @@ extra-source-files:
|
||||
scaffold/config/routes.cg
|
||||
scaffold/Settings.hs.cg
|
||||
scaffold/Settings/StaticFiles.hs.cg
|
||||
scaffold/messages/en.msg.cg
|
||||
|
||||
|
||||
flag ghc7
|
||||
|
||||
Loading…
Reference in New Issue
Block a user