Add 'yesod-core/' from commit '982d6185bee75b078bee92bd8a2e8743707f1922'
git-subtree-dir: yesod-core git-subtree-mainline:cd5ee0fb12git-subtree-split:982d6185be
This commit is contained in:
Michael Snoyman
commit
2dc10de435
7
yesod-core/.gitignore
vendored
Normal file
7
yesod-core/.gitignore
vendored
Normal file
@ -0,0 +1,7 @@
|
||||
/dist/
|
||||
*.swp
|
||||
client_session_key.aes
|
||||
*.hi
|
||||
*.o
|
||||
blog.db3
|
||||
static/tmp/
|
||||
25
yesod-core/LICENSE
Normal file
25
yesod-core/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.
|
||||
1
yesod-core/README
Normal file
1
yesod-core/README
Normal file
@ -0,0 +1 @@
|
||||
Learn more at http://docs.yesodweb.com/
|
||||
7
yesod-core/Setup.lhs
Executable file
7
yesod-core/Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
||||
132
yesod-core/Test/CleanPath.hs
Normal file
132
yesod-core/Test/CleanPath.hs
Normal file
@ -0,0 +1,132 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.CleanPath (cleanPathTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Content
|
||||
import Yesod.Dispatch
|
||||
import Yesod.Handler (Route)
|
||||
|
||||
import Test.Framework (defaultMain, testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Network.HTTP.Types (status200, decodePathSegments)
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import qualified Data.Text as TS
|
||||
|
||||
data Subsite = Subsite
|
||||
getSubsite = const Subsite
|
||||
data SubsiteRoute = SubsiteRoute [TS.Text]
|
||||
deriving (Eq, Show, Read)
|
||||
type instance Route Subsite = SubsiteRoute
|
||||
instance RenderRoute SubsiteRoute where
|
||||
renderRoute (SubsiteRoute x) = (x, [])
|
||||
|
||||
instance YesodDispatch Subsite master where
|
||||
yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
|
||||
status200
|
||||
[ ("Content-Type", "SUBSITE")
|
||||
] $ L8.pack $ show pieces
|
||||
|
||||
data Y = Y
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/foo FooR GET
|
||||
/foo/#String FooStringR GET
|
||||
/bar BarR GET
|
||||
/subsite SubsiteR Subsite getSubsite
|
||||
/plain PlainR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
approot _ = "http://test"
|
||||
cleanPath _ ["bar", ""] = Right ["bar"]
|
||||
cleanPath _ ["bar"] = Left ["bar", ""]
|
||||
cleanPath _ s =
|
||||
if corrected == s
|
||||
then Right s
|
||||
else Left corrected
|
||||
where
|
||||
corrected = filter (not . TS.null) s
|
||||
|
||||
getFooR = return $ RepPlain "foo"
|
||||
getFooStringR = return . RepPlain . toContent
|
||||
getBarR = return $ RepPlain "bar"
|
||||
getPlainR = return $ RepPlain "plain"
|
||||
|
||||
cleanPathTest :: Test
|
||||
cleanPathTest = testGroup "Test.CleanPath"
|
||||
[ testCase "remove trailing slash" removeTrailingSlash
|
||||
, testCase "noTrailingSlash" noTrailingSlash
|
||||
, testCase "add trailing slash" addTrailingSlash
|
||||
, testCase "has trailing slash" hasTrailingSlash
|
||||
, testCase "/foo/something" fooSomething
|
||||
, testCase "subsite dispatch" subsiteDispatch
|
||||
, testCase "redirect with query string" redQueryString
|
||||
]
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, rawQueryString = ""
|
||||
, requestMethod = "GET"
|
||||
}
|
||||
|
||||
removeTrailingSlash = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/foo/"
|
||||
}
|
||||
assertStatus 301 res
|
||||
assertHeader "Location" "http://test/foo" res
|
||||
|
||||
noTrailingSlash = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/foo"
|
||||
}
|
||||
assertStatus 200 res
|
||||
assertContentType "text/plain; charset=utf-8" res
|
||||
assertBody "foo" res
|
||||
|
||||
addTrailingSlash = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/bar"
|
||||
}
|
||||
assertStatus 301 res
|
||||
assertHeader "Location" "http://test/bar/" res
|
||||
|
||||
hasTrailingSlash = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/bar/"
|
||||
}
|
||||
assertStatus 200 res
|
||||
assertContentType "text/plain; charset=utf-8" res
|
||||
assertBody "bar" res
|
||||
|
||||
fooSomething = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/foo/something"
|
||||
}
|
||||
assertStatus 200 res
|
||||
assertContentType "text/plain; charset=utf-8" res
|
||||
assertBody "something" res
|
||||
|
||||
subsiteDispatch = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/subsite/1/2/3/"
|
||||
}
|
||||
assertStatus 200 res
|
||||
assertContentType "SUBSITE" res
|
||||
assertBody "[\"1\",\"2\",\"3\",\"\"]" res
|
||||
|
||||
redQueryString = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = decodePathSegments "/plain/"
|
||||
, rawQueryString = "?foo=bar"
|
||||
}
|
||||
assertStatus 301 res
|
||||
assertHeader "Location" "http://test/plain?foo=bar" res
|
||||
47
yesod-core/Test/Exceptions.hs
Normal file
47
yesod-core/Test/Exceptions.hs
Normal file
@ -0,0 +1,47 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.Exceptions (exceptionsTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Content
|
||||
import Yesod.Dispatch
|
||||
import Yesod.Handler (Route, ErrorResponse (InternalError))
|
||||
|
||||
import Test.Framework (defaultMain, testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
data Y = Y
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/ RootR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
approot _ = "http://test"
|
||||
errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e
|
||||
errorHandler x = defaultErrorHandler x
|
||||
|
||||
getRootR = error "FOOBAR" >> return ()
|
||||
|
||||
exceptionsTest :: Test
|
||||
exceptionsTest = testGroup "Test.Exceptions"
|
||||
[ testCase "500" case500
|
||||
]
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, requestMethod = "GET"
|
||||
}
|
||||
|
||||
case500 = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertStatus 500 res
|
||||
assertBody "FOOBAR" res
|
||||
42
yesod-core/Test/Links.hs
Normal file
42
yesod-core/Test/Links.hs
Normal file
@ -0,0 +1,42 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.Links (linksTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Text.Hamlet
|
||||
|
||||
import Test.Framework (defaultMain, testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
data Y = Y
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/ RootR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
approot _ = ""
|
||||
|
||||
getRootR = defaultLayout $ addHamlet [$hamlet|<a href=@{RootR}>|]
|
||||
|
||||
linksTest :: Test
|
||||
linksTest = testGroup "Test.Links"
|
||||
[ testCase "linkToHome" case_linkToHome
|
||||
]
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, requestMethod = "GET"
|
||||
}
|
||||
|
||||
case_linkToHome = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res
|
||||
64
yesod-core/Test/Media.hs
Normal file
64
yesod-core/Test/Media.hs
Normal file
@ -0,0 +1,64 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.Media (mediaTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
|
||||
import Test.Framework (defaultMain, testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import Network.HTTP.Types (status200, decodePathSegments)
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import qualified Data.Text as TS
|
||||
import Text.Lucius
|
||||
|
||||
data Y = Y
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/ RootR GET
|
||||
/static StaticR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
approot _ = ""
|
||||
addStaticContent _ _ content = do
|
||||
tm <- getRouteToMaster
|
||||
route <- getCurrentRoute
|
||||
case fmap tm route of
|
||||
Just StaticR -> return $ Just $ Left $
|
||||
if content == "foo2{bar:baz}"
|
||||
then "screen.css"
|
||||
else "all.css"
|
||||
_ -> return Nothing
|
||||
|
||||
getRootR = defaultLayout $ do
|
||||
addCassius [$lucius|foo1{bar:baz}|]
|
||||
addCassiusMedia "screen" [$lucius|foo2{bar:baz}|]
|
||||
addCassius [$lucius|foo3{bar:baz}|]
|
||||
getStaticR = getRootR
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, requestMethod = "GET"
|
||||
}
|
||||
|
||||
caseMedia = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertStatus 200 res
|
||||
flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><style>foo1{bar:baz}foo3{bar:baz}</style><style media=\"screen\">foo2{bar:baz}</style></head><body></body></html>"
|
||||
|
||||
caseMediaLink = runner $ do
|
||||
res <- request defaultRequest { pathInfo = ["static"] }
|
||||
assertStatus 200 res
|
||||
flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
|
||||
|
||||
mediaTest = testGroup "Test.Media"
|
||||
[ testCase "media" caseMedia
|
||||
, testCase "media link" caseMediaLink
|
||||
]
|
||||
50
yesod-core/Test/NoOverloadedStrings.hs
Normal file
50
yesod-core/Test/NoOverloadedStrings.hs
Normal file
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.NoOverloadedStrings (noOverloadedTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Network.Wai.Test
|
||||
import Network.Wai
|
||||
import Data.Monoid (mempty)
|
||||
import Data.String (fromString)
|
||||
|
||||
data Subsite = 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 = return ()
|
||||
getFooR = return ()
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, requestMethod = fromString "GET"
|
||||
}
|
||||
|
||||
case_sanity = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertBody mempty res
|
||||
|
||||
noOverloadedTest :: Test
|
||||
noOverloadedTest = testGroup "Test.NoOverloadedStrings"
|
||||
[ testCase "sanity" case_sanity
|
||||
]
|
||||
78
yesod-core/Test/Widget.hs
Normal file
78
yesod-core/Test/Widget.hs
Normal file
@ -0,0 +1,78 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Test.Widget (widgetTest) where
|
||||
|
||||
import Yesod.Core hiding (Request)
|
||||
import Yesod.Content
|
||||
import Yesod.Dispatch
|
||||
import Yesod.Widget
|
||||
import Text.Julius
|
||||
|
||||
import Test.Framework (defaultMain, testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.HUnit hiding (Test)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
|
||||
data Y = Y
|
||||
|
||||
mkMessage "Y" "test" "en"
|
||||
|
||||
mkYesod "Y" [$parseRoutes|
|
||||
/ RootR GET
|
||||
/foo/*Strings MultiR GET
|
||||
/whamlet WhamletR GET
|
||||
|]
|
||||
|
||||
instance Yesod Y where
|
||||
approot _ = "http://test"
|
||||
|
||||
getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
|
||||
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
|
||||
|
||||
getWhamletR = defaultLayout [$whamlet|
|
||||
<h1>Test
|
||||
<h2>@{WhamletR}
|
||||
<h3>_{Goodbye}
|
||||
<h3>_{MsgAnother}
|
||||
^{embed}
|
||||
|]
|
||||
where
|
||||
embed = [$whamlet|<h4>Embed|]
|
||||
|
||||
widgetTest :: Test
|
||||
widgetTest = testGroup "Test.Widget"
|
||||
[ testCase "addJuliusBody" case_addJuliusBody
|
||||
, testCase "whamlet" case_whamlet
|
||||
]
|
||||
|
||||
runner f = toWaiApp Y >>= runSession f
|
||||
defaultRequest = Request
|
||||
{ pathInfo = []
|
||||
, requestHeaders = []
|
||||
, queryString = []
|
||||
, requestMethod = "GET"
|
||||
}
|
||||
|
||||
case_addJuliusBody = runner $ do
|
||||
res <- request defaultRequest
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script><not escaped></script></body></html>" res
|
||||
|
||||
case_whamlet = runner $ do
|
||||
res <- request defaultRequest
|
||||
{ pathInfo = ["whamlet"]
|
||||
, requestHeaders = [("Accept-Language", "es")]
|
||||
}
|
||||
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res
|
||||
232
yesod-core/Yesod/Content.hs
Normal file
232
yesod-core/Yesod/Content.hs
Normal file
@ -0,0 +1,232 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Content
|
||||
( -- * Content
|
||||
Content (..)
|
||||
, emptyContent
|
||||
, ToContent (..)
|
||||
-- * Mime types
|
||||
-- ** Data type
|
||||
, ContentType
|
||||
, typeHtml
|
||||
, typePlain
|
||||
, typeJson
|
||||
, typeXml
|
||||
, typeAtom
|
||||
, typeRss
|
||||
, typeJpeg
|
||||
, typePng
|
||||
, typeGif
|
||||
, typeJavascript
|
||||
, typeCss
|
||||
, typeFlv
|
||||
, typeOgv
|
||||
, typeOctet
|
||||
-- * Utilities
|
||||
, simpleContentType
|
||||
-- * Representations
|
||||
, ChooseRep
|
||||
, HasReps (..)
|
||||
, defChooseRep
|
||||
-- ** Specific content types
|
||||
, RepHtml (..)
|
||||
, RepJson (..)
|
||||
, RepHtmlJson (..)
|
||||
, RepPlain (..)
|
||||
, RepXml (..)
|
||||
-- * Utilities
|
||||
, formatW3
|
||||
, formatRFC1123
|
||||
, formatRFC822
|
||||
) where
|
||||
|
||||
import Data.Maybe (mapMaybe)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Text.Lazy (Text, pack)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Data.Time
|
||||
import System.Locale
|
||||
|
||||
import qualified Data.Text.Encoding
|
||||
import qualified Data.Text.Lazy.Encoding
|
||||
|
||||
import Data.Enumerator (Enumerator)
|
||||
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
import Text.Hamlet (Html)
|
||||
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.String (IsString (fromString))
|
||||
import Network.Wai (FilePart)
|
||||
|
||||
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
|
||||
| ContentEnum (forall a. Enumerator Builder IO a)
|
||||
| ContentFile FilePath (Maybe FilePart)
|
||||
|
||||
-- | Zero-length enumerator.
|
||||
emptyContent :: Content
|
||||
emptyContent = ContentBuilder mempty $ Just 0
|
||||
|
||||
instance IsString Content where
|
||||
fromString = toContent
|
||||
|
||||
-- | Anything which can be converted into 'Content'. Most of the time, you will
|
||||
-- want to use the 'ContentBuilder' constructor. An easier approach will be to use
|
||||
-- a pre-defined 'toContent' function, such as converting your data into a lazy
|
||||
-- bytestring and then calling 'toContent' on that.
|
||||
--
|
||||
-- Please note that the built-in instances for lazy data structures ('String',
|
||||
-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include
|
||||
-- the content length for the 'ContentBuilder' constructor.
|
||||
class ToContent a where
|
||||
toContent :: a -> Content
|
||||
|
||||
instance ToContent Builder where
|
||||
toContent = flip ContentBuilder Nothing
|
||||
instance ToContent B.ByteString where
|
||||
toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
|
||||
instance ToContent L.ByteString where
|
||||
toContent = flip ContentBuilder Nothing . fromLazyByteString
|
||||
instance ToContent T.Text where
|
||||
toContent = toContent . Data.Text.Encoding.encodeUtf8
|
||||
instance ToContent Text where
|
||||
toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8
|
||||
instance ToContent String where
|
||||
toContent = toContent . pack
|
||||
instance ToContent Html where
|
||||
toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
|
||||
|
||||
-- | A function which gives targetted representations of content based on the
|
||||
-- content-types the user accepts.
|
||||
type ChooseRep =
|
||||
[ContentType] -- ^ list of content-types user accepts, ordered by preference
|
||||
-> IO (ContentType, Content)
|
||||
|
||||
-- | Any type which can be converted to representations.
|
||||
class HasReps a where
|
||||
chooseRep :: a -> ChooseRep
|
||||
|
||||
-- | A helper method for generating 'HasReps' instances.
|
||||
--
|
||||
-- This function should be given a list of pairs of content type and conversion
|
||||
-- functions. If none of the content types match, the first pair is used.
|
||||
defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep
|
||||
defChooseRep reps a ts = do
|
||||
let (ct, c) =
|
||||
case mapMaybe helper ts of
|
||||
(x:_) -> x
|
||||
[] -> case reps of
|
||||
[] -> error "Empty reps to defChooseRep"
|
||||
(x:_) -> x
|
||||
c' <- c a
|
||||
return (ct, c')
|
||||
where
|
||||
helper ct = do
|
||||
c <- lookup ct reps
|
||||
return (ct, c)
|
||||
|
||||
instance HasReps ChooseRep where
|
||||
chooseRep = id
|
||||
|
||||
instance HasReps () where
|
||||
chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]
|
||||
|
||||
instance HasReps (ContentType, Content) where
|
||||
chooseRep = const . return
|
||||
|
||||
instance HasReps [(ContentType, Content)] where
|
||||
chooseRep a cts = return $
|
||||
case filter (\(ct, _) -> go ct `elem` map go cts) a of
|
||||
((ct, c):_) -> (ct, c)
|
||||
_ -> case a of
|
||||
(x:_) -> x
|
||||
_ -> error "chooseRep [(ContentType, Content)] of empty"
|
||||
where
|
||||
go = simpleContentType
|
||||
|
||||
newtype RepHtml = RepHtml Content
|
||||
instance HasReps RepHtml where
|
||||
chooseRep (RepHtml c) _ = return (typeHtml, c)
|
||||
newtype RepJson = RepJson Content
|
||||
instance HasReps RepJson where
|
||||
chooseRep (RepJson c) _ = return (typeJson, c)
|
||||
data RepHtmlJson = RepHtmlJson Content Content
|
||||
instance HasReps RepHtmlJson where
|
||||
chooseRep (RepHtmlJson html json) = chooseRep
|
||||
[ (typeHtml, html)
|
||||
, (typeJson, json)
|
||||
]
|
||||
newtype RepPlain = RepPlain Content
|
||||
instance HasReps RepPlain where
|
||||
chooseRep (RepPlain c) _ = return (typePlain, c)
|
||||
newtype RepXml = RepXml Content
|
||||
instance HasReps RepXml where
|
||||
chooseRep (RepXml c) _ = return (typeXml, c)
|
||||
|
||||
type ContentType = B.ByteString -- FIXME Text?
|
||||
|
||||
typeHtml :: ContentType
|
||||
typeHtml = "text/html; charset=utf-8"
|
||||
|
||||
typePlain :: ContentType
|
||||
typePlain = "text/plain; charset=utf-8"
|
||||
|
||||
typeJson :: ContentType
|
||||
typeJson = "application/json; charset=utf-8"
|
||||
|
||||
typeXml :: ContentType
|
||||
typeXml = "text/xml"
|
||||
|
||||
typeAtom :: ContentType
|
||||
typeAtom = "application/atom+xml"
|
||||
|
||||
typeRss :: ContentType
|
||||
typeRss = "application/rss+xml"
|
||||
|
||||
typeJpeg :: ContentType
|
||||
typeJpeg = "image/jpeg"
|
||||
|
||||
typePng :: ContentType
|
||||
typePng = "image/png"
|
||||
|
||||
typeGif :: ContentType
|
||||
typeGif = "image/gif"
|
||||
|
||||
typeJavascript :: ContentType
|
||||
typeJavascript = "text/javascript; charset=utf-8"
|
||||
|
||||
typeCss :: ContentType
|
||||
typeCss = "text/css; charset=utf-8"
|
||||
|
||||
typeFlv :: ContentType
|
||||
typeFlv = "video/x-flv"
|
||||
|
||||
typeOgv :: ContentType
|
||||
typeOgv = "video/ogg"
|
||||
|
||||
typeOctet :: ContentType
|
||||
typeOctet = "application/octet-stream"
|
||||
|
||||
-- | Removes \"extra\" information at the end of a content type string. In
|
||||
-- particular, removes everything after the semicolon, if present.
|
||||
--
|
||||
-- For example, \"text/html; charset=utf-8\" is commonly used to specify the
|
||||
-- character encoding for HTML data. This function would return \"text/html\".
|
||||
simpleContentType :: ContentType -> ContentType
|
||||
simpleContentType = fst . B.breakByte 59 -- 59 == ;
|
||||
|
||||
-- | Format a 'UTCTime' in W3 format.
|
||||
formatW3 :: UTCTime -> T.Text
|
||||
formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"
|
||||
|
||||
-- | Format as per RFC 1123.
|
||||
formatRFC1123 :: UTCTime -> T.Text
|
||||
formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
|
||||
|
||||
-- | Format as per RFC 822.
|
||||
formatRFC822 :: UTCTime -> T.Text
|
||||
formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
|
||||
75
yesod-core/Yesod/Core.hs
Normal file
75
yesod-core/Yesod/Core.hs
Normal file
@ -0,0 +1,75 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Core
|
||||
( -- * Type classes
|
||||
Yesod (..)
|
||||
, YesodDispatch (..)
|
||||
, RenderRoute (..)
|
||||
-- ** Breadcrumbs
|
||||
, YesodBreadcrumbs (..)
|
||||
, breadcrumbs
|
||||
-- * Utitlities
|
||||
, maybeAuthorized
|
||||
, widgetToPageContent
|
||||
-- * Defaults
|
||||
, defaultErrorHandler
|
||||
-- * Data types
|
||||
, AuthResult (..)
|
||||
-- * Logging
|
||||
, LogLevel (..)
|
||||
, formatLogMessage
|
||||
, logDebug
|
||||
, logInfo
|
||||
, logWarn
|
||||
, logError
|
||||
, logOther
|
||||
-- * Misc
|
||||
, yesodVersion
|
||||
, yesodRender
|
||||
-- * Re-exports
|
||||
, module Yesod.Content
|
||||
, module Yesod.Dispatch
|
||||
, module Yesod.Handler
|
||||
, module Yesod.Request
|
||||
, module Yesod.Widget
|
||||
, module Yesod.Message
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Core
|
||||
import Yesod.Content
|
||||
import Yesod.Dispatch
|
||||
import Yesod.Handler
|
||||
import Yesod.Request
|
||||
import Yesod.Widget
|
||||
import Yesod.Message
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Text (Text)
|
||||
|
||||
logTH :: LogLevel -> Q Exp
|
||||
logTH level =
|
||||
[|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|]
|
||||
where
|
||||
liftLoc :: Loc -> Q Exp
|
||||
liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|]
|
||||
|
||||
-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
|
||||
--
|
||||
-- > $(logDebug) "This is a debug log message"
|
||||
logDebug :: Q Exp
|
||||
logDebug = logTH LevelDebug
|
||||
|
||||
-- | See 'logDebug'
|
||||
logInfo :: Q Exp
|
||||
logInfo = logTH LevelInfo
|
||||
-- | See 'logDebug'
|
||||
logWarn :: Q Exp
|
||||
logWarn = logTH LevelWarn
|
||||
-- | See 'logDebug'
|
||||
logError :: Q Exp
|
||||
logError = logTH LevelError
|
||||
|
||||
-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
|
||||
--
|
||||
-- > $(logOther "My new level") "This is a log message"
|
||||
logOther :: Text -> Q Exp
|
||||
logOther = logTH . LevelOther
|
||||
180
yesod-core/Yesod/Dispatch.hs
Normal file
180
yesod-core/Yesod/Dispatch.hs
Normal file
@ -0,0 +1,180 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Dispatch
|
||||
( -- * Quasi-quoted routing
|
||||
parseRoutes
|
||||
, parseRoutesFile
|
||||
, mkYesod
|
||||
, mkYesodSub
|
||||
-- ** More fine-grained
|
||||
, mkYesodData
|
||||
, mkYesodSubData
|
||||
, mkYesodDispatch
|
||||
, mkYesodSubDispatch
|
||||
-- ** Path pieces
|
||||
, SinglePiece (..)
|
||||
, MultiPiece (..)
|
||||
, Texts
|
||||
-- * Convert to WAI
|
||||
, toWaiApp
|
||||
, toWaiAppPlain
|
||||
) where
|
||||
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Either (partitionEithers)
|
||||
import Prelude hiding (exp)
|
||||
import Yesod.Internal.Core
|
||||
import Yesod.Handler
|
||||
import Yesod.Internal.Dispatch
|
||||
|
||||
import Web.PathPieces (SinglePiece (..), MultiPiece (..))
|
||||
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile)
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import Network.Wai.Middleware.Jsonp
|
||||
import Network.Wai.Middleware.Gzip
|
||||
import Network.Wai.Middleware.Autohead
|
||||
|
||||
import Data.ByteString.Lazy.Char8 ()
|
||||
|
||||
import Web.ClientSession
|
||||
import Data.Char (isUpper)
|
||||
import Data.Text (Text)
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
-- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
|
||||
-- Use 'parseRoutes' to create the 'Resource's.
|
||||
mkYesod :: String -- ^ name of the argument datatype
|
||||
-> [Resource]
|
||||
-> Q [Dec]
|
||||
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
|
||||
|
||||
-- | Generates URL datatype and site function for the given 'Resource's. This
|
||||
-- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
|
||||
-- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
|
||||
-- executable by itself, but instead provides functionality to
|
||||
-- be embedded in other sites.
|
||||
mkYesodSub :: String -- ^ name of the argument datatype
|
||||
-> Cxt
|
||||
-> [Resource]
|
||||
-> Q [Dec]
|
||||
mkYesodSub name clazzes =
|
||||
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
|
||||
where
|
||||
(name':rest) = words name
|
||||
|
||||
-- | Sometimes, you will want to declare your routes in one file and define
|
||||
-- your handlers elsewhere. For example, this is the only way to break up a
|
||||
-- monolithic file into smaller parts. Use this function, paired with
|
||||
-- 'mkYesodDispatch', to do just that.
|
||||
mkYesodData :: String -> [Resource] -> Q [Dec]
|
||||
mkYesodData name res = mkYesodDataGeneral name [] False res
|
||||
|
||||
mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
|
||||
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
|
||||
|
||||
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]
|
||||
mkYesodDataGeneral name clazzes isSub res = do
|
||||
let (name':rest) = words name
|
||||
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
|
||||
let rname = mkName $ "resources" ++ name
|
||||
eres <- lift res
|
||||
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
|
||||
, FunD rname [Clause [] (NormalB eres) []]
|
||||
]
|
||||
return $ x ++ y
|
||||
|
||||
-- | See 'mkYesodData'.
|
||||
mkYesodDispatch :: String -> [Resource] -> Q [Dec]
|
||||
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
|
||||
|
||||
mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
|
||||
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
|
||||
where (name':rest) = words name
|
||||
|
||||
mkYesodGeneral :: String -- ^ foundation name
|
||||
-> [String] -- ^ parameters for foundation
|
||||
-> Cxt -- ^ classes
|
||||
-> Bool -- ^ is subsite?
|
||||
-> [Resource]
|
||||
-> Q ([Dec], [Dec])
|
||||
mkYesodGeneral name args clazzes isSub res = do
|
||||
let name' = mkName name
|
||||
args' = map mkName args
|
||||
arg = foldl AppT (ConT name') $ map VarT args'
|
||||
th' <- mapM thResourceFromResource res
|
||||
let th = map fst th'
|
||||
w' <- createRoutes th
|
||||
let routesName = mkName $ name ++ "Route"
|
||||
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
|
||||
let x = TySynInstD ''Route [arg] $ ConT routesName
|
||||
|
||||
render <- createRender th
|
||||
let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
|
||||
[ FunD (mkName "renderRoute") render
|
||||
]
|
||||
|
||||
let splitter :: (THResource, Maybe String)
|
||||
-> Either
|
||||
(THResource, Maybe String)
|
||||
(THResource, Maybe String)
|
||||
splitter a@((_, SubSite{}), _) = Left a
|
||||
splitter a = Right a
|
||||
let (resSub, resLoc) = partitionEithers $ map splitter th'
|
||||
yd <- mkYesodDispatch' resSub resLoc
|
||||
let master = mkName "master"
|
||||
let ctx = if isSub
|
||||
then ClassP (mkName "Yesod") [VarT master] : clazzes
|
||||
else []
|
||||
let ytyp = if isSub
|
||||
then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
|
||||
else ConT ''YesodDispatch `AppT` arg `AppT` arg
|
||||
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
|
||||
return ([w, x, x'], [y])
|
||||
|
||||
thResourceFromResource :: Resource -> Q (THResource, Maybe String)
|
||||
thResourceFromResource (Resource n ps atts)
|
||||
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
|
||||
thResourceFromResource (Resource n ps [stype, toSubArg]) = do
|
||||
let stype' = ConT $ mkName stype
|
||||
parse <- [|error "ssParse"|]
|
||||
dispatch <- [|error "ssDispatch"|]
|
||||
render <- [|renderRoute|]
|
||||
tmg <- [|error "ssToMasterArg"|]
|
||||
return ((n, SubSite
|
||||
{ ssType = ConT ''Route `AppT` stype'
|
||||
, ssParse = parse
|
||||
, ssRender = render
|
||||
, ssDispatch = dispatch
|
||||
, ssToMasterArg = tmg
|
||||
, ssPieces = ps
|
||||
}), Just toSubArg)
|
||||
|
||||
thResourceFromResource (Resource n _ _) =
|
||||
error $ "Invalid attributes for resource: " ++ n
|
||||
|
||||
-- | 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
|
||||
-- recommended approach for most users.
|
||||
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
|
||||
toWaiApp y = gzip False . 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.
|
||||
toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
|
||||
toWaiAppPlain a = toWaiApp' a <$> encryptKey a
|
||||
|
||||
|
||||
toWaiApp' :: (Yesod y, YesodDispatch y y)
|
||||
=> y
|
||||
-> Maybe Key
|
||||
-> W.Application
|
||||
toWaiApp' y key' env =
|
||||
case yesodDispatch y key' (W.pathInfo env) y id of
|
||||
Just app -> app env
|
||||
Nothing -> yesodRunner y y id key' Nothing notFound env
|
||||
904
yesod-core/Yesod/Handler.hs
Normal file
904
yesod-core/Yesod/Handler.hs
Normal file
@ -0,0 +1,904 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Handler
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : unstable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Define Handler stuff.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Yesod.Handler
|
||||
( -- * Type families
|
||||
Route
|
||||
, YesodSubRoute (..)
|
||||
-- * Handler monad
|
||||
, GHandler
|
||||
, GGHandler
|
||||
-- ** Read information from handler
|
||||
, getYesod
|
||||
, getYesodSub
|
||||
, getUrlRender
|
||||
, getUrlRenderParams
|
||||
, getCurrentRoute
|
||||
, getRouteToMaster
|
||||
, getRequest
|
||||
, waiRequest
|
||||
, runRequestBody
|
||||
-- * Special responses
|
||||
-- ** Redirecting
|
||||
, RedirectType (..)
|
||||
, redirect
|
||||
, redirectParams
|
||||
, redirectString
|
||||
, redirectText
|
||||
, redirectToPost
|
||||
-- ** Errors
|
||||
, notFound
|
||||
, badMethod
|
||||
, permissionDenied
|
||||
, permissionDeniedI
|
||||
, invalidArgs
|
||||
, invalidArgsI
|
||||
-- ** Short-circuit responses.
|
||||
, sendFile
|
||||
, sendFilePart
|
||||
, sendResponse
|
||||
, sendResponseStatus
|
||||
, sendResponseCreated
|
||||
, sendWaiResponse
|
||||
-- * Setting headers
|
||||
, setCookie
|
||||
, deleteCookie
|
||||
, setHeader
|
||||
, setLanguage
|
||||
-- ** Content caching and expiration
|
||||
, cacheSeconds
|
||||
, neverExpires
|
||||
, alreadyExpired
|
||||
, expiresAt
|
||||
-- * Session
|
||||
, SessionMap
|
||||
, lookupSession
|
||||
, getSession
|
||||
, setSession
|
||||
, deleteSession
|
||||
-- ** Ultimate destination
|
||||
, setUltDest
|
||||
, setUltDestString
|
||||
, setUltDestText
|
||||
, setUltDest'
|
||||
, setUltDestReferer
|
||||
, redirectUltDest
|
||||
, clearUltDest
|
||||
-- ** Messages
|
||||
, setMessage
|
||||
, setMessageI
|
||||
, getMessage
|
||||
-- * Helpers for specific content
|
||||
-- ** Hamlet
|
||||
, hamletToContent
|
||||
, hamletToRepHtml
|
||||
-- ** Misc
|
||||
, newIdent
|
||||
, liftIOHandler
|
||||
-- * i18n
|
||||
, getMessageRender
|
||||
-- * Internal Yesod
|
||||
, runHandler
|
||||
, YesodApp (..)
|
||||
, runSubsiteGetter
|
||||
, toMasterHandler
|
||||
, toMasterHandlerDyn
|
||||
, toMasterHandlerMaybe
|
||||
, localNoCurrent
|
||||
, HandlerData
|
||||
, ErrorResponse (..)
|
||||
, YesodAppResult (..)
|
||||
, handlerToYAR
|
||||
, yarToResponse
|
||||
, headerToPair
|
||||
) where
|
||||
|
||||
import Prelude hiding (catch)
|
||||
import Yesod.Internal.Request
|
||||
import Yesod.Internal
|
||||
import Data.Time (UTCTime)
|
||||
|
||||
import Control.Exception hiding (Handler, catch, finally)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Applicative
|
||||
|
||||
import Control.Monad (liftM, join, MonadPlus)
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Writer
|
||||
import Control.Monad.Trans.Reader
|
||||
import Control.Monad.Trans.State
|
||||
import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
|
||||
|
||||
import System.IO
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Control.Failure (Failure (failure))
|
||||
|
||||
import Text.Hamlet
|
||||
import qualified Text.Blaze.Renderer.Text
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Control.Monad.IO.Control (MonadControlIO)
|
||||
import Control.Monad.Trans.Control (MonadTransControl, liftControl)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.ByteString as S
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Enumerator (Iteratee (..), run_, ($$))
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
|
||||
import Yesod.Content
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Web.Cookie (SetCookie (..), renderSetCookie)
|
||||
import Control.Arrow (second, (***))
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import Data.Monoid (mappend, mempty, Endo (..))
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Blaze.ByteString.Builder (toByteString)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
|
||||
import Text.Blaze (toHtml, preEscapedText)
|
||||
|
||||
-- | The type-safe URLs associated with a site argument.
|
||||
type family Route a
|
||||
|
||||
class YesodSubRoute s y where
|
||||
fromSubRoute :: s -> y -> Route s -> Route y
|
||||
|
||||
data HandlerData sub master = HandlerData
|
||||
{ handlerRequest :: Request
|
||||
, handlerSub :: sub
|
||||
, handlerMaster :: master
|
||||
, handlerRoute :: Maybe (Route sub)
|
||||
, handlerRender :: Route master -> [(Text, Text)] -> Text
|
||||
, handlerToMaster :: Route sub -> Route master
|
||||
}
|
||||
|
||||
handlerSubData :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
|
||||
|
||||
handlerSubDataMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> HandlerData oldSub master
|
||||
-> HandlerData sub master
|
||||
handlerSubDataMaybe tm ts route hd = hd
|
||||
{ handlerSub = ts $ handlerMaster hd
|
||||
, handlerToMaster = tm
|
||||
, handlerRoute = route
|
||||
}
|
||||
|
||||
-- | Used internally for promoting subsite handler functions to master site
|
||||
-- handler functions. Should not be needed by users.
|
||||
toMasterHandler :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
toMasterHandler tm ts route (GHandler h) =
|
||||
GHandler $ withReaderT (handlerSubData tm ts route) h
|
||||
|
||||
toMasterHandlerDyn :: Monad mo
|
||||
=> (Route sub -> Route master)
|
||||
-> GGHandler sub' master mo sub
|
||||
-> Route sub
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
toMasterHandlerDyn tm getSub route (GHandler h) = do
|
||||
sub <- getSub
|
||||
GHandler $ withReaderT (handlerSubData tm (const sub) route) h
|
||||
|
||||
class SubsiteGetter g m s | g -> s where
|
||||
runSubsiteGetter :: g -> m s
|
||||
|
||||
instance (master ~ master'
|
||||
) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where
|
||||
runSubsiteGetter getter = getter <$> getYesod
|
||||
|
||||
instance (anySub ~ anySub'
|
||||
,master ~ master'
|
||||
) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
|
||||
runSubsiteGetter = id
|
||||
|
||||
toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> GGHandler sub master mo a
|
||||
-> GGHandler sub' master mo a
|
||||
toMasterHandlerMaybe tm ts route (GHandler h) =
|
||||
GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
-- site. This monad is a combination of 'ReaderT' for basic arguments, a
|
||||
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
|
||||
-- special responses. It is declared as a newtype to make compiler errors more
|
||||
-- readable.
|
||||
newtype GGHandler sub master m a =
|
||||
GHandler
|
||||
{ unGHandler :: GHInner sub master m a
|
||||
}
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus)
|
||||
|
||||
instance MonadTrans (GGHandler s m) where
|
||||
lift = GHandler . lift . lift . lift . lift
|
||||
|
||||
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: SessionMap
|
||||
, ghsRBC :: Maybe RequestBodyContents
|
||||
, ghsIdent :: Int
|
||||
}
|
||||
|
||||
type GHInner s m monad = -- FIXME collapse the stack
|
||||
ReaderT (HandlerData s m) (
|
||||
ErrorT HandlerContents (
|
||||
WriterT (Endo [Header]) (
|
||||
StateT GHState (
|
||||
monad
|
||||
))))
|
||||
|
||||
type SessionMap = Map.Map Text Text
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
-- features needed by Yesod. Users should never need to use this directly, as
|
||||
-- the 'GHandler' monad and template haskell code should hide it away.
|
||||
newtype YesodApp = YesodApp
|
||||
{ unYesodApp
|
||||
:: (ErrorResponse -> YesodApp)
|
||||
-> Request
|
||||
-> [ContentType]
|
||||
-> SessionMap
|
||||
-> Iteratee ByteString IO YesodAppResult
|
||||
}
|
||||
|
||||
data YesodAppResult
|
||||
= YARWai W.Response
|
||||
| YARPlain H.Status [Header] ContentType Content SessionMap
|
||||
|
||||
data HandlerContents =
|
||||
HCContent H.Status ChooseRep
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?
|
||||
| HCRedirect RedirectType Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
|
||||
instance Error HandlerContents where
|
||||
strMsg = HCError . InternalError . T.pack
|
||||
|
||||
getRequest :: Monad mo => GGHandler s m mo Request
|
||||
getRequest = handlerRequest `liftM` GHandler ask
|
||||
|
||||
instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
|
||||
failure = GHandler . lift . throwError . HCError
|
||||
|
||||
runRequestBody :: GHandler s m RequestBodyContents
|
||||
runRequestBody = do
|
||||
x <- GHandler $ lift $ lift $ lift get
|
||||
case ghsRBC x of
|
||||
Just rbc -> return rbc
|
||||
Nothing -> do
|
||||
rr <- waiRequest
|
||||
rbc <- lift $ rbHelper rr
|
||||
GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc }
|
||||
return rbc
|
||||
|
||||
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
|
||||
rbHelper req =
|
||||
(map fix1 *** map fix2) <$> iter
|
||||
where
|
||||
iter = NWP.parseRequestBody NWP.lbsSink req
|
||||
fix1 = go *** go
|
||||
fix2 (x, NWP.FileInfo a b c) =
|
||||
(go x, FileInfo (go a) (go b) c)
|
||||
go = decodeUtf8With lenientDecode
|
||||
|
||||
-- | Get the sub application argument.
|
||||
getYesodSub :: Monad m => GGHandler sub master m sub
|
||||
getYesodSub = handlerSub `liftM` GHandler ask
|
||||
|
||||
-- | Get the master site appliation argument.
|
||||
getYesod :: Monad m => GGHandler sub master m master
|
||||
getYesod = handlerMaster `liftM` GHandler ask
|
||||
|
||||
-- | Get the URL rendering function.
|
||||
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
|
||||
getUrlRender = do
|
||||
x <- handlerRender `liftM` GHandler ask
|
||||
return $ flip x []
|
||||
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: Monad m
|
||||
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = handlerRender `liftM` GHandler ask
|
||||
|
||||
-- | Get the route requested by the user. If this is a 404 response- where the
|
||||
-- user requested an invalid route- this function will return 'Nothing'.
|
||||
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
|
||||
getCurrentRoute = handlerRoute `liftM` GHandler ask
|
||||
|
||||
-- | Get the function to promote a route for a subsite to a route for the
|
||||
-- master site.
|
||||
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
|
||||
getRouteToMaster = handlerToMaster `liftM` GHandler ask
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
|
||||
runHandler :: HasReps c
|
||||
=> GHandler sub master c
|
||||
-> (Route master -> [(Text, Text)] -> Text)
|
||||
-> Maybe (Route sub)
|
||||
-> (Route sub -> Route master)
|
||||
-> master
|
||||
-> sub
|
||||
-> YesodApp
|
||||
runHandler handler mrender sroute tomr ma sa =
|
||||
YesodApp $ \eh rr cts initSession -> do
|
||||
let toErrorHandler e =
|
||||
case fromException e of
|
||||
Just x -> x
|
||||
Nothing -> InternalError $ T.pack $ show e
|
||||
let hd = HandlerData
|
||||
{ handlerRequest = rr
|
||||
, handlerSub = sa
|
||||
, handlerMaster = ma
|
||||
, handlerRoute = sroute
|
||||
, handlerRender = mrender
|
||||
, handlerToMaster = tomr
|
||||
}
|
||||
let initSession' = GHState initSession Nothing 1
|
||||
((contents', headers), finalSession) <- catchIter (
|
||||
fmap (second ghsSession)
|
||||
$ flip runStateT initSession'
|
||||
$ runWriterT
|
||||
$ runErrorT
|
||||
$ flip runReaderT hd
|
||||
$ unGHandler handler
|
||||
) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession))
|
||||
let contents = either id (HCContent H.status200 . chooseRep) contents'
|
||||
let handleError e = do
|
||||
yar <- unYesodApp (eh e) safeEh rr cts finalSession
|
||||
case yar of
|
||||
YARPlain _ hs ct c sess ->
|
||||
let hs' = appEndo headers hs
|
||||
in return $ YARPlain (getStatus e) hs' ct c sess
|
||||
YARWai _ -> return yar
|
||||
let sendFile' ct fp p =
|
||||
return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
|
||||
case contents of
|
||||
HCContent status a -> do
|
||||
(ct, c) <- liftIO $ a cts
|
||||
return $ YARPlain status (appEndo headers []) ct c finalSession
|
||||
HCError e -> handleError e
|
||||
HCRedirect rt loc -> do
|
||||
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
|
||||
return $ YARPlain
|
||||
(getRedirectStatus rt) hs typePlain emptyContent
|
||||
finalSession
|
||||
HCSendFile ct fp p -> catchIter
|
||||
(sendFile' ct fp p)
|
||||
(handleError . toErrorHandler)
|
||||
HCCreated loc -> do
|
||||
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
|
||||
return $ YARPlain
|
||||
H.status201
|
||||
hs
|
||||
typePlain
|
||||
emptyContent
|
||||
finalSession
|
||||
HCWai r -> return $ YARWai r
|
||||
|
||||
catchIter :: Exception e
|
||||
=> Iteratee ByteString IO a
|
||||
-> (e -> Iteratee ByteString IO a)
|
||||
-> Iteratee ByteString IO a
|
||||
catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
|
||||
|
||||
safeEh :: ErrorResponse -> YesodApp
|
||||
safeEh er = YesodApp $ \_ _ _ session -> do
|
||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
||||
return $ YARPlain
|
||||
H.status500
|
||||
[]
|
||||
typePlain
|
||||
(toContent ("Internal Server Error" :: S.ByteString))
|
||||
session
|
||||
|
||||
-- | Redirect to the given route.
|
||||
redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a
|
||||
redirect rt url = redirectParams rt url []
|
||||
|
||||
-- | Redirects to the given route with the associated query-string parameters.
|
||||
redirectParams :: Monad mo
|
||||
=> RedirectType -> Route master -> [(Text, Text)]
|
||||
-> GGHandler sub master mo a
|
||||
redirectParams rt url params = do
|
||||
r <- getUrlRenderParams
|
||||
redirectString rt $ r url params
|
||||
|
||||
-- | Redirect to the given URL.
|
||||
redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
|
||||
redirectText rt = GHandler . lift . throwError . HCRedirect rt
|
||||
redirectString = redirectText
|
||||
{-# DEPRECATED redirectString "Use redirectText instead" #-}
|
||||
|
||||
ultDestKey :: Text
|
||||
ultDestKey = "_ULT"
|
||||
|
||||
-- | Sets the ultimate destination variable to the given route.
|
||||
--
|
||||
-- An ultimate destination is stored in the user session and can be loaded
|
||||
-- later by 'redirectUltDest'.
|
||||
setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
|
||||
setUltDest dest = do
|
||||
render <- getUrlRender
|
||||
setUltDestString $ render dest
|
||||
|
||||
-- | Same as 'setUltDest', but use the given string.
|
||||
setUltDestText :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
setUltDestText = setSession ultDestKey
|
||||
|
||||
setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
setUltDestString = setSession ultDestKey
|
||||
{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
|
||||
|
||||
-- | Same as 'setUltDest', but uses the current page.
|
||||
--
|
||||
-- If this is a 404 handler, there is no current page, and then this call does
|
||||
-- nothing.
|
||||
setUltDest' :: Monad mo => GGHandler sub master mo ()
|
||||
setUltDest' = do
|
||||
route <- getCurrentRoute
|
||||
case route of
|
||||
Nothing -> return ()
|
||||
Just r -> do
|
||||
tm <- getRouteToMaster
|
||||
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
|
||||
render <- getUrlRenderParams
|
||||
setUltDestString $ render (tm r) gets'
|
||||
|
||||
-- | Sets the ultimate destination to the referer request header, if present.
|
||||
--
|
||||
-- This function will not overwrite an existing ultdest.
|
||||
setUltDestReferer :: Monad mo => GGHandler sub master mo ()
|
||||
setUltDestReferer = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
maybe
|
||||
(waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
|
||||
(const $ return ())
|
||||
mdest
|
||||
where
|
||||
setUltDestBS = setUltDestText . T.pack . S8.unpack
|
||||
|
||||
-- | Redirect to the ultimate destination in the user's session. Clear the
|
||||
-- value from the session.
|
||||
--
|
||||
-- The ultimate destination is set with 'setUltDest'.
|
||||
redirectUltDest :: Monad mo
|
||||
=> RedirectType
|
||||
-> Route master -- ^ default destination if nothing in session
|
||||
-> GGHandler sub master mo a
|
||||
redirectUltDest rt def = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
deleteSession ultDestKey
|
||||
maybe (redirect rt def) (redirectText rt) mdest
|
||||
|
||||
-- | Remove a previously set ultimate destination. See 'setUltDest'.
|
||||
clearUltDest :: Monad mo => GGHandler sub master mo ()
|
||||
clearUltDest = deleteSession ultDestKey
|
||||
|
||||
msgKey :: Text
|
||||
msgKey = "_MSG"
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessage :: Monad mo => Html -> GGHandler sub master mo ()
|
||||
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()
|
||||
setMessageI msg = do
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
|
||||
-- | Gets the message in the user's session, if available, and then clears the
|
||||
-- variable.
|
||||
--
|
||||
-- See 'setMessage'.
|
||||
getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
|
||||
getMessage = do
|
||||
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
|
||||
deleteSession msgKey
|
||||
return mmsg
|
||||
|
||||
-- | Bypass remaining handler code and output the given file.
|
||||
--
|
||||
-- For some backends, this is more efficient than reading in the file to
|
||||
-- memory, since they can optimize file sending via a system call to sendfile.
|
||||
sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
|
||||
sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing
|
||||
|
||||
-- | Same as 'sendFile', but only sends part of a file.
|
||||
sendFilePart :: Monad mo
|
||||
=> ContentType
|
||||
-> FilePath
|
||||
-> Integer -- ^ offset
|
||||
-> Integer -- ^ count
|
||||
-> GGHandler sub master mo a
|
||||
sendFilePart ct fp off count =
|
||||
GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with a 200
|
||||
-- status code.
|
||||
sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
|
||||
sendResponse = GHandler . lift . throwError . HCContent H.status200
|
||||
. chooseRep
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with the given
|
||||
-- status code.
|
||||
sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
|
||||
sendResponseStatus s = GHandler . lift . throwError . HCContent s
|
||||
. chooseRep
|
||||
|
||||
-- | Send a 201 "Created" response with the given route as the Location
|
||||
-- response header.
|
||||
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
|
||||
sendResponseCreated url = do
|
||||
r <- getUrlRender
|
||||
GHandler $ lift $ throwError $ HCCreated $ r url
|
||||
|
||||
-- | Send a 'W.Response'. Please note: this function is rarely
|
||||
-- necessary, and will /disregard/ any changes to response headers and session
|
||||
-- that you have already specified. This function short-circuits. It should be
|
||||
-- considered only for very specific needs. If you are not sure if you need it,
|
||||
-- you don't.
|
||||
sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b
|
||||
sendWaiResponse = GHandler . lift . throwError . HCWai
|
||||
|
||||
-- | Return a 404 not found page. Also denotes no handler available.
|
||||
notFound :: Failure ErrorResponse m => m a
|
||||
notFound = failure NotFound
|
||||
|
||||
-- | Return a 405 method not supported page.
|
||||
badMethod :: Monad mo => GGHandler s m mo a
|
||||
badMethod = do
|
||||
w <- waiRequest
|
||||
failure $ BadMethod $ W.requestMethod w
|
||||
|
||||
-- | Return a 403 permission denied page.
|
||||
permissionDenied :: Failure ErrorResponse m => Text -> m a
|
||||
permissionDenied = failure . PermissionDenied
|
||||
|
||||
-- | Return a 403 permission denied page.
|
||||
permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a
|
||||
permissionDeniedI msg = do
|
||||
mr <- getMessageRender
|
||||
permissionDenied $ mr msg
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgs :: Failure ErrorResponse m => [Text] -> m a
|
||||
invalidArgs = failure . InvalidArgs
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a
|
||||
invalidArgsI msg = do
|
||||
mr <- getMessageRender
|
||||
invalidArgs $ map mr msg
|
||||
|
||||
------- Headers
|
||||
-- | Set the cookie on the client.
|
||||
setCookie :: Monad mo
|
||||
=> Int -- ^ minutes to timeout
|
||||
-> H.Ascii -- ^ key
|
||||
-> H.Ascii -- ^ value
|
||||
-> GGHandler sub master mo ()
|
||||
setCookie a b = addHeader . AddCookie a b
|
||||
|
||||
-- | Unset the cookie on the client.
|
||||
deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
|
||||
deleteCookie = addHeader . DeleteCookie
|
||||
|
||||
-- | Set the language in the user session. Will show up in 'languages' on the
|
||||
-- next request.
|
||||
setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
setLanguage = setSession langKey
|
||||
|
||||
-- | Set an arbitrary response header.
|
||||
setHeader :: Monad mo
|
||||
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
|
||||
setHeader a = addHeader . Header a
|
||||
|
||||
-- | Set the Cache-Control header to indicate this response should be cached
|
||||
-- for the given number of seconds.
|
||||
cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
|
||||
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
|
||||
[ "max-age="
|
||||
, show i
|
||||
, ", public"
|
||||
]
|
||||
|
||||
-- | Set the Expires header to some date in 2037. In other words, this content
|
||||
-- is never (realistically) expired.
|
||||
neverExpires :: Monad mo => GGHandler s m mo ()
|
||||
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
|
||||
|
||||
-- | Set an Expires header in the past, meaning this content should not be
|
||||
-- cached.
|
||||
alreadyExpired :: Monad mo => GGHandler s m mo ()
|
||||
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
||||
|
||||
-- | Set an Expires header to the given date.
|
||||
expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
|
||||
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
|
||||
|
||||
-- | Set a variable in the user's session.
|
||||
--
|
||||
-- The session is handled by the clientsession package: it sets an encrypted
|
||||
-- and hashed cookie on the client. This ensures that all data is secure and
|
||||
-- not tampered with.
|
||||
setSession :: Monad mo
|
||||
=> Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GGHandler sub master mo ()
|
||||
setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
|
||||
|
||||
-- | Unsets a session variable. See 'setSession'.
|
||||
deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
|
||||
deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
|
||||
|
||||
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
|
||||
modSession f x = x { ghsSession = f $ ghsSession x }
|
||||
|
||||
-- | Internal use only, not to be confused with 'setHeader'.
|
||||
addHeader :: Monad mo => Header -> GGHandler sub master mo ()
|
||||
addHeader = GHandler . lift . lift . tell . Endo . (:)
|
||||
|
||||
getStatus :: ErrorResponse -> H.Status
|
||||
getStatus NotFound = H.status404
|
||||
getStatus (InternalError _) = H.status500
|
||||
getStatus (InvalidArgs _) = H.status400
|
||||
getStatus (PermissionDenied _) = H.status403
|
||||
getStatus (BadMethod _) = H.status405
|
||||
|
||||
getRedirectStatus :: RedirectType -> H.Status
|
||||
getRedirectStatus RedirectPermanent = H.status301
|
||||
getRedirectStatus RedirectTemporary = H.status302
|
||||
getRedirectStatus RedirectSeeOther = H.status303
|
||||
|
||||
-- | Different types of redirects.
|
||||
data RedirectType = RedirectPermanent
|
||||
| RedirectTemporary
|
||||
| RedirectSeeOther
|
||||
deriving (Show, Eq)
|
||||
|
||||
localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a
|
||||
localNoCurrent =
|
||||
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
|
||||
|
||||
-- | Lookup for session data.
|
||||
lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
|
||||
lookupSession n = GHandler $ do
|
||||
m <- liftM ghsSession $ lift $ lift $ lift get
|
||||
return $ Map.lookup n m
|
||||
|
||||
-- | Get all session variables.
|
||||
getSession :: Monad mo => GGHandler s m mo SessionMap
|
||||
getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
|
||||
|
||||
handlerToYAR :: (HasReps a, HasReps b)
|
||||
=> m -- ^ master site foundation
|
||||
-> s -- ^ sub site foundation
|
||||
-> (Route s -> Route m)
|
||||
-> (Route m -> [(Text, Text)] -> Text)
|
||||
-> (ErrorResponse -> GHandler s m a)
|
||||
-> Request
|
||||
-> Maybe (Route s)
|
||||
-> SessionMap
|
||||
-> GHandler s m b
|
||||
-> Iteratee ByteString IO YesodAppResult
|
||||
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
|
||||
unYesodApp ya eh' rr types sessionMap
|
||||
where
|
||||
ya = runHandler h render murl toMasterRoute y s
|
||||
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
|
||||
types = httpAccept $ reqWaiRequest rr
|
||||
errorHandler' = localNoCurrent . errorHandler
|
||||
|
||||
type HeaderRenderer = [Header]
|
||||
-> ContentType
|
||||
-> SessionMap
|
||||
-> [(CI H.Ascii, H.Ascii)]
|
||||
|
||||
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
|
||||
yarToResponse _ (YARWai a) = a
|
||||
yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
|
||||
case c of
|
||||
ContentBuilder b mlen ->
|
||||
let hs' = maybe finalHeaders finalHeaders' mlen
|
||||
in W.ResponseBuilder s hs' b
|
||||
ContentFile fp p -> W.ResponseFile s finalHeaders fp p
|
||||
ContentEnum e ->
|
||||
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
|
||||
where
|
||||
finalHeaders = renderHeaders hs ct sessionFinal
|
||||
finalHeaders' len = ("Content-Length", S8.pack $ show len)
|
||||
: finalHeaders
|
||||
{-
|
||||
getExpires m = fromIntegral (m * 60) `addUTCTime` now
|
||||
sessionVal =
|
||||
case key' of
|
||||
Nothing -> B.empty
|
||||
Just key'' -> encodeSession key'' exp' host
|
||||
$ Map.toList
|
||||
$ Map.insert nonceKey (reqNonce rr) sessionFinal
|
||||
hs' =
|
||||
case key' of
|
||||
Nothing -> hs
|
||||
Just _ -> AddCookie
|
||||
(clientSessionDuration y)
|
||||
sessionName
|
||||
(bsToChars sessionVal)
|
||||
: hs
|
||||
hs'' = map (headerToPair getExpires) hs'
|
||||
hs''' = ("Content-Type", charsToBs ct) : hs''
|
||||
-}
|
||||
|
||||
httpAccept :: W.Request -> [ContentType]
|
||||
httpAccept = parseHttpAccept
|
||||
. fromMaybe mempty
|
||||
. lookup "Accept"
|
||||
. W.requestHeaders
|
||||
|
||||
-- | Convert Header to a key/value pair.
|
||||
headerToPair :: S.ByteString -- ^ cookie path
|
||||
-> (Int -> UTCTime) -- ^ minutes -> expiration time
|
||||
-> Header
|
||||
-> (CI H.Ascii, H.Ascii)
|
||||
headerToPair cp getExpires (AddCookie minutes key value) =
|
||||
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
|
||||
{ setCookieName = key
|
||||
, setCookieValue = value
|
||||
, setCookiePath = Just cp
|
||||
, setCookieExpires =
|
||||
if minutes == 0
|
||||
then Nothing
|
||||
else Just $ getExpires minutes
|
||||
, setCookieDomain = Nothing
|
||||
, setCookieHttpOnly = True
|
||||
})
|
||||
headerToPair cp _ (DeleteCookie key) =
|
||||
( "Set-Cookie"
|
||||
, key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
|
||||
)
|
||||
headerToPair _ _ (Header key value) = (key, value)
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text
|
||||
newIdent = GHandler $ lift $ lift $ lift $ do
|
||||
x <- get
|
||||
let i' = ghsIdent x + 1
|
||||
put x { ghsIdent = i' }
|
||||
return $ 'h' : show i'
|
||||
|
||||
liftIOHandler :: MonadIO mo
|
||||
=> GGHandler sub master IO a
|
||||
-> GGHandler sub master mo a
|
||||
liftIOHandler m = GHandler $
|
||||
ReaderT $ \r ->
|
||||
ErrorT $
|
||||
WriterT $
|
||||
StateT $ \s ->
|
||||
liftIO $ runGGHandler m r s
|
||||
|
||||
runGGHandler :: GGHandler sub master m a
|
||||
-> HandlerData sub master
|
||||
-> GHState
|
||||
-> m ( ( Either HandlerContents a
|
||||
, Endo [Header]
|
||||
)
|
||||
, GHState
|
||||
)
|
||||
runGGHandler m r s = runStateT
|
||||
(runWriterT
|
||||
(runErrorT
|
||||
(runReaderT
|
||||
(unGHandler m) r))) s
|
||||
|
||||
instance MonadTransControl (GGHandler s m) where
|
||||
liftControl f =
|
||||
GHandler $
|
||||
liftControl $ \runRdr ->
|
||||
liftControl $ \runErr ->
|
||||
liftControl $ \runWrt ->
|
||||
liftControl $ \runSt ->
|
||||
f ( liftM ( GHandler
|
||||
. join . lift
|
||||
. join . lift
|
||||
. join . lift
|
||||
)
|
||||
. runSt . runWrt . runErr . runRdr
|
||||
. unGHandler
|
||||
)
|
||||
|
||||
-- | Redirect to a POST resource.
|
||||
--
|
||||
-- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
-- POST form, and some Javascript to automatically submit the form. This can be
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- changes on the server.
|
||||
redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a
|
||||
redirectToPost dest = hamletToRepHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
\<!DOCTYPE html>
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>Redirecting...
|
||||
<body onload="document.getElementById('form').submit()">
|
||||
<form id="form" method="post" action="@{dest}">
|
||||
<noscript>
|
||||
<p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
<input type="submit" value="Continue">
|
||||
|] >>= sendResponse
|
||||
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: Monad mo
|
||||
=> Hamlet (Route master) -> GGHandler sub master mo Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Monad mo
|
||||
=> Hamlet (Route master) -> GGHandler sub master mo RepHtml
|
||||
hamletToRepHtml = liftM RepHtml . hamletToContent
|
||||
|
||||
-- | Get the request\'s 'W.Request' value.
|
||||
waiRequest :: Monad mo => GGHandler sub master mo W.Request
|
||||
waiRequest = reqWaiRequest `liftM` getRequest
|
||||
|
||||
getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)
|
||||
getMessageRender = do
|
||||
m <- getYesod
|
||||
l <- reqLangs `liftM` getRequest
|
||||
return $ renderMessage m l
|
||||
128
yesod-core/Yesod/Internal.hs
Normal file
128
yesod-core/Yesod/Internal.hs
Normal file
@ -0,0 +1,128 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
-- | Normal users should never need access to these.
|
||||
module Yesod.Internal
|
||||
( -- * Error responses
|
||||
ErrorResponse (..)
|
||||
-- * Header
|
||||
, Header (..)
|
||||
-- * Cookie names
|
||||
, langKey
|
||||
-- * Widgets
|
||||
, GWData (..)
|
||||
, Location (..)
|
||||
, UniqueList (..)
|
||||
, Script (..)
|
||||
, Stylesheet (..)
|
||||
, Title (..)
|
||||
, Head (..)
|
||||
, Body (..)
|
||||
, locationToHamlet
|
||||
, runUniqueList
|
||||
, toUnique
|
||||
-- * Names
|
||||
, sessionName
|
||||
, nonceKey
|
||||
) where
|
||||
|
||||
import Text.Hamlet (Hamlet, hamlet, Html)
|
||||
import Text.Cassius (Cassius)
|
||||
import Text.Julius (Julius)
|
||||
import Data.Monoid (Monoid (..), Last)
|
||||
import Data.List (nub)
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
import Control.Exception (Exception)
|
||||
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types as A
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.String (IsString)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
-- | Responses to indicate some form of an error occurred. These are different
|
||||
-- from 'SpecialResponse' in that they allow for custom error pages.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
deriving (Show, Eq, Typeable)
|
||||
instance Exception ErrorResponse
|
||||
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie Int A.Ascii A.Ascii
|
||||
| DeleteCookie A.Ascii
|
||||
| Header (CI A.Ascii) A.Ascii
|
||||
deriving (Eq, Show)
|
||||
|
||||
langKey :: IsString a => a
|
||||
langKey = "_LANG"
|
||||
|
||||
data Location url = Local url | Remote Text
|
||||
deriving (Show, Eq)
|
||||
locationToHamlet :: Location url -> Hamlet url
|
||||
locationToHamlet (Local url) = [HAMLET|\@{url}
|
||||
|]
|
||||
locationToHamlet (Remote s) = [HAMLET|\#{s}
|
||||
|]
|
||||
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
instance Monoid (UniqueList x) where
|
||||
mempty = UniqueList id
|
||||
UniqueList x `mappend` UniqueList y = UniqueList $ x . y
|
||||
runUniqueList :: Eq x => UniqueList x -> [x]
|
||||
runUniqueList (UniqueList x) = nub $ x []
|
||||
toUnique :: x -> UniqueList x
|
||||
toUnique = UniqueList . (:)
|
||||
|
||||
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
|
||||
newtype Head url = Head (Hamlet url)
|
||||
deriving Monoid
|
||||
newtype Body url = Body (Hamlet url)
|
||||
deriving Monoid
|
||||
|
||||
nonceKey :: IsString a => a
|
||||
nonceKey = "_NONCE"
|
||||
|
||||
sessionName :: IsString a => a
|
||||
sessionName = "_SESSION"
|
||||
|
||||
data GWData a = GWData
|
||||
!(Body a)
|
||||
!(Last Title)
|
||||
!(UniqueList (Script a))
|
||||
!(UniqueList (Stylesheet a))
|
||||
!(Map.Map (Maybe Text) (Cassius a)) -- media type
|
||||
!(Maybe (Julius a))
|
||||
!(Head a)
|
||||
instance Monoid (GWData a) where
|
||||
mempty = GWData mempty mempty mempty mempty mempty mempty mempty
|
||||
mappend (GWData a1 a2 a3 a4 a5 a6 a7)
|
||||
(GWData b1 b2 b3 b4 b5 b6 b7) = GWData
|
||||
(a1 `mappend` b1)
|
||||
(a2 `mappend` b2)
|
||||
(a3 `mappend` b3)
|
||||
(a4 `mappend` b4)
|
||||
(Map.unionWith mappend a5 b5)
|
||||
(a6 `mappend` b6)
|
||||
(a7 `mappend` b7)
|
||||
575
yesod-core/Yesod/Internal/Core.hs
Normal file
575
yesod-core/Yesod/Internal/Core.hs
Normal file
@ -0,0 +1,575 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- | The basic typeclass for a Yesod application.
|
||||
module Yesod.Internal.Core
|
||||
( -- * Type classes
|
||||
Yesod (..)
|
||||
, YesodDispatch (..)
|
||||
, RenderRoute (..)
|
||||
-- ** Breadcrumbs
|
||||
, YesodBreadcrumbs (..)
|
||||
, breadcrumbs
|
||||
-- * Utitlities
|
||||
, maybeAuthorized
|
||||
, widgetToPageContent
|
||||
-- * Defaults
|
||||
, defaultErrorHandler
|
||||
-- * Data types
|
||||
, AuthResult (..)
|
||||
-- * Logging
|
||||
, LogLevel (..)
|
||||
, formatLogMessage
|
||||
, messageLoggerHandler
|
||||
-- * Misc
|
||||
, yesodVersion
|
||||
, yesodRender
|
||||
) where
|
||||
|
||||
import Yesod.Content
|
||||
import Yesod.Handler
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Monad (forM)
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import Yesod.Widget
|
||||
import Yesod.Request
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Internal
|
||||
import Yesod.Internal.Session
|
||||
import Yesod.Internal.Request
|
||||
import Web.ClientSession (getKey, defaultKeyFile)
|
||||
import qualified Web.ClientSession as CS
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Monoid
|
||||
import Control.Monad.Trans.RWS
|
||||
import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Blaze ((!), customAttribute, textTag, toValue)
|
||||
import qualified Text.Blaze.Html5 as TBH
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Web.Cookie (parseCookies)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Data.Text as TS
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import qualified Data.Text.Encoding.Error as TEE
|
||||
import Blaze.ByteString.Builder (Builder, toByteString)
|
||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||
import Data.List (foldl')
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.IO
|
||||
import qualified System.IO
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
|
||||
import Text.Blaze (preEscapedLazyText)
|
||||
|
||||
#if GHC7
|
||||
#define HAMLET hamlet
|
||||
#else
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
class Eq u => RenderRoute u where
|
||||
renderRoute :: u -> ([Text], [(Text, Text)])
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
class YesodDispatch a master where
|
||||
yesodDispatch
|
||||
:: Yesod master
|
||||
=> a
|
||||
-> Maybe CS.Key
|
||||
-> [Text]
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> Maybe W.Application
|
||||
|
||||
yesodRunner :: Yesod master
|
||||
=> a
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
|
||||
yesodRunner = defaultYesodRunner
|
||||
|
||||
-- | Define settings for a Yesod applications. The only required setting is
|
||||
-- 'approot'; other than that, there are intelligent defaults.
|
||||
class RenderRoute (Route a) => Yesod a where
|
||||
-- | An absolute URL to the root of the application. Do not include
|
||||
-- trailing slash.
|
||||
--
|
||||
-- If you want to be lazy, you can supply an empty string under the
|
||||
-- following conditions:
|
||||
--
|
||||
-- * Your application is served from the root of the domain.
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
approot :: a -> Text
|
||||
|
||||
-- | The encryption key to be used for encrypting client sessions.
|
||||
-- Returning 'Nothing' disables sessions.
|
||||
encryptKey :: a -> IO (Maybe CS.Key)
|
||||
encryptKey _ = fmap Just $ getKey defaultKeyFile
|
||||
|
||||
-- | Number of minutes before a client session times out. Defaults to
|
||||
-- 120 (2 hours).
|
||||
clientSessionDuration :: a -> Int
|
||||
clientSessionDuration = const 120
|
||||
|
||||
-- | Output error response pages.
|
||||
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
|
||||
errorHandler = defaultErrorHandler
|
||||
|
||||
-- | Applies some form of layout to the contents of a page.
|
||||
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
|
||||
defaultLayout w = do
|
||||
p <- widgetToPageContent w
|
||||
mmsg <- getMessage
|
||||
hamletToRepHtml [HAMLET|
|
||||
!!!
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>#{pageTitle p}
|
||||
^{pageHead p}
|
||||
<body>
|
||||
$maybe msg <- mmsg
|
||||
<p .message>#{msg}
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
-- sending cookies.
|
||||
urlRenderOverride :: a -> Route a -> Maybe Builder
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- | Determine if a request is authorized or not.
|
||||
--
|
||||
-- Return 'Nothing' is the request is authorized, 'Just' a message if
|
||||
-- unauthorized. If authentication is required, you should use a redirect;
|
||||
-- the Auth helper provides this functionality automatically.
|
||||
isAuthorized :: Route a
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> GHandler s a AuthResult
|
||||
isAuthorized _ _ = return Authorized
|
||||
|
||||
-- | Determines whether the current request is a write request. By default,
|
||||
-- this assumes you are following RESTful principles, and determines this
|
||||
-- from request method. In particular, all except the following request
|
||||
-- methods are considered write: GET HEAD OPTIONS TRACE.
|
||||
--
|
||||
-- This function is used to determine if a request is authorized; see
|
||||
-- 'isAuthorized'.
|
||||
isWriteRequest :: Route a -> GHandler s a Bool
|
||||
isWriteRequest _ = do
|
||||
wai <- waiRequest
|
||||
return $ W.requestMethod wai `notElem`
|
||||
["GET", "HEAD", "OPTIONS", "TRACE"]
|
||||
|
||||
-- | The default route for authentication.
|
||||
--
|
||||
-- Used in particular by 'isAuthorized', but library users can do whatever
|
||||
-- they want with it.
|
||||
authRoute :: a -> Maybe (Route a)
|
||||
authRoute _ = Nothing
|
||||
|
||||
-- | A function used to clean up path segments. It returns 'Right' with a
|
||||
-- clean path or 'Left' with a new set of pieces the user should be
|
||||
-- redirected to. The default implementation enforces:
|
||||
--
|
||||
-- * No double slashes
|
||||
--
|
||||
-- * There is no trailing slash.
|
||||
--
|
||||
-- Note that versions of Yesod prior to 0.7 used a different set of rules
|
||||
-- involing trailing slashes.
|
||||
cleanPath :: a -> [Text] -> Either [Text] [Text]
|
||||
cleanPath _ s =
|
||||
if corrected == s
|
||||
then Right s
|
||||
else Left corrected
|
||||
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'.
|
||||
joinPath :: a
|
||||
-> TS.Text -- ^ application root
|
||||
-> [TS.Text] -- ^ path pieces
|
||||
-> [(TS.Text, TS.Text)] -- ^ query string
|
||||
-> Builder
|
||||
joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs
|
||||
where
|
||||
pieces = if null pieces' then [""] else pieces'
|
||||
qs = map (TE.encodeUtf8 *** go) qs'
|
||||
go "" = Nothing
|
||||
go x = Just $ TE.encodeUtf8 x
|
||||
|
||||
-- | This function is used to store some static content to be served as an
|
||||
-- external file. The most common case of this is stashing CSS and
|
||||
-- JavaScript content in an external file; the "Yesod.Widget" module uses
|
||||
-- this feature.
|
||||
--
|
||||
-- The return value is 'Nothing' if no storing was performed; this is the
|
||||
-- default implementation. A 'Just' 'Left' gives the absolute URL of the
|
||||
-- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is
|
||||
-- necessary when you are serving the content outside the context of a
|
||||
-- Yesod application, such as via memcached.
|
||||
addStaticContent :: Text -- ^ filename extension
|
||||
-> Text -- ^ mime-type
|
||||
-> L.ByteString -- ^ content
|
||||
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
|
||||
addStaticContent _ _ _ = return Nothing
|
||||
|
||||
-- | Whether or not to tie a session to a specific IP address. Defaults to
|
||||
-- 'True'.
|
||||
sessionIpAddress :: a -> Bool
|
||||
sessionIpAddress _ = True
|
||||
|
||||
-- | The path value to set for cookies. By default, uses \"\/\", meaning
|
||||
-- cookies will be sent to every page on the current domain.
|
||||
cookiePath :: a -> S8.ByteString
|
||||
cookiePath _ = "/"
|
||||
|
||||
-- | Maximum allowed length of the request body, in bytes.
|
||||
maximumContentLength :: a -> Maybe (Route a) -> Int
|
||||
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
|
||||
|
||||
-- | Send a message to the log. By default, prints to stderr.
|
||||
messageLogger :: a
|
||||
-> Loc -- ^ position in source code
|
||||
-> LogLevel
|
||||
-> Text -- ^ message
|
||||
-> IO ()
|
||||
messageLogger _ loc level msg =
|
||||
formatLogMessage loc level msg >>=
|
||||
Data.Text.Lazy.IO.hPutStrLn System.IO.stderr
|
||||
|
||||
messageLoggerHandler :: (Yesod m, MonadIO mo)
|
||||
=> Loc -> LogLevel -> Text -> GGHandler s m mo ()
|
||||
messageLoggerHandler loc level msg = do
|
||||
y <- getYesod
|
||||
liftIO $ messageLogger y loc level msg
|
||||
|
||||
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
|
||||
deriving (Eq, Show, Read, Ord)
|
||||
|
||||
instance Lift LogLevel where
|
||||
lift LevelDebug = [|LevelDebug|]
|
||||
lift LevelInfo = [|LevelInfo|]
|
||||
lift LevelWarn = [|LevelWarn|]
|
||||
lift LevelError = [|LevelError|]
|
||||
lift (LevelOther x) = [|LevelOther $ TS.pack $(lift $ TS.unpack x)|]
|
||||
|
||||
formatLogMessage :: Loc
|
||||
-> LogLevel
|
||||
-> Text -- ^ message
|
||||
-> IO TL.Text
|
||||
formatLogMessage loc level msg = do
|
||||
now <- getCurrentTime
|
||||
return $ TB.toLazyText $
|
||||
TB.fromText (TS.pack $ show now)
|
||||
`mappend` TB.fromText ": "
|
||||
`mappend` TB.fromText (TS.pack $ show level)
|
||||
`mappend` TB.fromText "@("
|
||||
`mappend` TB.fromText (TS.pack $ loc_filename loc)
|
||||
`mappend` TB.fromText ":"
|
||||
`mappend` TB.fromText (TS.pack $ show $ fst $ loc_start loc)
|
||||
`mappend` TB.fromText ") "
|
||||
`mappend` TB.fromText msg
|
||||
|
||||
defaultYesodRunner :: Yesod master
|
||||
=> a
|
||||
-> master
|
||||
-> (Route a -> Route master)
|
||||
-> Maybe CS.Key
|
||||
-> Maybe (Route a)
|
||||
-> GHandler a master ChooseRep
|
||||
-> W.Application
|
||||
defaultYesodRunner _ m toMaster _ murl _ req
|
||||
| maximumContentLength m (fmap toMaster murl) < len =
|
||||
return $ W.responseLBS
|
||||
(H.Status 413 "Too Large")
|
||||
[("Content-Type", "text/plain")]
|
||||
"Request body too large to be processed."
|
||||
where
|
||||
len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
|
||||
readMay s =
|
||||
case reads $ S8.unpack s of
|
||||
[] -> Nothing
|
||||
(x, _):_ -> Just x
|
||||
defaultYesodRunner s master toMasterRoute mkey murl handler req = do
|
||||
now <- liftIO getCurrentTime
|
||||
let getExpires m = fromIntegral (m * 60) `addUTCTime` now
|
||||
let exp' = getExpires $ clientSessionDuration master
|
||||
let rh = takeWhile (/= ':') $ show $ W.remoteHost req
|
||||
let host = if sessionIpAddress master then S8.pack rh else ""
|
||||
let session' =
|
||||
case mkey of
|
||||
Nothing -> []
|
||||
Just key -> fromMaybe [] $ do
|
||||
raw <- lookup "Cookie" $ W.requestHeaders req
|
||||
val <- lookup sessionName $ parseCookies raw
|
||||
decodeSession key now host val
|
||||
rr <- liftIO $ parseWaiRequest req session' mkey
|
||||
let h = do
|
||||
case murl of
|
||||
Nothing -> handler
|
||||
Just url -> do
|
||||
isWrite <- isWriteRequest $ toMasterRoute url
|
||||
ar <- isAuthorized (toMasterRoute url) isWrite
|
||||
case ar of
|
||||
Authorized -> return ()
|
||||
AuthenticationRequired ->
|
||||
case authRoute master of
|
||||
Nothing ->
|
||||
permissionDenied "Authentication required"
|
||||
Just url' -> do
|
||||
setUltDest'
|
||||
redirect RedirectTemporary url'
|
||||
Unauthorized s' -> permissionDenied s'
|
||||
handler
|
||||
let sessionMap = Map.fromList
|
||||
$ filter (\(x, _) -> x /= nonceKey) session'
|
||||
yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
|
||||
let mnonce = reqNonce rr
|
||||
return $ yarToResponse (hr mnonce getExpires host exp') yar
|
||||
where
|
||||
hr mnonce getExpires host exp' hs ct sm =
|
||||
hs'''
|
||||
where
|
||||
sessionVal =
|
||||
case (mkey, mnonce) of
|
||||
(Just key, Just nonce)
|
||||
-> encodeSession key exp' host
|
||||
$ Map.toList
|
||||
$ Map.insert nonceKey nonce sm
|
||||
_ -> mempty
|
||||
hs' =
|
||||
case mkey of
|
||||
Nothing -> hs
|
||||
Just _ -> AddCookie
|
||||
(clientSessionDuration master)
|
||||
sessionName
|
||||
sessionVal
|
||||
: hs
|
||||
hs'' = map (headerToPair (cookiePath master) getExpires) hs'
|
||||
hs''' = ("Content-Type", ct) : hs''
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
|
||||
-- resource, you declare the title of the page and the parent resource (if
|
||||
-- present).
|
||||
class YesodBreadcrumbs y where
|
||||
-- | Returns the title and the parent resource, if available. If you return
|
||||
-- a 'Nothing', then this is considered a top-level page.
|
||||
breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))
|
||||
|
||||
-- | Gets the title of the current page and the hierarchy of parent pages,
|
||||
-- along with their respective titles.
|
||||
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])
|
||||
breadcrumbs = do
|
||||
x' <- getCurrentRoute
|
||||
tm <- getRouteToMaster
|
||||
let x = fmap tm x'
|
||||
case x of
|
||||
Nothing -> return ("Not found", [])
|
||||
Just y -> do
|
||||
(title, next) <- breadcrumb y
|
||||
z <- go [] next
|
||||
return (title, z)
|
||||
where
|
||||
go back Nothing = return back
|
||||
go back (Just this) = do
|
||||
(title, next) <- breadcrumb this
|
||||
go ((this, title) : back) next
|
||||
|
||||
applyLayout' :: Yesod master
|
||||
=> Html -- ^ title
|
||||
-> Hamlet (Route master) -- ^ body
|
||||
-> GHandler sub master ChooseRep
|
||||
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
|
||||
setTitle title
|
||||
addHamlet body
|
||||
|
||||
-- | The default error handler for 'errorHandler'.
|
||||
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
|
||||
defaultErrorHandler NotFound = do
|
||||
r <- waiRequest
|
||||
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
|
||||
applyLayout' "Not Found"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Not Found
|
||||
<p>#{path'}
|
||||
|]
|
||||
defaultErrorHandler (PermissionDenied msg) =
|
||||
applyLayout' "Permission Denied"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Permission denied
|
||||
<p>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Invalid Arguments
|
||||
<ul>
|
||||
$forall msg <- ia
|
||||
<li>#{msg}
|
||||
|]
|
||||
defaultErrorHandler (InternalError e) =
|
||||
applyLayout' "Internal Server Error"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Internal Server Error
|
||||
<p>#{e}
|
||||
|]
|
||||
defaultErrorHandler (BadMethod m) =
|
||||
applyLayout' "Bad Method"
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
<h1>Method Not Supported
|
||||
<p>Method "#{S8.unpack m}" not supported
|
||||
|]
|
||||
|
||||
-- | Return the same URL if the user is authorized to see it.
|
||||
--
|
||||
-- Built on top of 'isAuthorized'. This is useful for building page that only
|
||||
-- contain links to pages the user is allowed to see.
|
||||
maybeAuthorized :: Yesod a
|
||||
=> Route a
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> GHandler s a (Maybe (Route a))
|
||||
maybeAuthorized r isWrite = do
|
||||
x <- isAuthorized r isWrite
|
||||
return $ if x == Authorized then Just r else Nothing
|
||||
|
||||
-- | 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
|
||||
((), _, 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 :: Julius url -> Hamlet url
|
||||
jelper = fmap jsToHtml
|
||||
|
||||
render <- getUrlRenderParams
|
||||
let renderLoc x =
|
||||
case x of
|
||||
Nothing -> Nothing
|
||||
Just (Left s) -> Just s
|
||||
Just (Right (u, p)) -> Just $ render u p
|
||||
css <- forM (Map.toList style) $ \(mmedia, content) -> do
|
||||
let rendered = renderCassius render content
|
||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
||||
$ encodeUtf8 rendered
|
||||
return (mmedia,
|
||||
case x of
|
||||
Nothing -> Left $ preEscapedLazyText rendered
|
||||
Just y -> Right $ either id (uncurry render) y)
|
||||
jsLoc <-
|
||||
case jscript of
|
||||
Nothing -> return Nothing
|
||||
Just s -> do
|
||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
||||
$ encodeUtf8 $ renderJulius render s
|
||||
return $ renderLoc x
|
||||
|
||||
let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
|
||||
let renderLoc' render' (Local url) = render' url []
|
||||
renderLoc' _ (Remote s) = s
|
||||
let mkScriptTag (Script loc attrs) render' =
|
||||
foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
|
||||
let mkLinkTag (Stylesheet loc attrs) render' =
|
||||
foldl' addAttr TBH.link
|
||||
( ("rel", "stylesheet")
|
||||
: ("href", renderLoc' render' loc)
|
||||
: attrs
|
||||
)
|
||||
let left (Left x) = Just x
|
||||
left _ = Nothing
|
||||
right (Right x) = Just x
|
||||
right _ = Nothing
|
||||
let head'' =
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
$forall s <- stylesheets
|
||||
^{mkLinkTag s}
|
||||
$forall s <- css
|
||||
$maybe t <- right $ snd s
|
||||
$maybe media <- fst s
|
||||
<link rel=stylesheet media=#{media} href=#{t}
|
||||
$nothing
|
||||
<link rel=stylesheet href=#{t}
|
||||
$maybe content <- left $ snd s
|
||||
$maybe media <- fst s
|
||||
<style media=#{media}>#{content}
|
||||
$nothing
|
||||
<style>#{content}
|
||||
$forall s <- scripts
|
||||
^{mkScriptTag s}
|
||||
$maybe j <- jscript
|
||||
$maybe s <- jsLoc
|
||||
<script src="#{s}">
|
||||
$nothing
|
||||
<script>^{jelper j}
|
||||
\^{head'}
|
||||
|]
|
||||
return $ PageContent title head'' body
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
|
||||
yesodRender :: Yesod y
|
||||
=> y
|
||||
-> Route y
|
||||
-> [(Text, Text)]
|
||||
-> Text
|
||||
yesodRender y u qs =
|
||||
TE.decodeUtf8 $ toByteString $
|
||||
fromMaybe
|
||||
(joinPath y (approot y) ps
|
||||
$ qs ++ qs')
|
||||
(urlRenderOverride y u)
|
||||
where
|
||||
(ps, qs') = renderRoute u
|
||||
322
yesod-core/Yesod/Internal/Dispatch.hs
Normal file
322
yesod-core/Yesod/Internal/Dispatch.hs
Normal file
@ -0,0 +1,322 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | A bunch of Template Haskell used in the Yesod.Dispatch module.
|
||||
module Yesod.Internal.Dispatch
|
||||
( mkYesodDispatch'
|
||||
) where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Web.PathPieces
|
||||
import Yesod.Internal.RouteParsing
|
||||
import Control.Monad (foldM)
|
||||
import Yesod.Handler (badMethod)
|
||||
import Yesod.Content (chooseRep)
|
||||
import qualified Network.Wai as W
|
||||
import Yesod.Internal.Core (yesodRunner, yesodDispatch)
|
||||
import Data.List (foldl')
|
||||
import Data.Char (toLower)
|
||||
import qualified Data.ByteString as S
|
||||
import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))
|
||||
import Network.HTTP.Types (status301)
|
||||
import Data.Text (Text)
|
||||
import Data.Monoid (mappend)
|
||||
import qualified Blaze.ByteString.Builder
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.Text
|
||||
|
||||
{-|
|
||||
|
||||
Alright, let's explain how routing works. We want to take a [String] and found
|
||||
out which route it applies to. For static pieces, we need to ensure an exact
|
||||
match against the segment. For a single or multi piece, we need to check the
|
||||
result of fromSinglePiece/fromMultiPiece, respectively.
|
||||
|
||||
We want to create a tree of case statements basically resembling:
|
||||
|
||||
case testRoute1 of
|
||||
Just app -> Just app
|
||||
Nothing ->
|
||||
case testRoute2 of
|
||||
Just app -> Just app
|
||||
Nothing ->
|
||||
case testRoute3 of
|
||||
Just app -> Just app
|
||||
Nothing -> Nothing
|
||||
|
||||
Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):
|
||||
|
||||
case segments of
|
||||
"name" : as ->
|
||||
case as of
|
||||
[] -> Nothing
|
||||
b:bs ->
|
||||
case fromSinglePiece b of
|
||||
Left _ -> Nothing
|
||||
Right name ->
|
||||
case bs of
|
||||
"age":cs ->
|
||||
case cs of
|
||||
[] -> Nothing
|
||||
d:ds ->
|
||||
case fromSinglePiece d of
|
||||
Left _ -> Nothing
|
||||
Right age ->
|
||||
case ds of
|
||||
[] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
Obviously we would never want to write code by hand like this, but generating it is not too bad.
|
||||
|
||||
This function generates a clause for the yesodDispatch function based on a set of routes.
|
||||
|
||||
NOTE: We deal with subsites first; if none of those match, we try to apply
|
||||
cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
|
||||
local routes.
|
||||
|
||||
-}
|
||||
|
||||
sendRedirect :: Yesod master => master -> [Text] -> W.Application
|
||||
sendRedirect y segments' env =
|
||||
return $ W.responseLBS status301
|
||||
[ ("Content-Type", "text/plain")
|
||||
, ("Location", Blaze.ByteString.Builder.toByteString dest')
|
||||
] "Redirecting"
|
||||
where
|
||||
dest = joinPath y (approot y) segments' []
|
||||
dest' =
|
||||
if S.null (W.rawQueryString env)
|
||||
then dest
|
||||
else (dest `mappend`
|
||||
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
|
||||
|
||||
mkYesodDispatch' :: [((String, Pieces), Maybe String)]
|
||||
-> [((String, Pieces), Maybe String)]
|
||||
-> Q Clause
|
||||
mkYesodDispatch' resSub resLoc = do
|
||||
sub <- newName "sub"
|
||||
master <- newName "master"
|
||||
mkey <- newName "mkey"
|
||||
segments <- newName "segments"
|
||||
segments' <- newName "segmentsClean"
|
||||
toMasterRoute <- newName "toMasterRoute"
|
||||
nothing <- [|Nothing|]
|
||||
bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
|
||||
cp <- [|cleanPath|]
|
||||
sr <- [|sendRedirect|]
|
||||
just <- [|Just|]
|
||||
let bodyLoc' =
|
||||
CaseE (cp `AppE` VarE master `AppE` VarE segments)
|
||||
[ Match (ConP (mkName "Left") [VarP segments'])
|
||||
(NormalB $ just `AppE`
|
||||
(sr `AppE` VarE master `AppE` VarE segments'))
|
||||
[]
|
||||
, Match (ConP (mkName "Right") [VarP segments'])
|
||||
(NormalB bodyLoc)
|
||||
[]
|
||||
]
|
||||
body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
|
||||
return $ Clause
|
||||
[VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
|
||||
(NormalB body)
|
||||
[]
|
||||
where
|
||||
go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
|
||||
test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
|
||||
app <- newName "app"
|
||||
return $ CaseE test
|
||||
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
|
||||
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
|
||||
]
|
||||
go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
|
||||
test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
|
||||
just <- [|Just|]
|
||||
app <- newName "app"
|
||||
return $ CaseE test
|
||||
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
|
||||
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
|
||||
]
|
||||
go _ _ _ _ _ _ _ = error "Invalid combination"
|
||||
|
||||
mkSimpleExp :: Exp -- ^ segments
|
||||
-> [Piece]
|
||||
-> ([Exp] -> [Exp]) -- ^ variables already parsed
|
||||
-> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods
|
||||
-> Q Exp
|
||||
mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
|
||||
just <- [|Just|]
|
||||
nothing <- [|Nothing|]
|
||||
onSuccess <- newName "onSuccess"
|
||||
req <- newName "req"
|
||||
badMethod' <- [|badMethod|]
|
||||
rm <- [|S8.unpack . W.requestMethod|]
|
||||
let caseExp = rm `AppE` VarE req
|
||||
yr <- [|yesodRunner|]
|
||||
cr <- [|fmap chooseRep|]
|
||||
eq <- [|(==)|]
|
||||
let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
|
||||
let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
|
||||
runHandler' h = yr `AppE` sub
|
||||
`AppE` VarE master
|
||||
`AppE` toMasterRoute
|
||||
`AppE` VarE mkey
|
||||
`AppE` (just `AppE` url)
|
||||
`AppE` h
|
||||
`AppE` VarE req
|
||||
let match :: String -> Q Match
|
||||
match m = do
|
||||
x <- newName "x"
|
||||
return $ Match
|
||||
(VarP x)
|
||||
(GuardedB
|
||||
[ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?
|
||||
, runHandlerVars $ map toLower m ++ constr
|
||||
)
|
||||
])
|
||||
[]
|
||||
clauses <-
|
||||
case methods of
|
||||
[] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
|
||||
_ -> do
|
||||
matches <- mapM match methods
|
||||
return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
|
||||
[Match WildP (NormalB $ runHandler' badMethod') []]) []]
|
||||
let exp = CaseE segments
|
||||
[ Match
|
||||
(ConP (mkName "[]") [])
|
||||
(NormalB $ just `AppE` VarE onSuccess)
|
||||
[FunD onSuccess clauses]
|
||||
, Match
|
||||
WildP
|
||||
(NormalB nothing)
|
||||
[]
|
||||
]
|
||||
return exp
|
||||
mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
|
||||
srest <- newName "segments"
|
||||
innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
|
||||
nothing <- [|Nothing|]
|
||||
y <- newName "y"
|
||||
pack <- [|Data.Text.pack|]
|
||||
eq <- [|(==)|]
|
||||
let exp = CaseE segments
|
||||
[ Match
|
||||
(InfixP (VarP y) (mkName ":") (VarP srest))
|
||||
(GuardedB
|
||||
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
|
||||
, innerExp
|
||||
)
|
||||
])
|
||||
[]
|
||||
, Match WildP (NormalB nothing) []
|
||||
]
|
||||
return exp
|
||||
mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
|
||||
srest <- newName "segments"
|
||||
next' <- newName "next'"
|
||||
innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
next <- newName "next"
|
||||
fsp <- [|fromSinglePiece|]
|
||||
let exp' = CaseE (fsp `AppE` VarE next)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
(NormalB nothing)
|
||||
[]
|
||||
, Match
|
||||
(ConP (mkName "Just") [VarP next'])
|
||||
(NormalB innerExp)
|
||||
[]
|
||||
]
|
||||
let exp = CaseE segments
|
||||
[ Match
|
||||
(InfixP (VarP next) (mkName ":") (VarP srest))
|
||||
(NormalB exp')
|
||||
[]
|
||||
, Match WildP (NormalB nothing) []
|
||||
]
|
||||
return exp
|
||||
mkSimpleExp segments [MultiPiece _] frontVars x = do
|
||||
next' <- newName "next'"
|
||||
srest <- [|[]|]
|
||||
innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
fmp <- [|fromMultiPiece|]
|
||||
let exp = CaseE (fmp `AppE` segments)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
(NormalB nothing)
|
||||
[]
|
||||
, Match
|
||||
(ConP (mkName "Just") [VarP next'])
|
||||
(NormalB innerExp)
|
||||
[]
|
||||
]
|
||||
return exp
|
||||
mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
|
||||
|
||||
mkSubsiteExp :: Name -- ^ segments
|
||||
-> [Piece]
|
||||
-> ([Exp] -> [Exp]) -- ^ variables already parsed
|
||||
-> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
|
||||
-> Q Exp
|
||||
mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
|
||||
yd <- [|yesodDispatch|]
|
||||
dot <- [|(.)|]
|
||||
let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
|
||||
-- proper handling for sub-subsites
|
||||
let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
|
||||
let app = yd `AppE` sub'
|
||||
`AppE` VarE mkey
|
||||
`AppE` VarE segments
|
||||
`AppE` VarE master
|
||||
`AppE` con
|
||||
just <- [|Just|]
|
||||
return $ just `AppE` app
|
||||
mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
|
||||
mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
|
||||
srest <- newName "segments"
|
||||
innerExp <- mkSubsiteExp srest pieces frontVars x
|
||||
nothing <- [|Nothing|]
|
||||
y <- newName "y"
|
||||
pack <- [|Data.Text.pack|]
|
||||
eq <- [|(==)|]
|
||||
let exp = CaseE (VarE segments)
|
||||
[ Match
|
||||
(InfixP (VarP y) (mkName ":") (VarP srest))
|
||||
(GuardedB
|
||||
[ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
|
||||
, innerExp
|
||||
)
|
||||
])
|
||||
[]
|
||||
, Match WildP (NormalB nothing) []
|
||||
]
|
||||
return exp
|
||||
mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
|
||||
srest <- newName "segments"
|
||||
next' <- newName "next'"
|
||||
innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
|
||||
nothing <- [|Nothing|]
|
||||
next <- newName "next"
|
||||
fsp <- [|fromSinglePiece|]
|
||||
let exp' = CaseE (fsp `AppE` VarE next)
|
||||
[ Match
|
||||
(ConP (mkName "Nothing") [])
|
||||
(NormalB nothing)
|
||||
[]
|
||||
, Match
|
||||
(ConP (mkName "Just") [VarP next'])
|
||||
(NormalB innerExp)
|
||||
[]
|
||||
]
|
||||
let exp = CaseE (VarE segments)
|
||||
[ Match
|
||||
(InfixP (VarP next) (mkName ":") (VarP srest))
|
||||
(NormalB exp')
|
||||
[]
|
||||
, Match WildP (NormalB nothing) []
|
||||
]
|
||||
return exp
|
||||
86
yesod-core/Yesod/Internal/Request.hs
Normal file
86
yesod-core/Yesod/Internal/Request.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Internal.Request
|
||||
( parseWaiRequest
|
||||
, Request (..)
|
||||
, RequestBodyContents
|
||||
, FileInfo (..)
|
||||
) where
|
||||
|
||||
import Control.Arrow (first, second)
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import Yesod.Internal
|
||||
import qualified Network.Wai as W
|
||||
import System.Random (randomR, newStdGen)
|
||||
import Web.Cookie (parseCookiesText)
|
||||
import Data.Monoid (mempty)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import Data.Text (Text, pack)
|
||||
import Network.HTTP.Types (queryToQueryText)
|
||||
import Control.Monad (join)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
||||
-- | The parsed request information.
|
||||
data Request = Request
|
||||
{ reqGetParams :: [(Text, Text)]
|
||||
, reqCookies :: [(Text, Text)]
|
||||
, reqWaiRequest :: W.Request
|
||||
-- | Languages which the client supports.
|
||||
, reqLangs :: [Text]
|
||||
-- | A random, session-specific nonce used to prevent CSRF attacks.
|
||||
, reqNonce :: Maybe Text
|
||||
}
|
||||
|
||||
parseWaiRequest :: W.Request
|
||||
-> [(Text, Text)] -- ^ session
|
||||
-> Maybe a
|
||||
-> IO Request
|
||||
parseWaiRequest env session' key' = do
|
||||
let gets' = queryToQueryText $ W.queryString env
|
||||
let reqCookie = fromMaybe mempty $ lookup "Cookie"
|
||||
$ W.requestHeaders env
|
||||
cookies' = parseCookiesText reqCookie
|
||||
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
|
||||
langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
|
||||
langs' = case lookup langKey session' of
|
||||
Nothing -> langs
|
||||
Just x -> x : langs
|
||||
langs'' = case lookup langKey cookies' of
|
||||
Nothing -> langs'
|
||||
Just x -> x : langs'
|
||||
langs''' = case join $ lookup langKey gets' of
|
||||
Nothing -> langs''
|
||||
Just x -> x : langs''
|
||||
nonce <- case (key', lookup nonceKey session') of
|
||||
(Nothing, _) -> return Nothing
|
||||
(_, Just x) -> return $ Just x
|
||||
(_, Nothing) -> do
|
||||
g <- newStdGen
|
||||
return $ Just $ pack $ fst $ randomString 10 g
|
||||
let gets'' = map (second $ fromMaybe "") gets'
|
||||
return $ Request gets'' cookies' env langs''' nonce
|
||||
where
|
||||
randomString len =
|
||||
first (map toChar) . sequence' (replicate len (randomR (0, 61)))
|
||||
sequence' [] g = ([], g)
|
||||
sequence' (f:fs) g =
|
||||
let (f', g') = f g
|
||||
(fs', g'') = sequence' fs g'
|
||||
in (f' : fs', g'')
|
||||
toChar i
|
||||
| i < 26 = toEnum $ i + fromEnum 'A'
|
||||
| i < 52 = toEnum $ i + fromEnum 'a' - 26
|
||||
| otherwise = toEnum $ i + fromEnum '0' - 52
|
||||
|
||||
-- | A tuple containing both the POST parameters and submitted files.
|
||||
type RequestBodyContents =
|
||||
( [(Text, Text)]
|
||||
, [(Text, FileInfo)]
|
||||
)
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ fileName :: Text
|
||||
, fileContentType :: Text
|
||||
, fileContent :: L.ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
349
yesod-core/Yesod/Internal/RouteParsing.hs
Normal file
349
yesod-core/Yesod/Internal/RouteParsing.hs
Normal file
@ -0,0 +1,349 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
module Yesod.Internal.RouteParsing
|
||||
( createRoutes
|
||||
, createRender
|
||||
, createParse
|
||||
, createDispatch
|
||||
, Pieces (..)
|
||||
, THResource
|
||||
, parseRoutes
|
||||
, parseRoutesFile
|
||||
, parseRoutesNoCheck
|
||||
, parseRoutesFileNoCheck
|
||||
, Resource (..)
|
||||
, Piece (..)
|
||||
) where
|
||||
|
||||
import Web.PathPieces
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Char (toLower)
|
||||
import qualified Data.Text
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.Data
|
||||
import Data.Maybe
|
||||
import qualified System.IO as SIO
|
||||
|
||||
data Pieces =
|
||||
SubSite
|
||||
{ ssType :: Type
|
||||
, ssParse :: Exp
|
||||
, ssRender :: Exp
|
||||
, ssDispatch :: Exp
|
||||
, ssToMasterArg :: Exp
|
||||
, ssPieces :: [Piece]
|
||||
}
|
||||
| Simple [Piece] [String] -- ^ methods
|
||||
deriving Show
|
||||
type THResource = (String, Pieces)
|
||||
|
||||
createRoutes :: [THResource] -> Q [Con]
|
||||
createRoutes res =
|
||||
return $ map go res
|
||||
where
|
||||
go (n, SubSite{ssType = s, ssPieces = pieces}) =
|
||||
NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
|
||||
go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
|
||||
go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
|
||||
go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
|
||||
go' (StaticPiece _) = Nothing
|
||||
|
||||
-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
|
||||
createParse :: [THResource] -> Q [Clause]
|
||||
createParse res = do
|
||||
final' <- final
|
||||
clauses <- mapM go res
|
||||
return $ if areResourcesComplete res
|
||||
then clauses
|
||||
else clauses ++ [final']
|
||||
where
|
||||
cons x y = ConP (mkName ":") [x, y]
|
||||
go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
|
||||
ri <- [|Right|]
|
||||
be <- [|ape|]
|
||||
(pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
|
||||
|
||||
x <- newName "x"
|
||||
let pat = init pat' ++ [VarP x]
|
||||
|
||||
--let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
|
||||
let eitherSub = p `AppE` VarE x
|
||||
let bod = be `AppE` parse `AppE` eitherSub
|
||||
--let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
|
||||
return $ Clause [foldr1 cons pat] (NormalB bod) []
|
||||
go (n, Simple ps _) = do
|
||||
ri <- [|Right|]
|
||||
be <- [|ape|]
|
||||
(pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
|
||||
return $ Clause [foldr1 cons pat] (NormalB parse) []
|
||||
final = do
|
||||
no <- [|Left "Invalid URL"|]
|
||||
return $ Clause [WildP] (NormalB no) []
|
||||
mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
|
||||
mkPat' be [MultiPiece s] parse = do
|
||||
v <- newName $ "var" ++ s
|
||||
fmp <- [|fromMultiPiece|]
|
||||
let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
|
||||
return ([VarP v], parse')
|
||||
mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
|
||||
mkPat' be (StaticPiece s:rest) parse = do
|
||||
(x, parse') <- mkPat' be rest parse
|
||||
let sp = LitP $ StringL s
|
||||
return (sp : x, parse')
|
||||
mkPat' be (SinglePiece s:rest) parse = do
|
||||
fsp <- [|fromSinglePiece|]
|
||||
v <- newName $ "var" ++ s
|
||||
let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
|
||||
(x, parse'') <- mkPat' be rest parse'
|
||||
return (VarP v : x, parse'')
|
||||
mkPat' _ [] parse = return ([ListP []], parse)
|
||||
|
||||
-- | 'ap' for 'Either'
|
||||
ape :: Either String (a -> b) -> Either String a -> Either String b
|
||||
ape (Left e) _ = Left e
|
||||
ape (Right _) (Left e) = Left e
|
||||
ape (Right f) (Right a) = Right $ f a
|
||||
|
||||
-- | Generates the set of clauses necesary to render the given 'Resource's. See
|
||||
-- 'quasiRender'.
|
||||
createRender :: [THResource] -> Q [Clause]
|
||||
createRender = mapM go
|
||||
where
|
||||
go (n, Simple ps _) = do
|
||||
let ps' = zip [1..] ps
|
||||
let pat = ConP (mkName n) $ mapMaybe go' ps'
|
||||
bod <- mkBod ps'
|
||||
return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
|
||||
go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
|
||||
cons' <- [|\a (b, c) -> (a ++ b, c)|]
|
||||
let cons a b = cons' `AppE` a `AppE` b
|
||||
x <- newName "x"
|
||||
let r' = r `AppE` VarE x
|
||||
let pieces' = zip [1..] pieces
|
||||
let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
|
||||
bod <- mkBod pieces'
|
||||
return $ Clause [pat] (NormalB $ cons bod r') []
|
||||
go' (_, StaticPiece _) = Nothing
|
||||
go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
|
||||
mkBod :: (Show t) => [(t, Piece)] -> Q Exp
|
||||
mkBod [] = lift ([] :: [String])
|
||||
mkBod ((_, StaticPiece x):xs) = do
|
||||
x' <- lift x
|
||||
pack <- [|Data.Text.pack|]
|
||||
xs' <- mkBod xs
|
||||
return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
|
||||
mkBod ((i, SinglePiece _):xs) = do
|
||||
let x' = VarE $ mkName $ "var" ++ show i
|
||||
tsp <- [|toSinglePiece|]
|
||||
let x'' = tsp `AppE` x'
|
||||
xs' <- mkBod xs
|
||||
return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
|
||||
mkBod ((i, MultiPiece _):_) = do
|
||||
let x' = VarE $ mkName $ "var" ++ show i
|
||||
tmp <- [|toMultiPiece|]
|
||||
return $ tmp `AppE` x'
|
||||
|
||||
-- | Whether the set of resources cover all possible URLs.
|
||||
areResourcesComplete :: [THResource] -> Bool
|
||||
areResourcesComplete res =
|
||||
let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
|
||||
in case slurps of
|
||||
[] -> False
|
||||
_ -> let minSlurp = minimum slurps
|
||||
in helper minSlurp $ reverse $ sort noSlurps
|
||||
where
|
||||
go :: THResource -> Maybe (Either Int Int)
|
||||
go (_, Simple ps _) =
|
||||
case reverse ps of
|
||||
[] -> Just $ Right 0
|
||||
(MultiPiece _:rest) -> go' Left rest
|
||||
x -> go' Right x
|
||||
go (n, SubSite{ssPieces = ps}) =
|
||||
go (n, Simple (ps ++ [MultiPiece ""]) [])
|
||||
go' b x = if all isSingle x then Just (b $ length x) else Nothing
|
||||
helper 0 _ = True
|
||||
helper _ [] = False
|
||||
helper m (i:is)
|
||||
| i >= m = helper m is
|
||||
| i + 1 == m = helper i is
|
||||
| otherwise = False
|
||||
isSingle (SinglePiece _) = True
|
||||
isSingle _ = False
|
||||
|
||||
notStatic :: Piece -> Bool
|
||||
notStatic StaticPiece{} = False
|
||||
notStatic _ = True
|
||||
|
||||
createDispatch :: Exp -- ^ modify a master handler
|
||||
-> Exp -- ^ convert a subsite handler to a master handler
|
||||
-> [THResource]
|
||||
-> Q [Clause]
|
||||
createDispatch modMaster toMaster = mapM go
|
||||
where
|
||||
go :: (String, Pieces) -> Q Clause
|
||||
go (n, Simple ps methods) = do
|
||||
meth <- newName "method"
|
||||
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
|
||||
let pat = [ ConP (mkName n) $ map VarP xs
|
||||
, if null methods then WildP else VarP meth
|
||||
]
|
||||
bod <- go' n meth xs methods
|
||||
return $ Clause pat (NormalB bod) []
|
||||
go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
|
||||
meth <- newName "method"
|
||||
x <- newName "x"
|
||||
xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
|
||||
let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
|
||||
let bod = d `AppE` VarE x `AppE` VarE meth
|
||||
fmap' <- [|fmap|]
|
||||
let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
|
||||
tma' = foldl AppE tma $ map VarE xs
|
||||
let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
|
||||
let bod' = InfixE (Just toMaster') fmap' (Just bod)
|
||||
let bod'' = InfixE (Just modMaster) fmap' (Just bod')
|
||||
return $ Clause pat (NormalB bod'') []
|
||||
go' n _ xs [] = do
|
||||
jus <- [|Just|]
|
||||
let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
|
||||
return $ jus `AppE` (modMaster `AppE` bod)
|
||||
go' n meth xs methods = do
|
||||
noth <- [|Nothing|]
|
||||
j <- [|Just|]
|
||||
let noMatch = Match WildP (NormalB noth) []
|
||||
return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
|
||||
go'' n xs j method =
|
||||
let pat = LitP $ StringL method
|
||||
func = map toLower method ++ n
|
||||
bod = foldl AppE (VarE $ mkName func) $ map VarE xs
|
||||
in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
|
||||
|
||||
-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
|
||||
-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
|
||||
-- checking. See documentation site for details on syntax.
|
||||
parseRoutes :: QuasiQuoter
|
||||
parseRoutes = QuasiQuoter
|
||||
{ quoteExp = x
|
||||
, quotePat = y
|
||||
}
|
||||
where
|
||||
x s = do
|
||||
let res = resourcesFromString s
|
||||
case findOverlaps res of
|
||||
[] -> lift res
|
||||
z -> error $ "Overlapping routes: " ++ unlines (map show z)
|
||||
y = dataToPatQ (const Nothing) . resourcesFromString
|
||||
|
||||
parseRoutesFile :: FilePath -> Q Exp
|
||||
parseRoutesFile fp = do
|
||||
s <- qRunIO $ readUtf8File fp
|
||||
quoteExp parseRoutes s
|
||||
|
||||
parseRoutesFileNoCheck :: FilePath -> Q Exp
|
||||
parseRoutesFileNoCheck fp = do
|
||||
s <- qRunIO $ readUtf8File fp
|
||||
quoteExp parseRoutesNoCheck s
|
||||
|
||||
readUtf8File :: FilePath -> IO String
|
||||
readUtf8File fp = do
|
||||
h <- SIO.openFile fp SIO.ReadMode
|
||||
SIO.hSetEncoding h SIO.utf8_bom
|
||||
SIO.hGetContents h
|
||||
|
||||
-- | Same as 'parseRoutes', but performs no overlap checking.
|
||||
parseRoutesNoCheck :: QuasiQuoter
|
||||
parseRoutesNoCheck = QuasiQuoter
|
||||
{ quoteExp = x
|
||||
, quotePat = y
|
||||
}
|
||||
where
|
||||
x = lift . resourcesFromString
|
||||
y = dataToPatQ (const Nothing) . resourcesFromString
|
||||
|
||||
instance Lift Resource where
|
||||
lift (Resource s ps h) = do
|
||||
r <- [|Resource|]
|
||||
s' <- lift s
|
||||
ps' <- lift ps
|
||||
h' <- lift h
|
||||
return $ r `AppE` s' `AppE` ps' `AppE` h'
|
||||
|
||||
-- | A single resource pattern.
|
||||
--
|
||||
-- First argument is the name of the constructor, second is the URL pattern to
|
||||
-- match, third is how to dispatch.
|
||||
data Resource = Resource String [Piece] [String]
|
||||
deriving (Read, Show, Eq, Data, Typeable)
|
||||
|
||||
-- | A single piece of a URL, delimited by slashes.
|
||||
--
|
||||
-- In the case of StaticPiece, the argument is the value of the piece; for the
|
||||
-- other constructors, it is the name of the parameter represented by this
|
||||
-- piece. That value is not used here, but may be useful elsewhere.
|
||||
data Piece = StaticPiece String
|
||||
| SinglePiece String
|
||||
| MultiPiece String
|
||||
deriving (Read, Show, Eq, Data, Typeable)
|
||||
|
||||
instance Lift Piece where
|
||||
lift (StaticPiece s) = do
|
||||
c <- [|StaticPiece|]
|
||||
s' <- lift s
|
||||
return $ c `AppE` s'
|
||||
lift (SinglePiece s) = do
|
||||
c <- [|SinglePiece|]
|
||||
s' <- lift s
|
||||
return $ c `AppE` s'
|
||||
lift (MultiPiece s) = do
|
||||
c <- [|MultiPiece|]
|
||||
s' <- lift s
|
||||
return $ c `AppE` s'
|
||||
|
||||
-- | Convert a multi-line string to a set of resources. See documentation for
|
||||
-- the format of this string. This is a partial function which calls 'error' on
|
||||
-- invalid input.
|
||||
resourcesFromString :: String -> [Resource]
|
||||
resourcesFromString =
|
||||
mapMaybe go . lines
|
||||
where
|
||||
go s =
|
||||
case takeWhile (/= "--") $ words s of
|
||||
(pattern:constr:rest) ->
|
||||
let pieces = piecesFromString $ drop1Slash pattern
|
||||
in Just $ Resource constr pieces rest
|
||||
[] -> Nothing
|
||||
_ -> error $ "Invalid resource line: " ++ s
|
||||
|
||||
drop1Slash :: String -> String
|
||||
drop1Slash ('/':x) = x
|
||||
drop1Slash x = x
|
||||
|
||||
piecesFromString :: String -> [Piece]
|
||||
piecesFromString "" = []
|
||||
piecesFromString x =
|
||||
let (y, z) = break (== '/') x
|
||||
in pieceFromString y : piecesFromString (drop1Slash z)
|
||||
|
||||
pieceFromString :: String -> Piece
|
||||
pieceFromString ('#':x) = SinglePiece x
|
||||
pieceFromString ('*':x) = MultiPiece x
|
||||
pieceFromString x = StaticPiece x
|
||||
|
||||
findOverlaps :: [Resource] -> [(Resource, Resource)]
|
||||
findOverlaps = gos . map justPieces
|
||||
where
|
||||
justPieces r@(Resource _ ps _) = (ps, r)
|
||||
gos [] = []
|
||||
gos (x:xs) = mapMaybe (go x) xs ++ gos xs
|
||||
go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
|
||||
| x == y = go (xs, xr) (ys, yr)
|
||||
| otherwise = Nothing
|
||||
go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
|
||||
go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
|
||||
go ([], xr) ([], yr) = Just (xr, yr)
|
||||
go ([], _) (_, _) = Nothing
|
||||
go (_, _) ([], _) = Nothing
|
||||
go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)
|
||||
55
yesod-core/Yesod/Internal/Session.hs
Normal file
55
yesod-core/Yesod/Internal/Session.hs
Normal file
@ -0,0 +1,55 @@
|
||||
module Yesod.Internal.Session
|
||||
( encodeSession
|
||||
, decodeSession
|
||||
) where
|
||||
|
||||
import qualified Web.ClientSession as CS
|
||||
import Data.Serialize
|
||||
import Data.Time
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Monad (guard)
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import Control.Arrow ((***))
|
||||
|
||||
encodeSession :: CS.Key
|
||||
-> UTCTime -- ^ expire time
|
||||
-> ByteString -- ^ remote host
|
||||
-> [(Text, Text)] -- ^ session
|
||||
-> ByteString -- ^ cookie value
|
||||
encodeSession key expire rhost session' =
|
||||
CS.encrypt key $ encode $ SessionCookie expire rhost session'
|
||||
|
||||
decodeSession :: CS.Key
|
||||
-> UTCTime -- ^ current time
|
||||
-> ByteString -- ^ remote host field
|
||||
-> ByteString -- ^ cookie value
|
||||
-> Maybe [(Text, Text)]
|
||||
decodeSession key now rhost encrypted = do
|
||||
decrypted <- CS.decrypt key encrypted
|
||||
SessionCookie expire rhost' session' <-
|
||||
either (const Nothing) Just $ decode decrypted
|
||||
guard $ expire > now
|
||||
guard $ rhost' == rhost
|
||||
return session'
|
||||
|
||||
data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)
|
||||
get = do
|
||||
a <- getTime
|
||||
b <- get
|
||||
c <- map (pack *** pack) `fmap` get
|
||||
return $ SessionCookie a b c
|
||||
|
||||
putTime :: Putter UTCTime
|
||||
putTime t@(UTCTime d _) = do
|
||||
put $ toModifiedJulianDay d
|
||||
let ndt = diffUTCTime t $ UTCTime d 0
|
||||
put $ toRational ndt
|
||||
|
||||
getTime :: Get UTCTime
|
||||
getTime = do
|
||||
d <- get
|
||||
ndt <- get
|
||||
return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
|
||||
250
yesod-core/Yesod/Message.hs
Normal file
250
yesod-core/Yesod/Message.hs
Normal file
@ -0,0 +1,250 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
module Yesod.Message
|
||||
( mkMessage
|
||||
, RenderMessage (..)
|
||||
, ToMessage (..)
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Data.Text (Text, pack, unpack)
|
||||
import System.Directory
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.List (isSuffixOf, sortBy, foldl')
|
||||
import qualified Data.ByteString as S
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Char (isSpace, toLower, toUpper)
|
||||
import Data.Ord (comparing)
|
||||
import Text.Shakespeare (Deref (..), Ident (..), parseHash, derefToExp)
|
||||
import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
|
||||
import Control.Arrow ((***))
|
||||
import Data.Monoid (mempty, mappend)
|
||||
|
||||
class ToMessage a where
|
||||
toMessage :: a -> Text
|
||||
instance ToMessage Text where
|
||||
toMessage = id
|
||||
instance ToMessage String where
|
||||
toMessage = Data.Text.pack
|
||||
|
||||
class RenderMessage master message where
|
||||
renderMessage :: master
|
||||
-> [Text] -- ^ languages
|
||||
-> message
|
||||
-> Text
|
||||
|
||||
instance RenderMessage master Text where
|
||||
renderMessage _ _ = id
|
||||
|
||||
type Lang = Text
|
||||
|
||||
mkMessage :: String
|
||||
-> FilePath
|
||||
-> Lang
|
||||
-> Q [Dec]
|
||||
mkMessage dt folder lang = do
|
||||
files <- qRunIO $ getDirectoryContents folder
|
||||
contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files
|
||||
sdef <-
|
||||
case lookup lang contents of
|
||||
Nothing -> error $ "Did not find main language file: " ++ unpack lang
|
||||
Just def -> toSDefs def
|
||||
mapM_ (checkDef sdef) $ map snd contents
|
||||
let dt' = ConT $ mkName dt
|
||||
let mname = mkName $ dt ++ "Message"
|
||||
c1 <- fmap concat $ mapM (toClauses dt) contents
|
||||
c2 <- mapM (sToClause dt) sdef
|
||||
c3 <- defClause
|
||||
return
|
||||
[ DataD [] mname [] (map (toCon dt) sdef) []
|
||||
, InstanceD
|
||||
[]
|
||||
(ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)
|
||||
[ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
|
||||
]
|
||||
]
|
||||
|
||||
toClauses :: String -> (Lang, [Def]) -> Q [Clause]
|
||||
toClauses dt (lang, defs) =
|
||||
mapM go defs
|
||||
where
|
||||
go def = do
|
||||
a <- newName "lang"
|
||||
(pat, bod) <- mkBody dt (constr def) (map fst $ vars def) (content def)
|
||||
guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
|
||||
return $ Clause
|
||||
[WildP, ConP (mkName ":") [VarP a, WildP], pat]
|
||||
(GuardedB [(guard, bod)])
|
||||
[]
|
||||
|
||||
mkBody :: String -- ^ datatype
|
||||
-> String -- ^ constructor
|
||||
-> [String] -- ^ variable names
|
||||
-> [Content]
|
||||
-> Q (Pat, Exp)
|
||||
mkBody dt cs vs ct = do
|
||||
vp <- mapM go vs
|
||||
let pat = RecP (mkName $ "Msg" ++ cs) (map (varName dt *** VarP) vp)
|
||||
let ct' = map (fixVars vp) ct
|
||||
pack' <- [|Data.Text.pack|]
|
||||
tomsg <- [|toMessage|]
|
||||
let ct'' = map (toH pack' tomsg) ct'
|
||||
mapp <- [|mappend|]
|
||||
let app a b = InfixE (Just a) mapp (Just b)
|
||||
e <-
|
||||
case ct'' of
|
||||
[] -> [|mempty|]
|
||||
[x] -> return x
|
||||
(x:xs) -> return $ foldl' app x xs
|
||||
return (pat, e)
|
||||
where
|
||||
toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
|
||||
toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
|
||||
go x = do
|
||||
let y = mkName $ '_' : x
|
||||
return (x, y)
|
||||
fixVars vp (Var d) = Var $ fixDeref vp d
|
||||
fixVars _ (Raw s) = Raw s
|
||||
fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
|
||||
fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
|
||||
fixDeref _ d = d
|
||||
fixIdent vp i =
|
||||
case lookup i vp of
|
||||
Nothing -> i
|
||||
Just y -> nameBase y
|
||||
|
||||
sToClause :: String -> SDef -> Q Clause
|
||||
sToClause dt sdef = do
|
||||
(pat, bod) <- mkBody dt (sconstr sdef) (map fst $ svars sdef) (scontent sdef)
|
||||
return $ Clause
|
||||
[WildP, ConP (mkName "[]") [], pat]
|
||||
(NormalB bod)
|
||||
[]
|
||||
|
||||
defClause :: Q Clause
|
||||
defClause = do
|
||||
a <- newName "sub"
|
||||
c <- newName "langs"
|
||||
d <- newName "msg"
|
||||
rm <- [|renderMessage|]
|
||||
return $ Clause
|
||||
[VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
|
||||
(NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
|
||||
[]
|
||||
|
||||
toCon :: String -> SDef -> Con
|
||||
toCon dt (SDef c vs _) =
|
||||
RecC (mkName $ "Msg" ++ c) $ map go vs
|
||||
where
|
||||
go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)
|
||||
|
||||
varName :: String -> String -> Name
|
||||
varName a y =
|
||||
mkName $ concat [lower a, "Message", upper y]
|
||||
where
|
||||
lower (x:xs) = toLower x : xs
|
||||
lower [] = []
|
||||
upper (x:xs) = toUpper x : xs
|
||||
upper [] = []
|
||||
|
||||
checkDef :: [SDef] -> [Def] -> Q ()
|
||||
checkDef x y =
|
||||
go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)
|
||||
where
|
||||
go _ [] = return ()
|
||||
go [] (b:_) = error $ "Extra message constructor: " ++ constr b
|
||||
go (a:as) (b:bs)
|
||||
| sconstr a < constr b = go as (b:bs)
|
||||
| sconstr a > constr b = error $ "Extra message constructor: " ++ constr b
|
||||
| otherwise = do
|
||||
go' (svars a) (vars b)
|
||||
go as bs
|
||||
go' ((an, at):as) ((bn, mbt):bs)
|
||||
| an /= bn = error "Mismatched variable names"
|
||||
| otherwise =
|
||||
case mbt of
|
||||
Nothing -> go' as bs
|
||||
Just bt
|
||||
| at == bt -> go' as bs
|
||||
| otherwise -> error "Mismatched variable types"
|
||||
go' [] [] = return ()
|
||||
go' _ _ = error "Mistmached variable count"
|
||||
|
||||
toSDefs :: [Def] -> Q [SDef]
|
||||
toSDefs = mapM toSDef
|
||||
|
||||
toSDef :: Def -> Q SDef
|
||||
toSDef d = do
|
||||
vars' <- mapM go $ vars d
|
||||
return $ SDef (constr d) vars' (content d)
|
||||
where
|
||||
go (a, Just b) = return (a, b)
|
||||
go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)
|
||||
|
||||
data SDef = SDef
|
||||
{ sconstr :: String
|
||||
, svars :: [(String, String)]
|
||||
, scontent :: [Content]
|
||||
}
|
||||
|
||||
data Def = Def
|
||||
{ constr :: String
|
||||
, vars :: [(String, Maybe String)]
|
||||
, content :: [Content]
|
||||
}
|
||||
|
||||
loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))
|
||||
loadLang folder file = do
|
||||
let file' = folder ++ '/' : file
|
||||
e <- doesFileExist file'
|
||||
if e && ".msg" `isSuffixOf` file
|
||||
then do
|
||||
let lang = pack $ reverse $ drop 4 $ reverse file
|
||||
bs <- S.readFile file'
|
||||
let s = unpack $ decodeUtf8 bs
|
||||
defs <- fmap catMaybes $ mapM parseDef $ lines s
|
||||
return $ Just (lang, defs)
|
||||
else return Nothing
|
||||
|
||||
parseDef :: String -> IO (Maybe Def)
|
||||
parseDef "" = return Nothing
|
||||
parseDef ('#':_) = return Nothing
|
||||
parseDef s =
|
||||
case end of
|
||||
':':end' -> do
|
||||
content' <- fmap compress $ parseContent $ dropWhile isSpace end'
|
||||
case words begin of
|
||||
[] -> error $ "Missing constructor: " ++ s
|
||||
(w:ws) -> return $ Just Def
|
||||
{ constr = w
|
||||
, vars = map parseVar ws
|
||||
, content = content'
|
||||
}
|
||||
_ -> error $ "Missing colon: " ++ s
|
||||
where
|
||||
(begin, end) = break (== ':') s
|
||||
|
||||
data Content = Var Deref | Raw String
|
||||
|
||||
compress :: [Content] -> [Content]
|
||||
compress [] = []
|
||||
compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest
|
||||
compress (x:y) = x : compress y
|
||||
|
||||
parseContent :: String -> IO [Content]
|
||||
parseContent s =
|
||||
either (error . show) return $ parse go s s
|
||||
where
|
||||
go = do
|
||||
x <- many go'
|
||||
eof
|
||||
return x
|
||||
go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)
|
||||
|
||||
parseVar :: String -> (String, Maybe String)
|
||||
parseVar s =
|
||||
case break (== '@') s of
|
||||
(x, '@':y) -> (x, Just y)
|
||||
_ -> (s, Nothing)
|
||||
101
yesod-core/Yesod/Request.hs
Normal file
101
yesod-core/Yesod/Request.hs
Normal file
@ -0,0 +1,101 @@
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Request
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- | Provides a parsed version of the raw 'W.Request' data.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Yesod.Request
|
||||
(
|
||||
-- * Request datatype
|
||||
RequestBodyContents
|
||||
, Request (..)
|
||||
, FileInfo (..)
|
||||
-- * Convenience functions
|
||||
, languages
|
||||
-- * Lookup parameters
|
||||
, lookupGetParam
|
||||
, lookupPostParam
|
||||
, lookupCookie
|
||||
, lookupFile
|
||||
-- ** Multi-lookup
|
||||
, lookupGetParams
|
||||
, lookupPostParams
|
||||
, lookupCookies
|
||||
, lookupFiles
|
||||
) where
|
||||
|
||||
import Yesod.Internal.Request
|
||||
import Yesod.Handler
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
|
||||
-- | Get the list of supported languages supplied by the user.
|
||||
--
|
||||
-- Languages are determined based on the following three (in descending order
|
||||
-- of preference):
|
||||
--
|
||||
-- * The _LANG get parameter.
|
||||
--
|
||||
-- * The _LANG cookie.
|
||||
--
|
||||
-- * The _LANG user session variable.
|
||||
--
|
||||
-- * Accept-Language HTTP header.
|
||||
--
|
||||
-- This is handled by parseWaiRequest (not exposed).
|
||||
languages :: Monad mo => GGHandler s m mo [Text]
|
||||
languages = reqLangs `liftM` getRequest
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text]
|
||||
lookupGetParams pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqGetParams rr
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
|
||||
lookupGetParam = liftM listToMaybe . lookupGetParams
|
||||
|
||||
-- | Lookup for POST parameters.
|
||||
lookupPostParams :: Text -> GHandler s m [Text]
|
||||
lookupPostParams pn = do
|
||||
(pp, _) <- runRequestBody
|
||||
return $ lookup' pn pp
|
||||
|
||||
lookupPostParam :: Text
|
||||
-> GHandler s m (Maybe Text)
|
||||
lookupPostParam = liftM listToMaybe . lookupPostParams
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFile :: Text
|
||||
-> GHandler s m (Maybe FileInfo)
|
||||
lookupFile = liftM listToMaybe . lookupFiles
|
||||
|
||||
-- | Lookup for POSTed files.
|
||||
lookupFiles :: Text
|
||||
-> GHandler s m [FileInfo]
|
||||
lookupFiles pn = do
|
||||
(_, files) <- runRequestBody
|
||||
return $ lookup' pn files
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
|
||||
lookupCookie = liftM listToMaybe . lookupCookies
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text]
|
||||
lookupCookies pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqCookies rr
|
||||
267
yesod-core/Yesod/Widget.hs
Normal file
267
yesod-core/Yesod/Widget.hs
Normal file
@ -0,0 +1,267 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
||||
-- generator, allowing you to create truly modular HTML components.
|
||||
module Yesod.Widget
|
||||
( -- * Datatype
|
||||
GWidget
|
||||
, GGWidget (..)
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, whamlet
|
||||
, whamletFile
|
||||
, ihamletToRepHtml
|
||||
-- * Creating
|
||||
-- ** Head of page
|
||||
, setTitle
|
||||
, setTitleI
|
||||
, addHamletHead
|
||||
, addHtmlHead
|
||||
-- ** Body
|
||||
, addHamlet
|
||||
, addHtml
|
||||
, addWidget
|
||||
, addSubWidget
|
||||
-- ** CSS
|
||||
, addCassius
|
||||
, addCassiusMedia
|
||||
, addLucius
|
||||
, addLuciusMedia
|
||||
, addStylesheet
|
||||
, addStylesheetAttrs
|
||||
, addStylesheetRemote
|
||||
, addStylesheetRemoteAttrs
|
||||
, addStylesheetEither
|
||||
-- ** Javascript
|
||||
, addJulius
|
||||
, addJuliusBody
|
||||
, addCoffee
|
||||
, addCoffeeBody
|
||||
, addScript
|
||||
, addScriptAttrs
|
||||
, addScriptRemote
|
||||
, addScriptRemoteAttrs
|
||||
, addScriptEither
|
||||
-- * Utilities
|
||||
, extractBody
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
import Control.Monad.Trans.RWS
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Lucius (Lucius)
|
||||
import Text.Julius
|
||||
import Text.Coffee
|
||||
import Yesod.Handler
|
||||
(Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getMessageRender, getUrlRenderParams
|
||||
)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Content (RepHtml (..), toContent)
|
||||
import Control.Applicative (Applicative)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
import Yesod.Internal
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
|
||||
|
||||
import Control.Monad.IO.Control (MonadControlIO)
|
||||
import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Text.Blaze (toHtml, preEscapedLazyText)
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
|
||||
-- dependencies along with a 'StateT' to track unique identifiers.
|
||||
newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO)
|
||||
|
||||
instance MonadTrans (GGWidget m) where
|
||||
lift = GWidget . lift
|
||||
|
||||
type GWidget s m = GGWidget m (GHandler s m)
|
||||
type GWInner master = RWST () (GWData (Route master)) Int
|
||||
|
||||
instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where
|
||||
mempty = return ()
|
||||
mappend x y = x >> y
|
||||
|
||||
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
|
||||
addSubWidget sub (GWidget w) = do
|
||||
master <- lift getYesod
|
||||
let sr = fromSubRoute sub master
|
||||
s <- GWidget get
|
||||
(a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s
|
||||
GWidget $ put s'
|
||||
GWidget $ tell w'
|
||||
return a
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitle :: Monad m => Html -> GGWidget master m ()
|
||||
setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
||||
-- set values.
|
||||
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()
|
||||
setTitleI msg = do
|
||||
mr <- lift getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
-- | Add a 'Hamlet' to the head tag.
|
||||
addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
|
||||
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
|
||||
-- | Add a 'Html' to the head tag.
|
||||
addHtmlHead :: Monad m => Html -> GGWidget master m ()
|
||||
addHtmlHead = addHamletHead . const
|
||||
|
||||
-- | Add a 'Hamlet' to the body tag.
|
||||
addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m ()
|
||||
addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Add a 'Html' to the body tag.
|
||||
addHtml :: Monad m => Html -> GGWidget master m ()
|
||||
addHtml = addHamlet . const
|
||||
|
||||
-- | Add another widget. This is defined as 'id', by can help with types, and
|
||||
-- makes widget blocks look more consistent.
|
||||
addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
|
||||
addWidget = id
|
||||
|
||||
-- | Add some raw CSS to the style tag. Applies to all media types.
|
||||
addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
|
||||
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
|
||||
|
||||
-- | Identical to 'addCassius'.
|
||||
addLucius :: Monad m => Lucius (Route master) -> GGWidget master m ()
|
||||
addLucius = addCassius
|
||||
|
||||
-- | Add some raw CSS to the style tag, for a specific media type.
|
||||
addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
|
||||
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
|
||||
|
||||
-- | Identical to 'addCassiusMedia'.
|
||||
addLuciusMedia :: Monad m => Text -> Lucius (Route master) -> GGWidget master m ()
|
||||
addLuciusMedia = addCassiusMedia
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: Monad m => Route master -> GGWidget master m ()
|
||||
addStylesheet = flip addStylesheetAttrs []
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
|
||||
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: Monad m => Text -> GGWidget master m ()
|
||||
addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
|
||||
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
|
||||
addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
|
||||
addStylesheetEither = either addStylesheet addStylesheetRemote
|
||||
|
||||
addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
|
||||
addScriptEither = either addScript addScriptRemote
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScript :: Monad m => Route master -> GGWidget master m ()
|
||||
addScript = flip addScriptAttrs []
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
|
||||
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: Monad m => Text -> GGWidget master m ()
|
||||
addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
|
||||
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Include raw Javascript in the page's script tag.
|
||||
addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()
|
||||
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
|
||||
-- | Add a new script tag to the body with the contents of this 'Julius'
|
||||
-- template.
|
||||
addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()
|
||||
addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j
|
||||
|
||||
-- | Add Coffesscript to the page's script tag. Requires the coffeescript
|
||||
-- executable to be present at runtime.
|
||||
addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
|
||||
addCoffee c = do
|
||||
render <- lift getUrlRenderParams
|
||||
t <- liftIO $ renderCoffee render c
|
||||
addJulius $ const $ Javascript $ fromLazyText t
|
||||
|
||||
-- | Add a new script tag to the body with the contents of this Coffesscript
|
||||
-- template. Requires the coffeescript executable to be present at runtime.
|
||||
addCoffeeBody :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
|
||||
addCoffeeBody c = do
|
||||
render <- lift getUrlRenderParams
|
||||
t <- liftIO $ renderCoffee render c
|
||||
addJuliusBody $ const $ Javascript $ fromLazyText t
|
||||
|
||||
-- | Pull out the HTML tag contents and return it. Useful for performing some
|
||||
-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
|
||||
extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))
|
||||
extractBody (GWidget w) =
|
||||
GWidget $ mapRWST (liftM go) w
|
||||
where
|
||||
go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g)
|
||||
|
||||
-- | Content for a web page. By providing this datatype, we can easily create
|
||||
-- generic site templates, which would have the type signature:
|
||||
--
|
||||
-- > PageContent url -> Hamlet url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: Html
|
||||
, pageHead :: Hamlet url
|
||||
, pageBody :: Hamlet url
|
||||
}
|
||||
|
||||
whamlet :: QuasiQuoter
|
||||
whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
whamletFile :: FilePath -> Q Exp
|
||||
whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
|
||||
|
||||
rules :: Q NP.HamletRules
|
||||
rules = do
|
||||
ah <- [|addHtml|]
|
||||
let helper qg f = do
|
||||
x <- newName "urender"
|
||||
e <- f $ VarE x
|
||||
let e' = LamE [VarP x] e
|
||||
g <- qg
|
||||
bind <- [|(>>=)|]
|
||||
return $ InfixE (Just g) bind (Just e')
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|lift getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) $ lift getMessageRender|])
|
||||
f env
|
||||
return $ NP.HamletRules ah ur $ \_ b -> return b
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
|
||||
=> NP.IHamlet message (Route master)
|
||||
-> GGHandler sub master mo RepHtml
|
||||
ihamletToRepHtml ih = do
|
||||
urender <- getUrlRenderParams
|
||||
mrender <- getMessageRender
|
||||
return $ RepHtml $ toContent $ ih (toHtml . mrender) urender
|
||||
40
yesod-core/helloworld.hs
Normal file
40
yesod-core/helloworld.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
import Yesod.Core
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Data.Text (unpack)
|
||||
|
||||
data Subsite = Subsite String
|
||||
|
||||
mkYesodSub "Subsite" [] [$parseRoutes|
|
||||
/ SubRootR GET
|
||||
/multi/*Strings SubMultiR
|
||||
|]
|
||||
|
||||
getSubRootR :: Yesod m => GHandler Subsite m RepPlain
|
||||
getSubRootR = do
|
||||
Subsite s <- getYesodSub
|
||||
tm <- getRouteToMaster
|
||||
render <- getUrlRender
|
||||
$(logDebug) "I'm in SubRootR"
|
||||
return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
|
||||
|
||||
handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
|
||||
handleSubMultiR x = do
|
||||
Subsite y <- getYesodSub
|
||||
$(logInfo) "In SubMultiR"
|
||||
return . RepPlain . toContent . show $ (x, y)
|
||||
|
||||
data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
|
||||
mkYesod "HelloWorld" [$parseRoutes|
|
||||
/ RootR GET
|
||||
/subsite/#String SubsiteR Subsite getSubsite
|
||||
|]
|
||||
instance Yesod HelloWorld where approot _ = ""
|
||||
-- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
|
||||
getRootR = do
|
||||
$(logOther "HAHAHA") "Here I am"
|
||||
return $ RepPlain "Hello World"
|
||||
main = toWaiApp (HelloWorld Subsite) >>= run 3000
|
||||
17
yesod-core/runtests.hs
Normal file
17
yesod-core/runtests.hs
Normal file
@ -0,0 +1,17 @@
|
||||
import Test.Framework (defaultMain)
|
||||
import Test.CleanPath
|
||||
import Test.Exceptions
|
||||
import Test.Widget
|
||||
import Test.Media
|
||||
import Test.Links
|
||||
import Test.NoOverloadedStrings
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ cleanPathTest
|
||||
, exceptionsTest
|
||||
, widgetTest
|
||||
, mediaTest
|
||||
, linksTest
|
||||
, noOverloadedTest
|
||||
]
|
||||
3
yesod-core/static/script.js
Normal file
3
yesod-core/static/script.js
Normal file
@ -0,0 +1,3 @@
|
||||
$(function(){
|
||||
$("p.noscript").hide();
|
||||
});
|
||||
12
yesod-core/static/style.css
Normal file
12
yesod-core/static/style.css
Normal file
@ -0,0 +1,12 @@
|
||||
body {
|
||||
font-family: sans-serif;
|
||||
background: #eee;
|
||||
}
|
||||
|
||||
#wrapper {
|
||||
width: 760px;
|
||||
margin: 1em auto;
|
||||
border: 2px solid #000;
|
||||
padding: 0.5em;
|
||||
background: #fff;
|
||||
}
|
||||
3
yesod-core/static/style2.css
Normal file
3
yesod-core/static/style2.css
Normal file
@ -0,0 +1,3 @@
|
||||
body {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
1
yesod-core/test/en.msg
Normal file
1
yesod-core/test/en.msg
Normal file
@ -0,0 +1 @@
|
||||
Another: String
|
||||
79
yesod-core/widget-benchmark.hs
Normal file
79
yesod-core/widget-benchmark.hs
Normal file
@ -0,0 +1,79 @@
|
||||
-- | BigTable benchmark implemented using Hamlet.
|
||||
--
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Main where
|
||||
|
||||
import Criterion.Main
|
||||
import Text.Hamlet
|
||||
import Numeric (showInt)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Text.Blaze.Renderer.Utf8 as Utf8
|
||||
import Data.Monoid (mconcat)
|
||||
import Text.Blaze.Html5 (table, tr, td)
|
||||
import Yesod.Widget
|
||||
import Control.Monad.Trans.Writer
|
||||
import Control.Monad.Trans.RWS
|
||||
import Data.Functor.Identity
|
||||
import Yesod.Internal
|
||||
|
||||
main = defaultMain
|
||||
[ bench "bigTable html" $ nf bigTableHtml bigTableData
|
||||
, bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
|
||||
, bench "bigTable widget" $ nf bigTableWidget bigTableData
|
||||
, bench "bigTable blaze" $ nf bigTableBlaze bigTableData
|
||||
]
|
||||
where
|
||||
rows :: Int
|
||||
rows = 1000
|
||||
|
||||
bigTableData :: [[Int]]
|
||||
bigTableData = replicate rows [1..10]
|
||||
{-# NOINLINE bigTableData #-}
|
||||
|
||||
bigTableHtml rows = L.length $ renderHtml [$hamlet|
|
||||
<table
|
||||
$forall row <- rows
|
||||
<tr
|
||||
$forall cell <- row
|
||||
<td>#{show cell}
|
||||
|]
|
||||
|
||||
bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
|
||||
<table
|
||||
$forall row <- rows
|
||||
<tr
|
||||
$forall cell <- row
|
||||
<td>#{show cell}
|
||||
|]
|
||||
|
||||
bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
|
||||
<table
|
||||
$forall row <- rows
|
||||
<tr
|
||||
$forall cell <- row
|
||||
<td>#{show cell}
|
||||
|]) (\_ _ -> "foo")
|
||||
where
|
||||
run (GWidget w) =
|
||||
let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
|
||||
in x
|
||||
{-
|
||||
run (GWidget w) = runIdentity $ do
|
||||
w' <- flip evalStateT 0
|
||||
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
|
||||
$ runWriterT $ runWriterT $ runWriterT w
|
||||
let ((((((((),
|
||||
Body body),
|
||||
_),
|
||||
_),
|
||||
_),
|
||||
_),
|
||||
_),
|
||||
_) = w'
|
||||
|
||||
return body
|
||||
-}
|
||||
|
||||
bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
|
||||
where
|
||||
row r = tr $ mconcat $ map (td . string . show) r
|
||||
94
yesod-core/yesod-core.cabal
Normal file
94
yesod-core/yesod-core.cabal
Normal file
@ -0,0 +1,94 @@
|
||||
name: yesod-core
|
||||
version: 0.9.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
maintainer: Michael Snoyman <michael@snoyman.com>
|
||||
synopsis: Creation of type-safe, RESTful web applications.
|
||||
description:
|
||||
Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.
|
||||
.
|
||||
The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent.
|
||||
category: Web, Yesod
|
||||
stability: Stable
|
||||
cabal-version: >= 1.6
|
||||
build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
|
||||
flag test
|
||||
description: Build the executable to run unit tests
|
||||
default: False
|
||||
|
||||
flag ghc7
|
||||
|
||||
library
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: time >= 1.1.4 && < 1.3
|
||||
, wai >= 0.4 && < 0.5
|
||||
, wai-extra >= 0.4 && < 0.5
|
||||
, bytestring >= 0.9.1.4 && < 0.10
|
||||
, text >= 0.5 && < 0.12
|
||||
, template-haskell
|
||||
, path-pieces >= 0.0 && < 0.1
|
||||
, hamlet >= 0.9 && < 0.10
|
||||
, blaze-builder >= 0.2.1 && < 0.4
|
||||
, transformers >= 0.2 && < 0.3
|
||||
, clientsession >= 0.6 && < 0.7
|
||||
, random >= 1.0.0.2 && < 1.1
|
||||
, cereal >= 0.2 && < 0.4
|
||||
, old-locale >= 1.0.0.2 && < 1.1
|
||||
, failure >= 0.1 && < 0.2
|
||||
, containers >= 0.2 && < 0.5
|
||||
, monad-control >= 0.2 && < 0.3
|
||||
, enumerator >= 0.4.7 && < 0.5
|
||||
, cookie >= 0.3 && < 0.4
|
||||
, blaze-html >= 0.4 && < 0.5
|
||||
, http-types >= 0.6 && < 0.7
|
||||
, case-insensitive >= 0.2 && < 0.4
|
||||
, parsec >= 2 && < 3.2
|
||||
, directory >= 1 && < 1.2
|
||||
exposed-modules: Yesod.Content
|
||||
Yesod.Core
|
||||
Yesod.Dispatch
|
||||
Yesod.Handler
|
||||
Yesod.Request
|
||||
Yesod.Widget
|
||||
Yesod.Message
|
||||
other-modules: Yesod.Internal
|
||||
Yesod.Internal.Core
|
||||
Yesod.Internal.Session
|
||||
Yesod.Internal.Request
|
||||
Yesod.Internal.Dispatch
|
||||
Yesod.Internal.RouteParsing
|
||||
Paths_yesod_core
|
||||
ghc-options: -Wall
|
||||
if flag(test)
|
||||
Buildable: False
|
||||
|
||||
executable runtests
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
cpp-options: -DGHC7
|
||||
else
|
||||
build-depends: base >= 4 && < 4.3
|
||||
if flag(test)
|
||||
Buildable: True
|
||||
cpp-options: -DTEST
|
||||
build-depends: test-framework,
|
||||
test-framework-quickcheck2,
|
||||
test-framework-hunit,
|
||||
HUnit,
|
||||
wai-test,
|
||||
QuickCheck >= 2 && < 3
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: runtests.hs
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/snoyberg/yesod-core.git
|
||||
Loading…
Reference in New Issue
Block a user