diff --git a/Yesod/Default/Config.hs b/Yesod/Default/Config.hs deleted file mode 100644 --- a/Yesod/Default/Config.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -module Yesod.Default.Config - ( DefaultEnv (..) - , fromArgs - , loadDevelopmentConfig - - -- reexport - , AppConfig (..) - , ConfigSettings (..) - , configSettings - , loadConfig - , withYamlEnvironment - ) where - -import Data.Char (toUpper, toLower) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Yaml -import Data.Maybe (fromMaybe) -import qualified Data.HashMap.Strict as M -import System.Environment (getArgs, getProgName, getEnvironment) -import System.Exit (exitFailure) -import Data.Conduit.Network (HostPreference) -import Data.String (fromString) - --- | 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 env = ArgConfig - { environment :: env - , port :: Int - } deriving Show - -parseArgConfig :: (Show env, Read env, Enum env, Bounded env) => IO (ArgConfig env) -parseArgConfig = do - let envs = [minBound..maxBound] - args <- getArgs - (portS, args') <- getPort id args - portI <- - case reads portS of - (i, _):_ -> return i - [] -> error $ "Invalid port value: " ++ show portS - case args' of - [e] -> do - case reads $ capitalize e of - (e', _):_ -> return $ ArgConfig e' portI - [] -> do - () <- error $ "Invalid environment, valid entries are: " ++ show envs - -- next line just provided to force the type of envs - return $ ArgConfig (head envs) 0 - _ -> do - pn <- getProgName - putStrLn $ "Usage: " ++ pn ++ " [--port ]" - putStrLn $ "Valid environments: " ++ show envs - exitFailure - where - getPort front [] = do - env <- getEnvironment - return (fromMaybe "0" $ lookup "PORT" env, front []) - getPort front ("--port":p:rest) = return (p, front rest) - getPort front ("-p":p:rest) = return (p, front rest) - getPort front (arg:rest) = getPort (front . (arg:)) rest - - capitalize [] = [] - capitalize (x:xs) = toUpper x : map toLower xs - --- | Load the app config from command line parameters -fromArgs :: (Read env, Show env, Enum env, Bounded env) - => (env -> Object -> Parser extra) - -> IO (AppConfig env extra) -fromArgs getExtra = do - args <- parseArgConfig - - let env = environment args - - let cs = (configSettings env) - { csParseExtra = getExtra - } - config <- loadConfig cs - - env' <- getEnvironment - let config' = - case lookup "APPROOT" env' of - Nothing -> config - Just ar -> config { appRoot = T.pack ar } - - return $ if port args /= 0 - then config' { appPort = port args } - else config' - --- | Load your development config (when using @'DefaultEnv'@) -loadDevelopmentConfig :: IO (AppConfig DefaultEnv ()) -loadDevelopmentConfig = loadConfig $ configSettings Development - --- | Dynamic per-environment configuration which can be loaded at --- run-time negating the need to recompile between environments. -data AppConfig environment extra = AppConfig - { appEnv :: environment - , appPort :: Int - , appRoot :: Text - , appHost :: HostPreference - , appExtra :: extra - } deriving (Show) - -data ConfigSettings environment extra = ConfigSettings - { - -- | An arbitrary value, used below, to indicate the current running - -- environment. Usually, you will use 'DefaultEnv' for this type. - csEnv :: environment - -- | Load any extra data, to be used by the application. - , csParseExtra :: environment -> Object -> Parser extra - -- | Return the path to the YAML config file. - , csFile :: environment -> IO FilePath - -- | Get the sub-object (if relevant) from the given YAML source which - -- contains the specific settings for the current environment. - , csGetObject :: environment -> Value -> IO Value - } - --- | Default config settings. -configSettings :: Show env => env -> ConfigSettings env () -configSettings env0 = ConfigSettings - { csEnv = env0 - , csParseExtra = \_ _ -> return () - , csFile = \_ -> return "config/settings.yml" - , csGetObject = \env v -> do - envs <- - case v of - Object obj -> return obj - _ -> fail "Expected Object" - let senv = show env - tenv = T.pack senv - maybe - (error $ "Could not find environment: " ++ senv) - return - (M.lookup tenv envs) - } - --- | Load an @'AppConfig'@. --- --- Some examples: --- --- > -- typical local development --- > Development: --- > host: localhost --- > port: 3000 --- > --- > -- approot: will default to "" --- --- > -- typical outward-facing production box --- > Production: --- > host: www.example.com --- > --- > -- port: will default 80 --- > -- host: will default to "*" --- > -- 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" --- > host: "localhost" -loadConfig :: ConfigSettings environment extra - -> IO (AppConfig environment extra) -loadConfig (ConfigSettings env parseExtra getFile getObject) = do - fp <- getFile env - mtopObj <- decodeFile fp - topObj <- maybe (fail "Invalid YAML file") return mtopObj - obj <- getObject env topObj - m <- - case obj of - Object m -> return m - _ -> fail "Expected map" - - let host = fromString $ T.unpack $ fromMaybe "*" $ lookupScalar "host" m - mport <- parseMonad (\x -> x .: "port") m - let approot' = fromMaybe "" $ lookupScalar "approot" m - - -- Handle the DISPLAY_PORT environment variable for yesod devel - approot <- - case T.stripSuffix ":3000" approot' of - Nothing -> return approot' - Just prefix -> do - envVars <- getEnvironment - case lookup "DISPLAY_PORT" envVars of - Nothing -> return approot' - Just p -> return $ prefix `T.append` T.pack (':' : p) - - extra <- parseMonad (parseExtra env) m - - -- set some default arguments - let port' = fromMaybe 80 mport - - return $ AppConfig - { appEnv = env - , appPort = port' - , appRoot = approot - , appHost = host - , appExtra = extra - } - - where - lookupScalar k m = - case M.lookup k m of - Just (String t) -> return t - Just _ -> fail $ "Invalid value for: " ++ show k - Nothing -> fail $ "Not found: " ++ show k - --- | 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 :: Show e - => FilePath -- ^ the yaml file - -> e -- ^ the environment you want to load - -> (Value -> Parser a) -- ^ what to do with the mapping - -> IO a -withYamlEnvironment fp env f = do - mval <- decodeFile fp - case mval of - Nothing -> fail $ "Invalid YAML file: " ++ show fp - Just (Object obj) - | Just v <- M.lookup (T.pack $ show env) obj -> parseMonad f v - _ -> fail $ "Could not find environment: " ++ show env diff --git a/Yesod/Default/Handlers.hs b/Yesod/Default/Handlers.hs deleted file mode 100644 --- a/Yesod/Default/Handlers.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Default.Handlers - ( getFaviconR - , getRobotsR - ) where - -import Yesod.Handler (GHandler, sendFile) -import Yesod.Content (RepPlain(..)) - -getFaviconR :: GHandler s m () -getFaviconR = sendFile "image/x-icon" "config/favicon.ico" - -getRobotsR :: GHandler s m RepPlain -getRobotsR = sendFile "text/plain" "config/robots.txt" diff --git a/Yesod/Default/Ignore.hs b/Yesod/Default/Ignore.hs new file mode 100644 --- /dev/null +++ b/Yesod/Default/Ignore.hs @@ -0,0 +1,1 @@ +module Yesod.Default.Ignore () where diff --git a/Yesod/Default/Main.hs b/Yesod/Default/Main.hs deleted file mode 100644 --- a/Yesod/Default/Main.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Yesod.Default.Main - ( defaultMain - , defaultRunner - , defaultDevelApp - ) where - -import Yesod.Default.Config -import Network.Wai (Application) -import Network.Wai.Handler.Warp - (runSettings, defaultSettings, settingsPort, settingsHost) -import System.Directory (doesDirectoryExist, removeDirectoryRecursive) -import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles, def) -import Network.Wai.Middleware.Autohead (autohead) -import Network.Wai.Middleware.Jsonp (jsonp) -import Control.Monad (when) -import System.Environment (getEnvironment) -import Data.Maybe (fromMaybe) -import Safe (readMay) - -#ifndef WINDOWS -import qualified System.Posix.Signals as Signal -import Control.Concurrent (forkIO, killThread) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -#endif - --- | Run your app, taking environment and port settings from the --- commandline. --- --- @'fromArgs'@ helps parse a custom configuration --- --- > main :: IO () --- > main = defaultMain (fromArgs parseExtra) makeApplication --- -defaultMain :: (Show env, Read env) - => IO (AppConfig env extra) - -> (AppConfig env extra -> IO Application) - -> IO () -defaultMain load getApp = do - config <- load - app <- getApp config - runSettings defaultSettings - { settingsPort = appPort config - , settingsHost = appHost config - } app - --- | Run your application continously, listening for SIGINT and exiting --- when received --- --- > withYourSite :: AppConfig DefaultEnv -> Logger -> (Application -> IO a) -> IO () --- > withYourSite conf logger f = do --- > Settings.withConnectionPool conf $ \p -> do --- > runConnectionPool (runMigration yourMigration) p --- > defaultRunner f $ YourSite conf logger p -defaultRunner :: (Application -> IO ()) -> Application -> IO () -defaultRunner f app = do - -- clear the .static-cache so we don't have stale content - exists <- doesDirectoryExist staticCache - when exists $ removeDirectoryRecursive staticCache -#ifdef WINDOWS - f (middlewares app) -#else - tid <- forkIO $ f (middlewares app) >> return () - flag <- newEmptyMVar - _ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do - putStrLn "Caught an interrupt" - killThread tid - putMVar flag ()) Nothing - takeMVar flag -#endif - where - middlewares = gzip gset . jsonp . autohead - - gset = def { gzipFiles = GzipCacheFolder staticCache } - staticCache = ".static-cache" - --- | Run your development app using a custom environment type and loader --- function -defaultDevelApp - :: (Show env, Read env) - => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@ - -> (AppConfig env extra -> IO Application) -- ^ Get your @Application@ - -> IO (Int, Application) -defaultDevelApp load getApp = do - conf <- load - env <- getEnvironment - let p = fromMaybe (appPort conf) $ lookup "PORT" env >>= readMay - pdisplay = fromMaybe p $ lookup "DISPLAY_PORT" env >>= readMay - putStrLn $ "Devel application launched: http://localhost:" ++ show pdisplay - app <- getApp conf - return (p, app) diff --git a/Yesod/Default/Util.hs b/Yesod/Default/Util.hs deleted file mode 100644 --- a/Yesod/Default/Util.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} --- | Various utilities used in the scaffolded site. -module Yesod.Default.Util - ( addStaticContentExternal - , globFile - , widgetFileNoReload - , widgetFileReload - , TemplateLanguage (..) - , defaultTemplateLanguages - , WidgetFileSettings - , wfsLanguages - , wfsHamletSettings - ) 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 (when, unless) -import System.Directory (doesFileExist, createDirectoryIfMissing) -import Language.Haskell.TH.Syntax -import Text.Lucius (luciusFile, luciusFileReload) -import Text.Julius (juliusFile, juliusFileReload) -import Text.Cassius (cassiusFile, cassiusFileReload) -import Text.Hamlet (HamletSettings, defaultHamletSettings) -import Data.Maybe (catMaybes) -import Data.Default (Default (def)) - --- | 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 - --- | expects a file extension for each type, e.g: hamlet lucius julius -globFile :: String -> String -> FilePath -globFile kind x = "templates/" ++ x ++ "." ++ kind - -data TemplateLanguage = TemplateLanguage - { tlRequiresToWidget :: Bool - , tlExtension :: String - , tlNoReload :: FilePath -> Q Exp - , tlReload :: FilePath -> Q Exp - } - -defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage] -defaultTemplateLanguages hset = - [ TemplateLanguage False "hamlet" whamletFile' whamletFile' - , TemplateLanguage True "cassius" cassiusFile cassiusFileReload - , TemplateLanguage True "julius" juliusFile juliusFileReload - , TemplateLanguage True "lucius" luciusFile luciusFileReload - ] - where - whamletFile' = whamletFileWithSettings hset - -data WidgetFileSettings = WidgetFileSettings - { wfsLanguages :: HamletSettings -> [TemplateLanguage] - , wfsHamletSettings :: HamletSettings - } - -instance Default WidgetFileSettings where - def = WidgetFileSettings defaultTemplateLanguages defaultHamletSettings - -widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp -widgetFileNoReload wfs x = combine "widgetFileNoReload" x False $ wfsLanguages wfs $ wfsHamletSettings wfs - -widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp -widgetFileReload wfs x = combine "widgetFileReload" x True $ wfsLanguages wfs $ wfsHamletSettings wfs - -combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp -combine func file isReload tls = do - mexps <- qmexps - case catMaybes mexps of - [] -> error $ concat - [ "Called " - , func - , " on " - , show file - , ", but no template were found." - ] - exps -> return $ DoE $ map NoBindS exps - where - qmexps :: Q [Maybe Exp] - qmexps = mapM go tls - - go :: TemplateLanguage -> Q (Maybe Exp) - go tl = whenExists file (tlRequiresToWidget tl) (tlExtension tl) ((if isReload then tlReload else tlNoReload) tl) - -whenExists :: String - -> Bool -- ^ requires toWidget wrap - -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp) -whenExists = warnUnlessExists False - -warnUnlessExists :: Bool - -> String - -> Bool -- ^ requires toWidget wrap - -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp) -warnUnlessExists shouldWarn x wrap glob f = do - let fn = globFile glob x - e <- qRunIO $ doesFileExist fn - when (shouldWarn && not e) $ qRunIO $ putStrLn $ "widget file not found: " ++ fn - if e - then do - ex <- f fn - if wrap - then do - tw <- [|toWidget|] - return $ Just $ tw `AppE` ex - else return $ Just ex - else return Nothing diff --git a/yesod-default.cabal b/yesod-default.cabal --- a/yesod-default.cabal +++ b/yesod-default.cabal @@ -1,50 +1,23 @@ name: yesod-default -version: 1.1.3.2 +version: 1.2.0 license: MIT license-file: LICENSE author: Patrick Brisbin maintainer: Patrick Brisbin -synopsis: Default config and main functions for your yesod application +synopsis: Default config and main functions for your yesod application (deprecated) 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 +description: Since version 1.2 of Yesod, this functionality is provided by the yesod package. This package is no longer needed. execution of your yesod application library - if os(windows) - cpp-options: -DWINDOWS - build-depends: base >= 4 && < 5 - , yesod-core >= 1.1 && < 1.2 - , warp >= 1.3 && < 1.4 - , wai >= 1.3 && < 1.5 - , wai-extra >= 1.3 && < 1.4 - , bytestring >= 0.9.1.4 - , transformers >= 0.2.2 && < 0.4 - , text >= 0.9 - , directory >= 1.0 - , shakespeare-css >= 1.0 && < 1.1 - , shakespeare-js >= 1.0 && < 1.2 - , template-haskell - , yaml >= 0.8 && < 0.9 - , network-conduit >= 0.5 - , unordered-containers - , hamlet >= 1.1 && < 1.2 - , data-default - , safe - - if !os(windows) - build-depends: unix - - exposed-modules: Yesod.Default.Config - , Yesod.Default.Main - , Yesod.Default.Util - , Yesod.Default.Handlers + , yesod-core >= 1.2 - ghc-options: -Wall + exposed-modules: Yesod.Default.Ignore source-repository head type: git