diff --git a/Yesod/Config.hs b/Yesod/Config.hs new file mode 100644 --- /dev/null +++ b/Yesod/Config.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Config + ( AppConfig(..) + , loadConfig + , withYamlEnvironment + ) where + +import Control.Monad (join) +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) + +-- | 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 + e <- maybe (fail "Expected map") return $ fromMapping e' + 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 $ T.concat + [ 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 = approot + } + + where + toBool :: Text -> Bool + toBool = (`elem` ["true", "TRUE", "yes", "YES", "Y", "1"]) + + addPort :: Bool -> Int -> Text + addPort True 443 = "" + addPort False 80 = "" + addPort _ p = T.pack $ ':' : show p + +-- | 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 + -> (TextObject -> IO a) -- ^ what to do with the mapping + -> IO a +withYamlEnvironment fp env f = do + obj <- join $ decodeFile fp + envs <- fromMapping obj + conf <- maybe (fail $ "Could not find environment: " ++ show env) return + $ lookup (T.pack $ show env) envs + f conf + +-- | Returns 'fail' if read fails +safeRead :: Monad m => String -> Text -> m Int +safeRead name t = case reads s of + (i, _):_ -> return i + [] -> fail $ concat ["Invalid value for ", name, ": ", s] + where + s = T.unpack t diff --git a/Yesod/Core.hs b/Yesod/Core.hs --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -33,6 +33,7 @@ , module Yesod.Request , module Yesod.Widget , module Yesod.Message + , module Yesod.Config ) where import Yesod.Internal.Core @@ -42,6 +43,7 @@ import Yesod.Request import Yesod.Widget import Yesod.Message +import Yesod.Config import Language.Haskell.TH.Syntax import Data.Text (Text) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -173,10 +173,10 @@ -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes three --- middlewares: GZIP compression, JSON-P and path cleaning. This is the +-- middlewares: GZIP compression, JSON-P and autohead. This is the -- recommended approach for most users. toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application -toWaiApp y = gzip False . jsonp . autohead <$> toWaiAppPlain y +toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This differs from 'toWaiApp' in that it uses no middlewares. diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs --- a/Yesod/Internal/Core.hs +++ b/Yesod/Internal/Core.hs @@ -52,7 +52,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius -import Text.Blaze ((!), customAttribute, textTag, toValue) +import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString) import qualified Text.Blaze.Html5 as TBH import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) @@ -75,6 +75,9 @@ import qualified Data.Text.Lazy.Builder as TB import Language.Haskell.TH.Syntax (Loc (..), Lift (..)) import Text.Blaze (preEscapedLazyText) +import Data.Aeson (Value (Array, String)) +import Data.Aeson.Encode (encode) +import qualified Data.Vector as Vector #if GHC7 #define HAMLET hamlet @@ -205,8 +208,9 @@ where corrected = filter (not . TS.null) s - -- | Join the pieces of a path together into an absolute URL. This should - -- be the inverse of 'splitPath'. + -- | Builds an absolute URL by concatenating the application root with the + -- pieces of a path and a query string, if any. + -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. joinPath :: a -> TS.Text -- ^ application root -> [TS.Text] -- ^ path pieces @@ -259,6 +263,15 @@ formatLogMessage loc level msg >>= Data.Text.Lazy.IO.putStrLn + -- | Apply gzip compression to files. Default is false. + gzipCompressFiles :: a -> Bool + gzipCompressFiles _ = False + + -- | Location of yepnope.js, if any. If one is provided, then all + -- Javascript files will be loaded asynchronously. + yepnopeJs :: a -> Maybe (Either Text (Route a)) + yepnopeJs _ = Nothing + messageLoggerHandler :: (Yesod m, MonadIO mo) => Loc -> LogLevel -> Text -> GGHandler s m mo () messageLoggerHandler loc level msg = do @@ -467,18 +480,22 @@ x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing +jsToHtml :: Javascript -> Html +jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b + +jelper :: JavascriptUrl url -> HtmlUrl url +jelper = fmap jsToHtml + -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route master), Yesod master) => GWidget sub master () -> GHandler sub master (PageContent (Route master)) widgetToPageContent (GWidget w) = do + master <- getYesod ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0 let title = maybe mempty unTitle mTitle let scripts = runUniqueList scripts' let stylesheets = runUniqueList stylesheets' - let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b - jelper :: JavascriptUrl url -> HtmlUrl url - jelper = fmap jsToHtml render <- getUrlRenderParams let renderLoc x = @@ -531,16 +548,54 @@ " + +caseMediaLink :: IO () +caseMediaLink = runner $ do + res <- request defaultRequest { pathInfo = ["static"] } + assertStatus 200 res + flip assertBody res "\n" + +mediaTest :: [Spec] +mediaTest = describe "Test.Media" + [ it "media" caseMedia + , it "media link" caseMediaLink + ] diff --git a/test/Test/NoOverloadedStrings.hs b/test/Test/NoOverloadedStrings.hs new file mode 100644 --- /dev/null +++ b/test/Test/NoOverloadedStrings.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.NoOverloadedStrings (noOverloadedTest, Widget) where + +import Test.Hspec +import Test.Hspec.HUnit () + +import Yesod.Core hiding (Request) +import Network.Wai.Test +import Data.Monoid (mempty) +import Data.String (fromString) + +data Subsite = Subsite + +getSubsite :: a -> Subsite +getSubsite = const Subsite + +mkYesodSub "Subsite" [] [parseRoutes| +/bar BarR GET +|] + +getBarR :: GHandler Subsite m () +getBarR = return () + +data Y = Y +mkYesod "Y" [parseRoutes| +/ RootR GET +/foo FooR GET +/subsite SubsiteR Subsite getSubsite +|] + +instance Yesod Y where + approot _ = fromString "" + +getRootR :: Handler () +getRootR = return () + +getFooR :: Handler () +getFooR = return () + +runner :: Session () -> IO () +runner f = toWaiApp Y >>= runSession f + +case_sanity :: IO () +case_sanity = runner $ do + res <- request defaultRequest + assertBody mempty res + +noOverloadedTest :: [Spec] +noOverloadedTest = describe "Test.NoOverloadedStrings" + [ it "sanity" case_sanity + ] diff --git a/test/Test/Widget.hs b/test/Test/Widget.hs new file mode 100644 --- /dev/null +++ b/test/Test/Widget.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Widget (widgetTest) where + +import Test.Hspec +import Test.Hspec.HUnit () + +import Yesod.Core hiding (Request) +import Text.Julius +import Text.Lucius +import Text.Hamlet + +import Network.Wai +import Network.Wai.Test + +data Y = Y + +mkMessage "Y" "test" "en" + +type Strings = [String] + +mkYesod "Y" [parseRoutes| +/ RootR GET +/foo/*Strings MultiR GET +/whamlet WhamletR GET +/towidget TowidgetR GET +|] + +instance Yesod Y where + approot _ = "http://test" + +getRootR :: Handler RepHtml +getRootR = defaultLayout $ toWidgetBody [julius||] + +getMultiR :: [String] -> Handler () +getMultiR _ = return () + +data Msg = Hello | Goodbye +instance RenderMessage Y Msg where + renderMessage _ ("en":_) Hello = "Hello" + renderMessage _ ("es":_) Hello = "Hola" + renderMessage _ ("en":_) Goodbye = "Goodbye" + renderMessage _ ("es":_) Goodbye = "Adios" + renderMessage a (_:xs) y = renderMessage a xs y + renderMessage a [] y = renderMessage a ["en"] y + +getTowidgetR :: Handler RepHtml +getTowidgetR = defaultLayout $ do + toWidget [julius|foo|] :: Widget + toWidgetHead [julius|foo|] + toWidgetBody [julius|foo|] + + toWidget [lucius|foo{bar:baz}|] + toWidgetHead [lucius|foo{bar:baz}|] + + toWidget [hamlet||] :: Widget + toWidgetHead [hamlet||] + toWidgetBody [hamlet||] + +getWhamletR :: Handler RepHtml +getWhamletR = defaultLayout [whamlet| +

Test +

@{WhamletR} +

_{Goodbye} +

_{MsgAnother} +^{embed} +|] + where + embed = [whamlet|

Embed|] + +widgetTest :: [Spec] +widgetTest = describe "Test.Widget" + [ it "addJuliusBody" case_addJuliusBody + , it "whamlet" case_whamlet + ] + +runner :: Session () -> IO () +runner f = toWaiApp Y >>= runSession f + +case_addJuliusBody :: IO () +case_addJuliusBody = runner $ do + res <- request defaultRequest + assertBody "\n" res + +case_whamlet :: IO () +case_whamlet = runner $ do + res <- request defaultRequest + { pathInfo = ["whamlet"] + , requestHeaders = [("Accept-Language", "es")] + } + assertBody "\n

Test

http://test/whamlet

Adios

String

Embed

" res diff --git a/test/en.msg b/test/en.msg new file mode 100644 --- /dev/null +++ b/test/en.msg @@ -0,0 +1,1 @@ +Another: String diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,20 @@ +import Test.Hspec + +import Test.CleanPath +import Test.Exceptions +import Test.Widget +import Test.Media +import Test.Links +import Test.NoOverloadedStrings +import Test.InternalRequest + +main :: IO () +main = hspecX $ descriptions $ + [ cleanPathTest + , exceptionsTest + , widgetTest + , mediaTest + , linksTest + , noOverloadedTest + , internalRequestTest + ] diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 0.9.2 +version: 0.9.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -14,6 +14,16 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ +extra-source-files: + test/en.msg + test/Test/NoOverloadedStrings.hs + test/Test/Media.hs + test/Test/Exceptions.hs + test/Test/Widget.hs + test/Test/CleanPath.hs + test/Test/Links.hs + test/Test/InternalRequest.hs + test/main.hs flag test description: Build the executable to run unit tests @@ -54,8 +64,12 @@ , 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 + , vector >= 0.9 && < 0.10 + , aeson-native >= 0.3.3.1 && < 0.4 exposed-modules: Yesod.Content Yesod.Core @@ -65,6 +79,8 @@ Yesod.Request Yesod.Widget Yesod.Message + Yesod.Config + Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Core Yesod.Internal.Session @@ -91,7 +107,7 @@ build-depends: base >= 4 && < 4.3 main-is: main.hs cpp-options: -DTEST - build-depends: hspec >= 0.6.1 && < 0.7 + build-depends: hspec >= 0.8 && < 0.9 ,wai-test ,wai ,yesod-core @@ -101,6 +117,7 @@ ,shakespeare-js ,text ,http-types + , random ,HUnit ,QuickCheck >= 2 && < 3 ghc-options: -Wall