yesod-core split
This commit is contained in:
Michael Snoyman
parent
e2ace86bb9
commit
c88bbfa33e
90
ChangeLog.md
90
ChangeLog.md
@ -1,90 +0,0 @@
|
|||||||
### Yesod 0.5.0 (August 29, 2010)
|
|
||||||
|
|
||||||
* Forms no longer have special types for special views; instead, there is a
|
|
||||||
toFormField attribute when declaring entities to specify a form rendering
|
|
||||||
function.
|
|
||||||
|
|
||||||
* URL settings for jQuery and Nic are now in their own typeclasses. This will
|
|
||||||
be the approach used in the future when adding more widgets and forms that
|
|
||||||
require Javascript libraries.
|
|
||||||
|
|
||||||
* You can explicitly specify the id and name attributes to be used in forms if
|
|
||||||
you like. When omitted, a unique name is automatically generated.
|
|
||||||
|
|
||||||
* The isAuthorized function now takes a function specifying whether the
|
|
||||||
request is a write request. This should make it simpler to develop read/write
|
|
||||||
authorization systems. Bonus points: if you use HTTP request methods properly,
|
|
||||||
the isWriteRequest function will automatically determine whether a request is
|
|
||||||
a read or write request.
|
|
||||||
|
|
||||||
* You can now specify splitPath and joinPath functions yourself. Previously,
|
|
||||||
the built-in versions had very specific URL rules, such as enforcing a
|
|
||||||
trailing slash. If you want something more flexible, you can override these
|
|
||||||
functions.
|
|
||||||
|
|
||||||
* addStaticContent is used to serve CSS and Javascript code from widgets from
|
|
||||||
external files. This allows caching to take place as you'd normally like.
|
|
||||||
|
|
||||||
* Static files served from the static subsite can have a hash string added to
|
|
||||||
the query string; this is done automatically when using the getStaticFiles
|
|
||||||
function. This allows you to set your expires headers far in the future.
|
|
||||||
|
|
||||||
* A new Yesod.Mail module provides datatypes and functions for creating
|
|
||||||
multipart MIME email messages and sending them via the sendmail executable.
|
|
||||||
Since these functions generate lazy bytestrings, you can use any delivery
|
|
||||||
mechanism you want.
|
|
||||||
|
|
||||||
* Change the type of defaultLayout to use Widgets instead of PageContent. This
|
|
||||||
makes it easier to avoid double-including scripts and stylesheets.
|
|
||||||
|
|
||||||
* Major reworking of the Auth subsite to make it easier to use.
|
|
||||||
|
|
||||||
* Update of the site scaffolder to include much more functionality. Also
|
|
||||||
removed the Handler type alias from the library, as the scaffolder now
|
|
||||||
provides that.
|
|
||||||
|
|
||||||
### New in Yesod 0.4.0
|
|
||||||
|
|
||||||
A big thanks on this release to Simon Michael, who pointed out a number of
|
|
||||||
places where the docs were unclear, the API was unintuitive, or the names were
|
|
||||||
inconsistent.
|
|
||||||
|
|
||||||
* Widgets. These allow you to create composable pieces of a webpage that
|
|
||||||
keep track of their own Javascript and CSS. It includes a function for
|
|
||||||
obtaining unique identifiers to avoid name collisions, and does automatic
|
|
||||||
dependency combining; in other words, if you have two widgets that depend on
|
|
||||||
jQuery, the combined widget will only include it once.
|
|
||||||
|
|
||||||
* Combined the Yesod.Form and Yesod.Formable module into a single, consistent,
|
|
||||||
widget-based API. It includes basic input functions as well as fancier
|
|
||||||
Javascript-driven functions; for example, there is a plain day entry field,
|
|
||||||
and a day entry field which automatically loads the jQuery UI date picker.
|
|
||||||
|
|
||||||
* Added the yesod executable which performs basic scaffolding.
|
|
||||||
|
|
||||||
* Cleaned up a bunch of API function names for consistency. For example,
|
|
||||||
Yesod.Request now has a logical lookupGetName, lookupPostName, etc naming
|
|
||||||
scheme.
|
|
||||||
|
|
||||||
* Changed the type of basicHandler to require less typing, and added
|
|
||||||
basicHandler' which allows you to modify the line output to STDOUT (or skip it
|
|
||||||
altogether).
|
|
||||||
|
|
||||||
* Switched the Handler monad from ContT to MEitherT (provided by the neither
|
|
||||||
package). ContT does not have a valid MonadCatchIO instance, which is used for
|
|
||||||
the sqlite persitent backend.
|
|
||||||
|
|
||||||
* Facebook support in the Auth helper.
|
|
||||||
|
|
||||||
* Ensure that HTTP request methods are given in ALL CAPS.
|
|
||||||
|
|
||||||
* Cleaned up signatures of many methods in the Yesod typeclass. In particular,
|
|
||||||
due to changes in web-routes-quasi, many of those functions can now live in
|
|
||||||
the Handler monad, making it easier to use standard functions on them.
|
|
||||||
|
|
||||||
* The static file helper now has extensible file-extension-to-mimetype
|
|
||||||
mappings.
|
|
||||||
|
|
||||||
* Added the sendResponse function for handler short-circuiting.
|
|
||||||
|
|
||||||
* Renamed Routes to Route.
|
|
||||||
@ -2,10 +2,6 @@
|
|||||||
|
|
||||||
> module Main where
|
> module Main where
|
||||||
> import Distribution.Simple
|
> import Distribution.Simple
|
||||||
> import System.Cmd (system)
|
|
||||||
|
|
||||||
> main :: IO ()
|
> main :: IO ()
|
||||||
> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' })
|
> main = defaultMain
|
||||||
|
|
||||||
> runTests' :: a -> b -> c -> d -> IO ()
|
|
||||||
> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return ()
|
|
||||||
|
|||||||
42
Yesod.hs
42
Yesod.hs
@ -1,41 +1,55 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
-- | This module simply re-exports from other modules for your convenience.
|
-- | This module simply re-exports from other modules for your convenience.
|
||||||
module Yesod
|
module Yesod
|
||||||
( module Yesod.Request
|
( -- * Re-exports from yesod-core
|
||||||
|
module Yesod.Request
|
||||||
, module Yesod.Content
|
, module Yesod.Content
|
||||||
, module Yesod.Yesod
|
, module Yesod.Core
|
||||||
, module Yesod.Handler
|
, module Yesod.Handler
|
||||||
, module Yesod.Dispatch
|
, module Yesod.Dispatch
|
||||||
, module Yesod.Hamlet
|
|
||||||
, module Yesod.Widget
|
, module Yesod.Widget
|
||||||
|
-- * Commonly referenced functions/datatypes
|
||||||
, Application
|
, Application
|
||||||
, lift
|
, lift
|
||||||
, liftIO
|
, liftIO
|
||||||
, MonadPeelIO
|
, MonadPeelIO
|
||||||
, mempty
|
-- * Utilities
|
||||||
, showIntegral
|
, showIntegral
|
||||||
, readIntegral
|
, readIntegral
|
||||||
|
-- * Hamlet library
|
||||||
|
-- ** Hamlet
|
||||||
|
, hamlet
|
||||||
|
, xhamlet
|
||||||
|
, Hamlet
|
||||||
|
, Html
|
||||||
|
, renderHamlet
|
||||||
|
, renderHtml
|
||||||
|
, string
|
||||||
|
, preEscapedString
|
||||||
|
, cdata
|
||||||
|
-- ** Julius
|
||||||
|
, julius
|
||||||
|
, Julius
|
||||||
|
, renderJulius
|
||||||
|
-- ** Cassius
|
||||||
|
, cassius
|
||||||
|
, Cassius
|
||||||
|
, renderCassius
|
||||||
) where
|
) where
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Yesod.Content hiding (testSuite)
|
|
||||||
import Yesod.Dispatch hiding (testSuite)
|
|
||||||
import Yesod.Yesod hiding (testSuite)
|
|
||||||
import Yesod.Handler hiding (runHandler, testSuite)
|
|
||||||
#else
|
|
||||||
import Yesod.Content
|
import Yesod.Content
|
||||||
import Yesod.Dispatch
|
import Yesod.Dispatch
|
||||||
import Yesod.Yesod
|
import Yesod.Core
|
||||||
import Yesod.Handler hiding (runHandler)
|
import Yesod.Handler hiding (runHandler)
|
||||||
#endif
|
import Text.Hamlet
|
||||||
|
import Text.Cassius
|
||||||
|
import Text.Julius
|
||||||
|
|
||||||
import Yesod.Request
|
import Yesod.Request
|
||||||
import Yesod.Widget
|
import Yesod.Widget
|
||||||
import Network.Wai (Application)
|
import Network.Wai (Application)
|
||||||
import Yesod.Hamlet
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Monad.Trans.Class (lift)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Data.Monoid (mempty)
|
|
||||||
import Control.Monad.IO.Peel (MonadPeelIO)
|
import Control.Monad.IO.Peel (MonadPeelIO)
|
||||||
|
|
||||||
showIntegral :: Integral a => a -> String
|
showIntegral :: Integral a => a -> String
|
||||||
|
|||||||
267
Yesod/Content.hs
267
Yesod/Content.hs
@ -1,267 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
{-# LANGUAGE Rank2Types #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
|
|
||||||
module Yesod.Content
|
|
||||||
( -- * Content
|
|
||||||
Content (..)
|
|
||||||
, emptyContent
|
|
||||||
, ToContent (..)
|
|
||||||
-- * Mime types
|
|
||||||
-- ** Data type
|
|
||||||
, ContentType
|
|
||||||
, typeHtml
|
|
||||||
, typePlain
|
|
||||||
, typeJson
|
|
||||||
, typeXml
|
|
||||||
, typeAtom
|
|
||||||
, typeJpeg
|
|
||||||
, typePng
|
|
||||||
, typeGif
|
|
||||||
, typeJavascript
|
|
||||||
, typeCss
|
|
||||||
, typeFlv
|
|
||||||
, typeOgv
|
|
||||||
, typeOctet
|
|
||||||
-- ** File extensions
|
|
||||||
, typeByExt
|
|
||||||
, ext
|
|
||||||
-- * Utilities
|
|
||||||
, simpleContentType
|
|
||||||
-- * Representations
|
|
||||||
, ChooseRep
|
|
||||||
, HasReps (..)
|
|
||||||
, defChooseRep
|
|
||||||
-- ** Specific content types
|
|
||||||
, RepHtml (..)
|
|
||||||
, RepJson (..)
|
|
||||||
, RepHtmlJson (..)
|
|
||||||
, RepPlain (..)
|
|
||||||
, RepXml (..)
|
|
||||||
-- * Utilities
|
|
||||||
, formatW3
|
|
||||||
, formatRFC1123
|
|
||||||
#if TEST
|
|
||||||
, testSuite
|
|
||||||
#endif
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Maybe (mapMaybe)
|
|
||||||
import qualified Data.ByteString as B
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Data.Text.Lazy (Text)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Data.Time
|
|
||||||
import System.Locale
|
|
||||||
|
|
||||||
import qualified Data.Text.Encoding
|
|
||||||
import qualified Data.Text.Lazy.Encoding
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Test.Framework (testGroup, Test)
|
|
||||||
import Test.Framework.Providers.HUnit
|
|
||||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
|
||||||
import Test.HUnit hiding (Test)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import Data.Enumerator (Enumerator)
|
|
||||||
import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
|
|
||||||
import Data.Monoid (mempty)
|
|
||||||
|
|
||||||
import qualified Data.JSON.Types as J
|
|
||||||
import qualified Text.JSON.Enumerator as J
|
|
||||||
|
|
||||||
data Content = ContentBuilder Builder
|
|
||||||
| ContentEnum (forall a. Enumerator Builder IO a)
|
|
||||||
| ContentFile FilePath
|
|
||||||
|
|
||||||
-- | Zero-length enumerator.
|
|
||||||
emptyContent :: Content
|
|
||||||
emptyContent = ContentBuilder mempty
|
|
||||||
|
|
||||||
-- | Anything which can be converted into 'Content'. Most of the time, you will
|
|
||||||
-- want to use the 'ContentEnum' 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.
|
|
||||||
class ToContent a where
|
|
||||||
toContent :: a -> Content
|
|
||||||
|
|
||||||
instance ToContent B.ByteString where
|
|
||||||
toContent = ContentBuilder . fromByteString
|
|
||||||
instance ToContent L.ByteString where
|
|
||||||
toContent = ContentBuilder . 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 . T.pack
|
|
||||||
instance ToContent J.Value where
|
|
||||||
toContent = ContentBuilder . J.renderValue
|
|
||||||
|
|
||||||
-- | 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 "")]
|
|
||||||
|
|
||||||
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 = String
|
|
||||||
|
|
||||||
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"
|
|
||||||
|
|
||||||
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 :: String -> String
|
|
||||||
simpleContentType = fst . span (/= ';')
|
|
||||||
|
|
||||||
-- | A default extension to mime-type dictionary.
|
|
||||||
typeByExt :: [(String, ContentType)]
|
|
||||||
typeByExt =
|
|
||||||
[ ("jpg", typeJpeg)
|
|
||||||
, ("jpeg", typeJpeg)
|
|
||||||
, ("js", typeJavascript)
|
|
||||||
, ("css", typeCss)
|
|
||||||
, ("html", typeHtml)
|
|
||||||
, ("png", typePng)
|
|
||||||
, ("gif", typeGif)
|
|
||||||
, ("txt", typePlain)
|
|
||||||
, ("flv", typeFlv)
|
|
||||||
, ("ogv", typeOgv)
|
|
||||||
]
|
|
||||||
|
|
||||||
-- | Get a file extension (everything after last period).
|
|
||||||
ext :: String -> String
|
|
||||||
ext = reverse . fst . break (== '.') . reverse
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
---- Testing
|
|
||||||
testSuite :: Test
|
|
||||||
testSuite = testGroup "Yesod.Resource"
|
|
||||||
[ testProperty "ext" propExt
|
|
||||||
, testCase "typeByExt" caseTypeByExt
|
|
||||||
]
|
|
||||||
|
|
||||||
propExt :: String -> Bool
|
|
||||||
propExt s =
|
|
||||||
let s' = filter (/= '.') s
|
|
||||||
in s' == ext ("foobarbaz." ++ s')
|
|
||||||
|
|
||||||
caseTypeByExt :: Assertion
|
|
||||||
caseTypeByExt = do
|
|
||||||
Just typeJavascript @=? lookup (ext "foo.js") typeByExt
|
|
||||||
Just typeHtml @=? lookup (ext "foo.html") typeByExt
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | Format a 'UTCTime' in W3 format.
|
|
||||||
formatW3 :: UTCTime -> String
|
|
||||||
formatW3 = formatTime defaultTimeLocale "%FT%X-00:00"
|
|
||||||
|
|
||||||
-- | Format as per RFC 1123.
|
|
||||||
formatRFC1123 :: UTCTime -> String
|
|
||||||
formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
|
|
||||||
@ -1,539 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
module Yesod.Dispatch
|
|
||||||
( -- * Quasi-quoted routing
|
|
||||||
parseRoutes
|
|
||||||
, mkYesod
|
|
||||||
, mkYesodSub
|
|
||||||
-- ** More fine-grained
|
|
||||||
, mkYesodData
|
|
||||||
, mkYesodSubData
|
|
||||||
, mkYesodDispatch
|
|
||||||
, mkYesodSubDispatch
|
|
||||||
-- ** Path pieces
|
|
||||||
, SinglePiece (..)
|
|
||||||
, MultiPiece (..)
|
|
||||||
, Strings
|
|
||||||
-- * Convert to WAI
|
|
||||||
, toWaiApp
|
|
||||||
, basicHandler
|
|
||||||
, basicHandler'
|
|
||||||
#if TEST
|
|
||||||
, testSuite
|
|
||||||
#endif
|
|
||||||
) where
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Yesod.Yesod hiding (testSuite)
|
|
||||||
import Yesod.Handler hiding (testSuite)
|
|
||||||
#else
|
|
||||||
import Yesod.Yesod
|
|
||||||
import Yesod.Handler
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import Yesod.Request
|
|
||||||
import Yesod.Internal
|
|
||||||
|
|
||||||
import Web.Routes.Quasi
|
|
||||||
import Web.Routes.Quasi.Parse
|
|
||||||
import Web.Routes.Quasi.TH
|
|
||||||
import Language.Haskell.TH.Syntax
|
|
||||||
|
|
||||||
import qualified Network.Wai as W
|
|
||||||
import Network.Wai.Middleware.CleanPath (cleanPath)
|
|
||||||
import Network.Wai.Middleware.Jsonp
|
|
||||||
import Network.Wai.Middleware.Gzip
|
|
||||||
|
|
||||||
import qualified Network.Wai.Handler.SimpleServer as SS
|
|
||||||
import qualified Network.Wai.Handler.CGI as CGI
|
|
||||||
import System.Environment (getEnvironment)
|
|
||||||
|
|
||||||
import qualified Data.ByteString.Char8 as B
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Blaze.ByteString.Builder (toLazyByteString)
|
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
|
||||||
import Control.Arrow ((***))
|
|
||||||
|
|
||||||
import Data.Time
|
|
||||||
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Maybe
|
|
||||||
import Web.ClientSession
|
|
||||||
import qualified Web.ClientSession as CS
|
|
||||||
import Data.Char (isUpper)
|
|
||||||
import Web.Cookie (parseCookies, SetCookie (..), renderSetCookie)
|
|
||||||
|
|
||||||
import Data.Serialize
|
|
||||||
import qualified Data.Serialize as Ser
|
|
||||||
import Network.Wai.Parse hiding (FileInfo)
|
|
||||||
import qualified Network.Wai.Parse as NWP
|
|
||||||
import Data.String (fromString)
|
|
||||||
import Web.Routes
|
|
||||||
import Control.Arrow (first)
|
|
||||||
import System.Random (randomR, newStdGen)
|
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
import Data.Enumerator (($$), run_)
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Test.Framework (testGroup, Test)
|
|
||||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
|
||||||
import Test.QuickCheck
|
|
||||||
import System.IO.Unsafe
|
|
||||||
import Yesod.Content hiding (testSuite)
|
|
||||||
import Data.Serialize.Get
|
|
||||||
import Data.Serialize.Put
|
|
||||||
#else
|
|
||||||
import Yesod.Content
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | 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 -- ^ argument name
|
|
||||||
-> [String] -- ^ parameters for site argument
|
|
||||||
-> 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 arg) res -- FIXME now we cannot have multi-nested subsites
|
|
||||||
w' <- createRoutes th
|
|
||||||
let routesName = mkName $ name ++ "Route"
|
|
||||||
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
|
|
||||||
let x = TySynInstD ''Route [arg] $ ConT routesName
|
|
||||||
|
|
||||||
parse' <- createParse th
|
|
||||||
parse'' <- newName "parse"
|
|
||||||
let parse = LetE [FunD parse'' parse'] $ VarE parse''
|
|
||||||
|
|
||||||
render' <- createRender th
|
|
||||||
render'' <- newName "render"
|
|
||||||
let render = LetE [FunD render'' render'] $ VarE render''
|
|
||||||
|
|
||||||
tmh <- [|toMasterHandlerDyn|]
|
|
||||||
modMaster <- [|fmap chooseRep|]
|
|
||||||
dispatch' <- createDispatch modMaster tmh th
|
|
||||||
dispatch'' <- newName "dispatch"
|
|
||||||
let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch''
|
|
||||||
|
|
||||||
site <- [|Site|]
|
|
||||||
let site' = site `AppE` dispatch `AppE` render `AppE` parse
|
|
||||||
let (ctx, ytyp, yfunc) =
|
|
||||||
if isSub
|
|
||||||
then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
|
|
||||||
else ([], ConT ''YesodSite `AppT` arg, "getSite")
|
|
||||||
let y = InstanceD ctx ytyp
|
|
||||||
[ FunD (mkName yfunc) [Clause [] (NormalB site') []]
|
|
||||||
]
|
|
||||||
return ([w, x], [y])
|
|
||||||
|
|
||||||
isStatic :: Piece -> Bool
|
|
||||||
isStatic StaticPiece{} = True
|
|
||||||
isStatic _ = False
|
|
||||||
|
|
||||||
thResourceFromResource :: Type -> Resource -> Q THResource
|
|
||||||
thResourceFromResource _ (Resource n ps atts)
|
|
||||||
| all (all isUpper) atts = return (n, Simple ps atts)
|
|
||||||
thResourceFromResource master (Resource n ps [stype, toSubArg])
|
|
||||||
-- static route to subsite
|
|
||||||
= do
|
|
||||||
let stype' = ConT $ mkName stype
|
|
||||||
gss <- [|getSubSite|]
|
|
||||||
let inside = ConT ''Maybe `AppT`
|
|
||||||
(ConT ''GHandler `AppT` stype' `AppT` master `AppT`
|
|
||||||
ConT ''ChooseRep)
|
|
||||||
let typ = ConT ''Site `AppT`
|
|
||||||
(ConT ''Route `AppT` stype') `AppT`
|
|
||||||
(ArrowT `AppT` ConT ''String `AppT` inside)
|
|
||||||
let gss' = gss `SigE` typ
|
|
||||||
parse' <- [|parsePathSegments|]
|
|
||||||
let parse = parse' `AppE` gss'
|
|
||||||
render' <- [|formatPathSegments|]
|
|
||||||
let render = render' `AppE` gss'
|
|
||||||
dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
|
|
||||||
let dispatch = dispatch' `AppE` gss'
|
|
||||||
tmg <- mkToMasterArg ps toSubArg
|
|
||||||
return (n, SubSite
|
|
||||||
{ ssType = ConT ''Route `AppT` stype'
|
|
||||||
, ssParse = parse
|
|
||||||
, ssRender = render
|
|
||||||
, ssDispatch = dispatch
|
|
||||||
, ssToMasterArg = tmg
|
|
||||||
, ssPieces = ps
|
|
||||||
})
|
|
||||||
|
|
||||||
|
|
||||||
thResourceFromResource _ (Resource n _ _) =
|
|
||||||
error $ "Invalid attributes for resource: " ++ n
|
|
||||||
|
|
||||||
mkToMasterArg :: [Piece] -> String -> Q Exp
|
|
||||||
mkToMasterArg ps fname = do
|
|
||||||
let nargs = length $ filter (not.isStatic) ps
|
|
||||||
f = VarE $ mkName fname
|
|
||||||
args <- sequence $ take nargs $ repeat $ newName "x"
|
|
||||||
rsg <- [| runSubsiteGetter|]
|
|
||||||
let xps = map VarP args
|
|
||||||
xes = map VarE args
|
|
||||||
e' = foldl (\x y -> x `AppE` y) f xes
|
|
||||||
e = rsg `AppE` e'
|
|
||||||
return $ LamE xps e
|
|
||||||
|
|
||||||
sessionName :: String
|
|
||||||
sessionName = "_SESSION"
|
|
||||||
|
|
||||||
-- | 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, YesodSite y) => y -> IO W.Application
|
|
||||||
toWaiApp y = do
|
|
||||||
a <- toWaiAppPlain y
|
|
||||||
return $ gzip False
|
|
||||||
$ jsonp
|
|
||||||
a
|
|
||||||
|
|
||||||
-- | Convert the given argument into a WAI application, executable with any WAI
|
|
||||||
-- handler. This differs from 'toWaiApp' in that it only uses the cleanpath
|
|
||||||
-- middleware.
|
|
||||||
toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application
|
|
||||||
toWaiAppPlain a = do
|
|
||||||
key' <- if enableClientSessions a
|
|
||||||
then Just `fmap` encryptKey a
|
|
||||||
else return Nothing
|
|
||||||
return $ cleanPath (splitPath a) (B.pack $ approot a)
|
|
||||||
$ toWaiApp' a key'
|
|
||||||
|
|
||||||
toWaiApp' :: (Yesod y, YesodSite y)
|
|
||||||
=> y
|
|
||||||
-> Maybe Key
|
|
||||||
-> [String]
|
|
||||||
-> W.Request
|
|
||||||
-> IO W.Response
|
|
||||||
toWaiApp' y key' segments env = do
|
|
||||||
now <- getCurrentTime
|
|
||||||
let getExpires m = fromIntegral (m * 60) `addUTCTime` now
|
|
||||||
let exp' = getExpires $ clientSessionDuration y
|
|
||||||
let host = if sessionIpAddress y then W.remoteHost env else ""
|
|
||||||
let session' =
|
|
||||||
case key' of
|
|
||||||
Nothing -> []
|
|
||||||
Just key'' -> fromMaybe [] $ do
|
|
||||||
raw <- lookup "Cookie" $ W.requestHeaders env
|
|
||||||
val <- lookup (B.pack sessionName) $ parseCookies raw
|
|
||||||
decodeSession key'' now host val
|
|
||||||
let site = getSite
|
|
||||||
method = B.unpack $ W.requestMethod env
|
|
||||||
types = httpAccept env
|
|
||||||
pathSegments = filter (not . null) segments
|
|
||||||
eurl = parsePathSegments site pathSegments
|
|
||||||
render u qs =
|
|
||||||
let (ps, qs') = formatPathSegments site u
|
|
||||||
in fromMaybe
|
|
||||||
(joinPath y (approot y) ps $ qs ++ qs')
|
|
||||||
(urlRenderOverride y u)
|
|
||||||
let errorHandler' = localNoCurrent . errorHandler
|
|
||||||
rr <- parseWaiRequest env session'
|
|
||||||
let h = do
|
|
||||||
onRequest
|
|
||||||
case eurl of
|
|
||||||
Left _ -> errorHandler' NotFound
|
|
||||||
Right url -> do
|
|
||||||
isWrite <- isWriteRequest url
|
|
||||||
ar <- isAuthorized url isWrite
|
|
||||||
case ar of
|
|
||||||
Authorized -> return ()
|
|
||||||
AuthenticationRequired ->
|
|
||||||
case authRoute y of
|
|
||||||
Nothing ->
|
|
||||||
permissionDenied "Authentication required"
|
|
||||||
Just url' -> do
|
|
||||||
setUltDest'
|
|
||||||
redirect RedirectTemporary url'
|
|
||||||
Unauthorized s -> permissionDenied s
|
|
||||||
case handleSite site render url method of
|
|
||||||
Nothing -> errorHandler' $ BadMethod method
|
|
||||||
Just h' -> h'
|
|
||||||
let eurl' = either (const Nothing) Just eurl
|
|
||||||
let eh er = runHandler (errorHandler' er) render eurl' id y id
|
|
||||||
let ya = runHandler h render eurl' id y id
|
|
||||||
let sessionMap = Map.fromList
|
|
||||||
$ filter (\(x, _) -> x /= nonceKey) session'
|
|
||||||
yar <- unYesodApp ya eh rr types sessionMap
|
|
||||||
case yar of
|
|
||||||
YARPlain s hs ct c sessionFinal -> do
|
|
||||||
let sessionVal =
|
|
||||||
case key' of
|
|
||||||
Nothing -> B.empty
|
|
||||||
Just key'' ->
|
|
||||||
encodeSession key'' exp' host
|
|
||||||
$ Map.toList
|
|
||||||
$ Map.insert nonceKey (reqNonce rr) sessionFinal
|
|
||||||
let 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''
|
|
||||||
return $
|
|
||||||
case c of
|
|
||||||
ContentBuilder b -> W.responseBuilder s hs''' b
|
|
||||||
ContentFile fp -> W.ResponseFile s hs''' fp
|
|
||||||
ContentEnum e -> W.ResponseEnumerator $ \iter ->
|
|
||||||
run_ $ e $$ iter s hs'''
|
|
||||||
YAREnum e -> return $ W.ResponseEnumerator e
|
|
||||||
|
|
||||||
httpAccept :: W.Request -> [ContentType]
|
|
||||||
httpAccept = map B.unpack
|
|
||||||
. parseHttpAccept
|
|
||||||
. fromMaybe B.empty
|
|
||||||
. lookup "Accept"
|
|
||||||
. W.requestHeaders
|
|
||||||
|
|
||||||
-- | Runs an application with CGI if CGI variables are present (namely
|
|
||||||
-- PATH_INFO); otherwise uses SimpleServer.
|
|
||||||
basicHandler :: (Yesod y, YesodSite y)
|
|
||||||
=> Int -- ^ port number
|
|
||||||
-> y
|
|
||||||
-> IO ()
|
|
||||||
basicHandler port y = basicHandler' port (Just "localhost") y
|
|
||||||
|
|
||||||
|
|
||||||
-- | Same as 'basicHandler', but allows you to specify the hostname to display
|
|
||||||
-- to the user. If 'Nothing' is provided, then no output is produced.
|
|
||||||
basicHandler' :: (Yesod y, YesodSite y)
|
|
||||||
=> Int -- ^ port number
|
|
||||||
-> Maybe String -- ^ host name, 'Nothing' to show nothing
|
|
||||||
-> y
|
|
||||||
-> IO ()
|
|
||||||
basicHandler' port mhost y = do
|
|
||||||
app <- toWaiApp y
|
|
||||||
vars <- getEnvironment
|
|
||||||
case lookup "PATH_INFO" vars of
|
|
||||||
Nothing -> do
|
|
||||||
case mhost of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just h -> putStrLn $ concat
|
|
||||||
["http://", h, ":", show port, "/"]
|
|
||||||
SS.run port app
|
|
||||||
Just _ -> CGI.run app
|
|
||||||
|
|
||||||
parseWaiRequest :: W.Request
|
|
||||||
-> [(String, String)] -- ^ session
|
|
||||||
-> IO Request
|
|
||||||
parseWaiRequest env session' = do
|
|
||||||
let gets' = map (bsToChars *** bsToChars)
|
|
||||||
$ parseQueryString $ W.queryString env
|
|
||||||
let reqCookie = fromMaybe B.empty $ lookup "Cookie"
|
|
||||||
$ W.requestHeaders env
|
|
||||||
cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie
|
|
||||||
acceptLang = lookup "Accept-Language" $ W.requestHeaders env
|
|
||||||
langs = map bsToChars $ maybe [] 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 lookup langKey gets' of
|
|
||||||
Nothing -> langs''
|
|
||||||
Just x -> x : langs''
|
|
||||||
rbthunk <- iothunk $ rbHelper env
|
|
||||||
nonce <- case lookup nonceKey session' of
|
|
||||||
Just x -> return x
|
|
||||||
Nothing -> do
|
|
||||||
g <- newStdGen
|
|
||||||
return $ fst $ randomString 10 g
|
|
||||||
return $ Request gets' cookies' rbthunk 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
|
|
||||||
|
|
||||||
nonceKey :: String
|
|
||||||
nonceKey = "_NONCE"
|
|
||||||
|
|
||||||
rbHelper :: W.Request -> IO RequestBodyContents
|
|
||||||
rbHelper req =
|
|
||||||
(map fix1 *** map fix2) <$> run_ (enum $$ iter)
|
|
||||||
where
|
|
||||||
enum = W.requestBody req
|
|
||||||
iter = parseRequestBody lbsSink req
|
|
||||||
fix1 = bsToChars *** bsToChars
|
|
||||||
fix2 (x, NWP.FileInfo a b c) =
|
|
||||||
(bsToChars x, FileInfo (bsToChars a) (bsToChars b) c)
|
|
||||||
|
|
||||||
-- | Produces a \"compute on demand\" value. The computation will be run once
|
|
||||||
-- it is requested, and then the result will be stored. This will happen only
|
|
||||||
-- once.
|
|
||||||
iothunk :: IO a -> IO (IO a)
|
|
||||||
iothunk = fmap go . newMVar . Left where
|
|
||||||
go :: MVar (Either (IO a) a) -> IO a
|
|
||||||
go mvar = modifyMVar mvar go'
|
|
||||||
go' :: Either (IO a) a -> IO (Either (IO a) a, a)
|
|
||||||
go' (Right val) = return (Right val, val)
|
|
||||||
go' (Left comp) = do
|
|
||||||
val <- comp
|
|
||||||
return (Right val, val)
|
|
||||||
|
|
||||||
-- | Convert Header to a key/value pair.
|
|
||||||
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
|
|
||||||
-> Header
|
|
||||||
-> (W.ResponseHeader, B.ByteString)
|
|
||||||
headerToPair getExpires (AddCookie minutes key value) =
|
|
||||||
("Set-Cookie", builderToBS $ renderSetCookie $ SetCookie
|
|
||||||
{ setCookieName = B.pack key -- FIXME check for non-ASCII
|
|
||||||
, setCookieValue = B.pack value -- FIXME check for non-ASCII
|
|
||||||
, setCookiePath = Just "/" -- FIXME make a config option, or use approot?
|
|
||||||
, setCookieExpires = Just $ getExpires minutes
|
|
||||||
, setCookieDomain = Nothing
|
|
||||||
})
|
|
||||||
where
|
|
||||||
builderToBS = S.concat . L.toChunks . toLazyByteString
|
|
||||||
headerToPair _ (DeleteCookie key) =
|
|
||||||
("Set-Cookie", charsToBs $
|
|
||||||
key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
|
|
||||||
headerToPair _ (Header key value) =
|
|
||||||
(fromString key, charsToBs value)
|
|
||||||
|
|
||||||
encodeSession :: CS.Key
|
|
||||||
-> UTCTime -- ^ expire time
|
|
||||||
-> B.ByteString -- ^ remote host
|
|
||||||
-> [(String, String)] -- ^ session
|
|
||||||
-> B.ByteString -- ^ cookie value
|
|
||||||
encodeSession key expire rhost session' =
|
|
||||||
encrypt key $ encode $ SessionCookie expire rhost session'
|
|
||||||
|
|
||||||
decodeSession :: CS.Key
|
|
||||||
-> UTCTime -- ^ current time
|
|
||||||
-> B.ByteString -- ^ remote host field
|
|
||||||
-> B.ByteString -- ^ cookie value
|
|
||||||
-> Maybe [(String, String)]
|
|
||||||
decodeSession key now rhost encrypted = do
|
|
||||||
decrypted <- 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 B.ByteString [(String, String)]
|
|
||||||
deriving (Show, Read)
|
|
||||||
instance Serialize SessionCookie where
|
|
||||||
put (SessionCookie a b c) = putTime a >> put b >> put c
|
|
||||||
get = do
|
|
||||||
a <- getTime
|
|
||||||
b <- Ser.get
|
|
||||||
c <- Ser.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 <- Ser.get
|
|
||||||
ndt <- Ser.get
|
|
||||||
return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
|
|
||||||
testSuite :: Test
|
|
||||||
testSuite = testGroup "Yesod.Dispatch"
|
|
||||||
[ testProperty "encode/decode session" propEncDecSession
|
|
||||||
, testProperty "get/put time" propGetPutTime
|
|
||||||
]
|
|
||||||
|
|
||||||
propEncDecSession :: [(String, String)] -> Bool
|
|
||||||
propEncDecSession session' = unsafePerformIO $ do
|
|
||||||
key <- getDefaultKey
|
|
||||||
now <- getCurrentTime
|
|
||||||
let expire = addUTCTime 1 now
|
|
||||||
let rhost = B.pack "some host"
|
|
||||||
let val = encodeSession key expire rhost session'
|
|
||||||
return $ Just session' == decodeSession key now rhost val
|
|
||||||
|
|
||||||
propGetPutTime :: UTCTime -> Bool
|
|
||||||
propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)
|
|
||||||
|
|
||||||
instance Arbitrary UTCTime where
|
|
||||||
arbitrary = do
|
|
||||||
a <- arbitrary
|
|
||||||
b <- arbitrary
|
|
||||||
return $ addUTCTime (fromRational b)
|
|
||||||
$ UTCTime (ModifiedJulianDay a) 0
|
|
||||||
|
|
||||||
#endif
|
|
||||||
@ -1,59 +0,0 @@
|
|||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
module Yesod.Hamlet
|
|
||||||
( -- * Hamlet library
|
|
||||||
-- ** Hamlet
|
|
||||||
hamlet
|
|
||||||
, xhamlet
|
|
||||||
, Hamlet
|
|
||||||
, Html
|
|
||||||
, renderHamlet
|
|
||||||
, renderHtml
|
|
||||||
, string
|
|
||||||
, preEscapedString
|
|
||||||
, cdata
|
|
||||||
-- ** Julius
|
|
||||||
, julius
|
|
||||||
, Julius
|
|
||||||
, renderJulius
|
|
||||||
-- ** Cassius
|
|
||||||
, cassius
|
|
||||||
, Cassius
|
|
||||||
, renderCassius
|
|
||||||
-- * Convert to something displayable
|
|
||||||
, hamletToContent
|
|
||||||
, hamletToRepHtml
|
|
||||||
-- * Page templates
|
|
||||||
, PageContent (..)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Text.Hamlet
|
|
||||||
import Text.Cassius
|
|
||||||
import Text.Julius
|
|
||||||
import Yesod.Content
|
|
||||||
import Yesod.Handler
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
|
||||||
-- Yesod 'Response'.
|
|
||||||
hamletToContent :: Hamlet (Route master) -> GHandler sub master Content
|
|
||||||
hamletToContent h = do
|
|
||||||
render <- getUrlRenderParams
|
|
||||||
return $ toContent $ renderHamlet render h
|
|
||||||
|
|
||||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
|
||||||
hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml
|
|
||||||
hamletToRepHtml = fmap RepHtml . hamletToContent
|
|
||||||
588
Yesod/Handler.hs
588
Yesod/Handler.hs
@ -1,588 +0,0 @@
|
|||||||
{-# LANGUAGE ExistentialQuantification #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE PackageImports #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE Rank2Types #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- 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
|
|
||||||
-- ** Read information from handler
|
|
||||||
, getYesod
|
|
||||||
, getYesodSub
|
|
||||||
, getUrlRender
|
|
||||||
, getUrlRenderParams
|
|
||||||
, getCurrentRoute
|
|
||||||
, getRouteToMaster
|
|
||||||
-- * Special responses
|
|
||||||
-- ** Redirecting
|
|
||||||
, RedirectType (..)
|
|
||||||
, redirect
|
|
||||||
, redirectParams
|
|
||||||
, redirectString
|
|
||||||
-- ** Errors
|
|
||||||
, notFound
|
|
||||||
, badMethod
|
|
||||||
, permissionDenied
|
|
||||||
, invalidArgs
|
|
||||||
-- ** Short-circuit responses.
|
|
||||||
, sendFile
|
|
||||||
, sendResponse
|
|
||||||
, sendResponseStatus
|
|
||||||
, sendResponseCreated
|
|
||||||
, sendResponseEnumerator
|
|
||||||
-- * Setting headers
|
|
||||||
, setCookie
|
|
||||||
, deleteCookie
|
|
||||||
, setHeader
|
|
||||||
, setLanguage
|
|
||||||
-- ** Content caching and expiration
|
|
||||||
, cacheSeconds
|
|
||||||
, neverExpires
|
|
||||||
, alreadyExpired
|
|
||||||
, expiresAt
|
|
||||||
-- * Session
|
|
||||||
, SessionMap
|
|
||||||
, lookupSession
|
|
||||||
, getSession
|
|
||||||
, setSession
|
|
||||||
, deleteSession
|
|
||||||
-- ** Ultimate destination
|
|
||||||
, setUltDest
|
|
||||||
, setUltDestString
|
|
||||||
, setUltDest'
|
|
||||||
, redirectUltDest
|
|
||||||
-- ** Messages
|
|
||||||
, setMessage
|
|
||||||
, getMessage
|
|
||||||
-- * Internal Yesod
|
|
||||||
, runHandler
|
|
||||||
, YesodApp (..)
|
|
||||||
, runSubsiteGetter
|
|
||||||
, toMasterHandler
|
|
||||||
, toMasterHandlerDyn
|
|
||||||
, toMasterHandlerMaybe
|
|
||||||
, localNoCurrent
|
|
||||||
, HandlerData
|
|
||||||
, ErrorResponse (..)
|
|
||||||
, YesodAppResult (..)
|
|
||||||
#if TEST
|
|
||||||
, testSuite
|
|
||||||
#endif
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Prelude hiding (catch)
|
|
||||||
import Yesod.Request
|
|
||||||
import Yesod.Internal
|
|
||||||
import Data.Neither
|
|
||||||
import Data.Time (UTCTime)
|
|
||||||
|
|
||||||
import Control.Exception hiding (Handler, catch, finally)
|
|
||||||
import qualified Control.Exception as E
|
|
||||||
import Control.Applicative
|
|
||||||
|
|
||||||
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 System.IO
|
|
||||||
import qualified Network.Wai as W
|
|
||||||
import Control.Failure (Failure (failure))
|
|
||||||
|
|
||||||
import Text.Hamlet
|
|
||||||
|
|
||||||
import Control.Monad.IO.Peel (MonadPeelIO)
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import qualified Data.ByteString.Char8 as S8
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Test.Framework (testGroup, Test)
|
|
||||||
import Test.Framework.Providers.HUnit (testCase)
|
|
||||||
import Test.HUnit hiding (Test)
|
|
||||||
import Yesod.Content hiding (testSuite)
|
|
||||||
import Data.IORef
|
|
||||||
#else
|
|
||||||
import Yesod.Content
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | 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 -> [(String, String)] -> String)
|
|
||||||
, 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
|
|
||||||
-> GHandler sub master a
|
|
||||||
-> GHandler sub' master a
|
|
||||||
toMasterHandler tm ts route (GHandler h) =
|
|
||||||
GHandler $ withReaderT (handlerSubData tm ts route) h
|
|
||||||
|
|
||||||
toMasterHandlerDyn :: (Route sub -> Route master)
|
|
||||||
-> GHandler sub' master sub
|
|
||||||
-> Route sub
|
|
||||||
-> GHandler sub master a
|
|
||||||
-> GHandler sub' master 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 = do
|
|
||||||
y <- getYesod
|
|
||||||
return $ getter y
|
|
||||||
|
|
||||||
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)
|
|
||||||
-> GHandler sub master a
|
|
||||||
-> GHandler sub' master 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 GHandler sub master a =
|
|
||||||
GHandler
|
|
||||||
{ unGHandler :: GHInner sub master a
|
|
||||||
}
|
|
||||||
deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
|
|
||||||
|
|
||||||
type GHInner s m =
|
|
||||||
ReaderT (HandlerData s m) (
|
|
||||||
MEitherT HandlerContents (
|
|
||||||
WriterT (Endo [Header]) (
|
|
||||||
StateT SessionMap ( -- session
|
|
||||||
IO
|
|
||||||
))))
|
|
||||||
|
|
||||||
type SessionMap = Map.Map String String
|
|
||||||
|
|
||||||
type Endo a = a -> a
|
|
||||||
|
|
||||||
-- | 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
|
|
||||||
-> IO YesodAppResult
|
|
||||||
}
|
|
||||||
|
|
||||||
data YesodAppResult
|
|
||||||
= YAREnum (forall a. W.ResponseEnumerator a)
|
|
||||||
| YARPlain W.Status [Header] ContentType Content SessionMap
|
|
||||||
|
|
||||||
data HandlerContents =
|
|
||||||
HCContent W.Status ChooseRep
|
|
||||||
| HCError ErrorResponse
|
|
||||||
| HCSendFile ContentType FilePath
|
|
||||||
| HCRedirect RedirectType String
|
|
||||||
| HCCreated String
|
|
||||||
| HCEnum (forall a. W.ResponseEnumerator a)
|
|
||||||
|
|
||||||
instance Failure ErrorResponse (GHandler sub master) where
|
|
||||||
failure = GHandler . lift . throwMEither . HCError
|
|
||||||
instance RequestReader (GHandler sub master) where
|
|
||||||
getRequest = handlerRequest <$> GHandler ask
|
|
||||||
|
|
||||||
-- | Get the sub application argument.
|
|
||||||
getYesodSub :: GHandler sub master sub
|
|
||||||
getYesodSub = handlerSub <$> GHandler ask
|
|
||||||
|
|
||||||
-- | Get the master site appliation argument.
|
|
||||||
getYesod :: GHandler sub master master
|
|
||||||
getYesod = handlerMaster <$> GHandler ask
|
|
||||||
|
|
||||||
-- | Get the URL rendering function.
|
|
||||||
getUrlRender :: GHandler sub master (Route master -> String)
|
|
||||||
getUrlRender = do
|
|
||||||
x <- handlerRender <$> GHandler ask
|
|
||||||
return $ flip x []
|
|
||||||
|
|
||||||
-- | The URL rendering function with query-string parameters.
|
|
||||||
getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String)
|
|
||||||
getUrlRenderParams = handlerRender <$> 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 :: GHandler sub master (Maybe (Route sub))
|
|
||||||
getCurrentRoute = handlerRoute <$> GHandler ask
|
|
||||||
|
|
||||||
-- | Get the function to promote a route for a subsite to a route for the
|
|
||||||
-- master site.
|
|
||||||
getRouteToMaster :: GHandler sub master (Route sub -> Route master)
|
|
||||||
getRouteToMaster = handlerToMaster <$> 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 -> [(String, String)] -> String)
|
|
||||||
-> Maybe (Route sub)
|
|
||||||
-> (Route sub -> Route master)
|
|
||||||
-> master
|
|
||||||
-> (master -> sub)
|
|
||||||
-> YesodApp
|
|
||||||
runHandler handler mrender sroute tomr ma tosa =
|
|
||||||
YesodApp $ \eh rr cts initSession -> do
|
|
||||||
let toErrorHandler =
|
|
||||||
InternalError
|
|
||||||
. (show :: Control.Exception.SomeException -> String)
|
|
||||||
let hd = HandlerData
|
|
||||||
{ handlerRequest = rr
|
|
||||||
, handlerSub = tosa ma
|
|
||||||
, handlerMaster = ma
|
|
||||||
, handlerRoute = sroute
|
|
||||||
, handlerRender = mrender
|
|
||||||
, handlerToMaster = tomr
|
|
||||||
}
|
|
||||||
((contents', headers), finalSession) <- E.catch (
|
|
||||||
flip runStateT initSession
|
|
||||||
$ runWriterT
|
|
||||||
$ runMEitherT
|
|
||||||
$ flip runReaderT hd
|
|
||||||
$ unGHandler handler
|
|
||||||
) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession))
|
|
||||||
let contents = meither id (HCContent W.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' = headers hs
|
|
||||||
in return $ YARPlain (getStatus e) hs' ct c sess
|
|
||||||
YAREnum _ -> return yar
|
|
||||||
let sendFile' ct fp =
|
|
||||||
return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession
|
|
||||||
case contents of
|
|
||||||
HCContent status a -> do
|
|
||||||
(ct, c) <- chooseRep a cts
|
|
||||||
return $ YARPlain status (headers []) ct c finalSession
|
|
||||||
HCError e -> handleError e
|
|
||||||
HCRedirect rt loc -> do
|
|
||||||
let hs = Header "Location" loc : headers []
|
|
||||||
return $ YARPlain
|
|
||||||
(getRedirectStatus rt) hs typePlain emptyContent
|
|
||||||
finalSession
|
|
||||||
HCSendFile ct fp -> E.catch
|
|
||||||
(sendFile' ct fp)
|
|
||||||
(handleError . toErrorHandler)
|
|
||||||
HCCreated loc -> do -- FIXME add status201 to WAI
|
|
||||||
let hs = Header "Location" loc : headers []
|
|
||||||
return $ YARPlain
|
|
||||||
(W.Status 201 (S8.pack "Created"))
|
|
||||||
hs
|
|
||||||
typePlain
|
|
||||||
emptyContent
|
|
||||||
finalSession
|
|
||||||
HCEnum e -> return $ YAREnum e
|
|
||||||
|
|
||||||
safeEh :: ErrorResponse -> YesodApp
|
|
||||||
safeEh er = YesodApp $ \_ _ _ session -> do
|
|
||||||
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
|
|
||||||
return $ YARPlain
|
|
||||||
W.status500
|
|
||||||
[]
|
|
||||||
typePlain
|
|
||||||
(toContent "Internal Server Error")
|
|
||||||
session
|
|
||||||
|
|
||||||
-- | Redirect to the given route.
|
|
||||||
redirect :: RedirectType -> Route master -> GHandler sub master a
|
|
||||||
redirect rt url = redirectParams rt url []
|
|
||||||
|
|
||||||
-- | Redirects to the given route with the associated query-string parameters.
|
|
||||||
redirectParams :: RedirectType -> Route master -> [(String, String)]
|
|
||||||
-> GHandler sub master a
|
|
||||||
redirectParams rt url params = do
|
|
||||||
r <- getUrlRenderParams
|
|
||||||
redirectString rt $ r url params
|
|
||||||
|
|
||||||
-- | Redirect to the given URL.
|
|
||||||
redirectString :: RedirectType -> String -> GHandler sub master a
|
|
||||||
redirectString rt = GHandler . lift . throwMEither . HCRedirect rt
|
|
||||||
|
|
||||||
ultDestKey :: String
|
|
||||||
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 :: Route master -> GHandler sub master ()
|
|
||||||
setUltDest dest = do
|
|
||||||
render <- getUrlRender
|
|
||||||
setUltDestString $ render dest
|
|
||||||
|
|
||||||
-- | Same as 'setUltDest', but use the given string.
|
|
||||||
setUltDestString :: String -> GHandler sub master ()
|
|
||||||
setUltDestString = setSession ultDestKey
|
|
||||||
|
|
||||||
-- | 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' :: GHandler sub master ()
|
|
||||||
setUltDest' = do
|
|
||||||
route <- getCurrentRoute
|
|
||||||
case route of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just r -> do
|
|
||||||
tm <- getRouteToMaster
|
|
||||||
gets' <- reqGetParams <$> getRequest
|
|
||||||
render <- getUrlRenderParams
|
|
||||||
setUltDestString $ render (tm r) gets'
|
|
||||||
|
|
||||||
-- | Redirect to the ultimate destination in the user's session. Clear the
|
|
||||||
-- value from the session.
|
|
||||||
--
|
|
||||||
-- The ultimate destination is set with 'setUltDest'.
|
|
||||||
redirectUltDest :: RedirectType
|
|
||||||
-> Route master -- ^ default destination if nothing in session
|
|
||||||
-> GHandler sub master ()
|
|
||||||
redirectUltDest rt def = do
|
|
||||||
mdest <- lookupSession ultDestKey
|
|
||||||
deleteSession ultDestKey
|
|
||||||
maybe (redirect rt def) (redirectString rt) mdest
|
|
||||||
|
|
||||||
msgKey :: String
|
|
||||||
msgKey = "_MSG"
|
|
||||||
|
|
||||||
-- | Sets a message in the user's session.
|
|
||||||
--
|
|
||||||
-- See 'getMessage'.
|
|
||||||
setMessage :: Html -> GHandler sub master ()
|
|
||||||
setMessage = setSession msgKey . lbsToChars . renderHtml
|
|
||||||
|
|
||||||
-- | Gets the message in the user's session, if available, and then clears the
|
|
||||||
-- variable.
|
|
||||||
--
|
|
||||||
-- See 'setMessage'.
|
|
||||||
getMessage :: GHandler sub master (Maybe Html)
|
|
||||||
getMessage = do
|
|
||||||
mmsg <- fmap (fmap preEscapedString) $ 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 :: ContentType -> FilePath -> GHandler sub master a
|
|
||||||
sendFile ct = GHandler . lift . throwMEither . HCSendFile ct
|
|
||||||
|
|
||||||
-- | Bypass remaining handler code and output the given content with a 200
|
|
||||||
-- status code.
|
|
||||||
sendResponse :: HasReps c => c -> GHandler sub master a
|
|
||||||
sendResponse = GHandler . lift . throwMEither . HCContent W.status200
|
|
||||||
. chooseRep
|
|
||||||
|
|
||||||
-- | Bypass remaining handler code and output the given content with the given
|
|
||||||
-- status code.
|
|
||||||
sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a
|
|
||||||
sendResponseStatus s = GHandler . lift . throwMEither . HCContent s
|
|
||||||
. chooseRep
|
|
||||||
|
|
||||||
-- | Send a 201 "Created" response with the given route as the Location
|
|
||||||
-- response header.
|
|
||||||
sendResponseCreated :: Route m -> GHandler s m a
|
|
||||||
sendResponseCreated url = do
|
|
||||||
r <- getUrlRender
|
|
||||||
GHandler $ lift $ throwMEither $ HCCreated $ r url
|
|
||||||
|
|
||||||
-- | Send a 'W.ResponseEnumerator'. 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 they specific needs. If you are not sure if you need it,
|
|
||||||
-- you don't.
|
|
||||||
sendResponseEnumerator :: (forall a. W.ResponseEnumerator a) -> GHandler s m b
|
|
||||||
sendResponseEnumerator = GHandler . lift . throwMEither . HCEnum
|
|
||||||
|
|
||||||
-- | 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 :: (RequestReader m, Failure ErrorResponse m) => m a
|
|
||||||
badMethod = do
|
|
||||||
w <- waiRequest
|
|
||||||
failure $ BadMethod $ bsToChars $ W.requestMethod w
|
|
||||||
|
|
||||||
-- | Return a 403 permission denied page.
|
|
||||||
permissionDenied :: Failure ErrorResponse m => String -> m a
|
|
||||||
permissionDenied = failure . PermissionDenied
|
|
||||||
|
|
||||||
-- | Return a 400 invalid arguments page.
|
|
||||||
invalidArgs :: Failure ErrorResponse m => [String] -> m a
|
|
||||||
invalidArgs = failure . InvalidArgs
|
|
||||||
|
|
||||||
------- Headers
|
|
||||||
-- | Set the cookie on the client.
|
|
||||||
setCookie :: Int -- ^ minutes to timeout
|
|
||||||
-> String -- ^ key
|
|
||||||
-> String -- ^ value
|
|
||||||
-> GHandler sub master ()
|
|
||||||
setCookie a b = addHeader . AddCookie a b
|
|
||||||
|
|
||||||
-- | Unset the cookie on the client.
|
|
||||||
deleteCookie :: String -> GHandler sub master ()
|
|
||||||
deleteCookie = addHeader . DeleteCookie
|
|
||||||
|
|
||||||
-- | Set the language in the user session. Will show up in 'languages' on the
|
|
||||||
-- next request.
|
|
||||||
setLanguage :: String -> GHandler sub master ()
|
|
||||||
setLanguage = setSession langKey
|
|
||||||
|
|
||||||
-- | Set an arbitrary response header.
|
|
||||||
setHeader :: String -> String -> GHandler sub master ()
|
|
||||||
setHeader a = addHeader . Header a
|
|
||||||
|
|
||||||
-- | Set the Cache-Control header to indicate this response should be cached
|
|
||||||
-- for the given number of seconds.
|
|
||||||
cacheSeconds :: Int -> GHandler s m ()
|
|
||||||
cacheSeconds i = setHeader "Cache-Control" $ 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 :: GHandler s m ()
|
|
||||||
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 :: GHandler s m ()
|
|
||||||
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
|
||||||
|
|
||||||
-- | Set an Expires header to the given date.
|
|
||||||
expiresAt :: UTCTime -> GHandler s m ()
|
|
||||||
expiresAt = setHeader "Expires" . 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 :: String -- ^ key
|
|
||||||
-> String -- ^ value
|
|
||||||
-> GHandler sub master ()
|
|
||||||
setSession k = GHandler . lift . lift . lift . modify . Map.insert k
|
|
||||||
|
|
||||||
-- | Unsets a session variable. See 'setSession'.
|
|
||||||
deleteSession :: String -> GHandler sub master ()
|
|
||||||
deleteSession = GHandler . lift . lift . lift . modify . Map.delete
|
|
||||||
|
|
||||||
-- | Internal use only, not to be confused with 'setHeader'.
|
|
||||||
addHeader :: Header -> GHandler sub master ()
|
|
||||||
addHeader = GHandler . lift . lift . tell . (:)
|
|
||||||
|
|
||||||
getStatus :: ErrorResponse -> W.Status
|
|
||||||
getStatus NotFound = W.status404
|
|
||||||
getStatus (InternalError _) = W.status500
|
|
||||||
getStatus (InvalidArgs _) = W.status400
|
|
||||||
getStatus (PermissionDenied _) = W.status403
|
|
||||||
getStatus (BadMethod _) = W.status405
|
|
||||||
|
|
||||||
getRedirectStatus :: RedirectType -> W.Status
|
|
||||||
getRedirectStatus RedirectPermanent = W.status301
|
|
||||||
getRedirectStatus RedirectTemporary = W.status302
|
|
||||||
getRedirectStatus RedirectSeeOther = W.status303
|
|
||||||
|
|
||||||
-- | Different types of redirects.
|
|
||||||
data RedirectType = RedirectPermanent
|
|
||||||
| RedirectTemporary
|
|
||||||
| RedirectSeeOther
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
localNoCurrent :: GHandler s m a -> GHandler s m a
|
|
||||||
localNoCurrent =
|
|
||||||
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
|
|
||||||
|
|
||||||
-- | Lookup for session data.
|
|
||||||
lookupSession :: ParamName -> GHandler s m (Maybe ParamValue)
|
|
||||||
lookupSession n = GHandler $ do
|
|
||||||
m <- lift $ lift $ lift get
|
|
||||||
return $ Map.lookup n m
|
|
||||||
|
|
||||||
-- | Get all session variables.
|
|
||||||
getSession :: GHandler s m SessionMap
|
|
||||||
getSession = GHandler $ lift $ lift $ lift get
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
|
|
||||||
testSuite :: Test
|
|
||||||
testSuite = testGroup "Yesod.Handler"
|
|
||||||
[
|
|
||||||
]
|
|
||||||
|
|
||||||
#endif
|
|
||||||
@ -1,96 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Yesod.Helpers.AtomFeed
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- Stability : Stable
|
|
||||||
-- Portability : portable
|
|
||||||
--
|
|
||||||
-- Generating atom news feeds.
|
|
||||||
--
|
|
||||||
---------------------------------------------------------
|
|
||||||
|
|
||||||
-- | Generation of Atom newsfeeds. See
|
|
||||||
-- <http://en.wikipedia.org/wiki/Atom_(standard)>.
|
|
||||||
module Yesod.Helpers.AtomFeed
|
|
||||||
( AtomFeed (..)
|
|
||||||
, AtomFeedEntry (..)
|
|
||||||
, atomFeed
|
|
||||||
, atomLink
|
|
||||||
, RepAtom (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Yesod
|
|
||||||
import Data.Time.Clock (UTCTime)
|
|
||||||
|
|
||||||
newtype RepAtom = RepAtom Content
|
|
||||||
instance HasReps RepAtom where
|
|
||||||
chooseRep (RepAtom c) _ = return (typeAtom, c)
|
|
||||||
|
|
||||||
atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom
|
|
||||||
atomFeed = fmap RepAtom . hamletToContent . template
|
|
||||||
|
|
||||||
data AtomFeed url = AtomFeed
|
|
||||||
{ atomTitle :: String
|
|
||||||
, atomLinkSelf :: url
|
|
||||||
, atomLinkHome :: url
|
|
||||||
, atomUpdated :: UTCTime
|
|
||||||
, atomEntries :: [AtomFeedEntry url]
|
|
||||||
}
|
|
||||||
|
|
||||||
data AtomFeedEntry url = AtomFeedEntry
|
|
||||||
{ atomEntryLink :: url
|
|
||||||
, atomEntryUpdated :: UTCTime
|
|
||||||
, atomEntryTitle :: String
|
|
||||||
, atomEntryContent :: Html
|
|
||||||
}
|
|
||||||
|
|
||||||
template :: AtomFeed url -> Hamlet url
|
|
||||||
template arg =
|
|
||||||
#if GHC7
|
|
||||||
[xhamlet|
|
|
||||||
#else
|
|
||||||
[$xhamlet|
|
|
||||||
#endif
|
|
||||||
<?xml version="1.0" encoding="utf-8"?>
|
|
||||||
%feed!xmlns="http://www.w3.org/2005/Atom"
|
|
||||||
%title $atomTitle.arg$
|
|
||||||
%link!rel=self!href=@atomLinkSelf.arg@
|
|
||||||
%link!href=@atomLinkHome.arg@
|
|
||||||
%updated $formatW3.atomUpdated.arg$
|
|
||||||
%id @atomLinkHome.arg@
|
|
||||||
$forall atomEntries.arg entry
|
|
||||||
^entryTemplate.entry^
|
|
||||||
|]
|
|
||||||
|
|
||||||
entryTemplate :: AtomFeedEntry url -> Hamlet url
|
|
||||||
entryTemplate arg =
|
|
||||||
#if GHC7
|
|
||||||
[xhamlet|
|
|
||||||
#else
|
|
||||||
[$xhamlet|
|
|
||||||
#endif
|
|
||||||
%entry
|
|
||||||
%id @atomEntryLink.arg@
|
|
||||||
%link!href=@atomEntryLink.arg@
|
|
||||||
%updated $formatW3.atomEntryUpdated.arg$
|
|
||||||
%title $atomEntryTitle.arg$
|
|
||||||
%content!type=html $cdata.atomEntryContent.arg$
|
|
||||||
|]
|
|
||||||
|
|
||||||
-- | Generates a link tag in the head of a widget.
|
|
||||||
atomLink :: Route m
|
|
||||||
-> String -- ^ title
|
|
||||||
-> GWidget s m ()
|
|
||||||
atomLink u title = addHamletHead
|
|
||||||
#if GHC7
|
|
||||||
[hamlet|
|
|
||||||
#else
|
|
||||||
[$hamlet|
|
|
||||||
#endif
|
|
||||||
%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$
|
|
||||||
|]
|
|
||||||
@ -1,79 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Yesod.Helpers.Sitemap
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- Stability : Stable
|
|
||||||
-- Portability : portable
|
|
||||||
--
|
|
||||||
-- Generating Google sitemap files.
|
|
||||||
--
|
|
||||||
---------------------------------------------------------
|
|
||||||
|
|
||||||
-- | Generates XML sitemap files.
|
|
||||||
--
|
|
||||||
-- See <http://www.sitemaps.org/>.
|
|
||||||
module Yesod.Helpers.Sitemap
|
|
||||||
( sitemap
|
|
||||||
, robots
|
|
||||||
, SitemapUrl (..)
|
|
||||||
, SitemapChangeFreq (..)
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Yesod
|
|
||||||
import Data.Time (UTCTime)
|
|
||||||
|
|
||||||
data SitemapChangeFreq = Always
|
|
||||||
| Hourly
|
|
||||||
| Daily
|
|
||||||
| Weekly
|
|
||||||
| Monthly
|
|
||||||
| Yearly
|
|
||||||
| Never
|
|
||||||
|
|
||||||
showFreq :: SitemapChangeFreq -> String
|
|
||||||
showFreq Always = "always"
|
|
||||||
showFreq Hourly = "hourly"
|
|
||||||
showFreq Daily = "daily"
|
|
||||||
showFreq Weekly = "weekly"
|
|
||||||
showFreq Monthly = "monthly"
|
|
||||||
showFreq Yearly = "yearly"
|
|
||||||
showFreq Never = "never"
|
|
||||||
|
|
||||||
data SitemapUrl url = SitemapUrl
|
|
||||||
{ sitemapLoc :: url
|
|
||||||
, sitemapLastMod :: UTCTime
|
|
||||||
, sitemapChangeFreq :: SitemapChangeFreq
|
|
||||||
, priority :: Double
|
|
||||||
}
|
|
||||||
|
|
||||||
template :: [SitemapUrl url] -> Hamlet url
|
|
||||||
template urls =
|
|
||||||
#if GHC7
|
|
||||||
[xhamlet|
|
|
||||||
#else
|
|
||||||
[$xhamlet|
|
|
||||||
#endif
|
|
||||||
%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9"
|
|
||||||
$forall urls url
|
|
||||||
%url
|
|
||||||
%loc @sitemapLoc.url@
|
|
||||||
%lastmod $formatW3.sitemapLastMod.url$
|
|
||||||
%changefreq $showFreq.sitemapChangeFreq.url$
|
|
||||||
%priority $show.priority.url$
|
|
||||||
|]
|
|
||||||
|
|
||||||
sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml
|
|
||||||
sitemap = fmap RepXml . hamletToContent . template
|
|
||||||
|
|
||||||
-- | A basic robots file which just lists the "Sitemap: " line.
|
|
||||||
robots :: Route sub -- ^ sitemap url
|
|
||||||
-> GHandler sub master RepPlain
|
|
||||||
robots smurl = do
|
|
||||||
tm <- getRouteToMaster
|
|
||||||
render <- getUrlRender
|
|
||||||
return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl)
|
|
||||||
@ -1,252 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Yesod.Helpers.Static
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- Stability : Unstable
|
|
||||||
-- Portability : portable
|
|
||||||
--
|
|
||||||
|
|
||||||
-- | Serve static files from a Yesod app.
|
|
||||||
--
|
|
||||||
-- This is most useful for standalone testing. When running on a production
|
|
||||||
-- server (like Apache), just let the server do the static serving.
|
|
||||||
--
|
|
||||||
-- In fact, in an ideal setup you'll serve your static files from a separate
|
|
||||||
-- domain name to save time on transmitting cookies. In that case, you may wish
|
|
||||||
-- to use 'urlRenderOverride' to redirect requests to this subsite to a
|
|
||||||
-- separate domain name.
|
|
||||||
module Yesod.Helpers.Static
|
|
||||||
( -- * Subsite
|
|
||||||
Static (..)
|
|
||||||
, StaticRoute (..)
|
|
||||||
-- * Lookup files in filesystem
|
|
||||||
, fileLookupDir
|
|
||||||
, staticFiles
|
|
||||||
-- * Embed files
|
|
||||||
, mkEmbedFiles
|
|
||||||
, getStaticHandler
|
|
||||||
-- * Hashing
|
|
||||||
, base64md5
|
|
||||||
#if TEST
|
|
||||||
, testSuite
|
|
||||||
#endif
|
|
||||||
) where
|
|
||||||
|
|
||||||
import System.Directory
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
|
|
||||||
import Yesod hiding (lift)
|
|
||||||
import Data.List (intercalate)
|
|
||||||
import Language.Haskell.TH
|
|
||||||
import Language.Haskell.TH.Syntax
|
|
||||||
import Web.Routes
|
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Data.Digest.Pure.MD5
|
|
||||||
import qualified Data.ByteString.Base64
|
|
||||||
import qualified Data.ByteString.Char8 as S8
|
|
||||||
import qualified Data.Serialize
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Test.Framework (testGroup, Test)
|
|
||||||
import Test.Framework.Providers.HUnit
|
|
||||||
import Test.HUnit hiding (Test)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | A function for looking up file contents. For serving from the file system,
|
|
||||||
-- see 'fileLookupDir'.
|
|
||||||
data Static = Static
|
|
||||||
{ staticLookup :: FilePath -> IO (Maybe (Either FilePath Content))
|
|
||||||
-- | Mapping from file extension to content type. See 'typeByExt'.
|
|
||||||
, staticTypes :: [(String, ContentType)]
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Manually construct a static route.
|
|
||||||
-- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string.
|
|
||||||
-- For example,
|
|
||||||
-- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")]
|
|
||||||
-- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc'
|
|
||||||
-- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time.
|
|
||||||
-- E.g. When generating image galleries.
|
|
||||||
data StaticRoute = StaticRoute [String] [(String, String)]
|
|
||||||
deriving (Eq, Show, Read)
|
|
||||||
|
|
||||||
type instance Route Static = StaticRoute
|
|
||||||
|
|
||||||
instance YesodSubSite Static master where
|
|
||||||
getSubSite = Site
|
|
||||||
{ handleSite = \_ (StaticRoute ps _) m ->
|
|
||||||
case m of
|
|
||||||
"GET" -> Just $ fmap chooseRep $ getStaticRoute ps
|
|
||||||
_ -> Nothing
|
|
||||||
, formatPathSegments = \(StaticRoute x y) -> (x, y)
|
|
||||||
, parsePathSegments = \x -> Right $ StaticRoute x []
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Lookup files in a specific directory.
|
|
||||||
--
|
|
||||||
-- If you are just using this in combination with the static subsite (you
|
|
||||||
-- probably are), the handler itself checks that no unsafe paths are being
|
|
||||||
-- requested. In particular, no path segments may begin with a single period,
|
|
||||||
-- so hidden files and parent directories are safe.
|
|
||||||
--
|
|
||||||
-- For the second argument to this function, you can just use 'typeByExt'.
|
|
||||||
fileLookupDir :: FilePath -> [(String, ContentType)] -> Static
|
|
||||||
fileLookupDir dir = Static $ \fp -> do
|
|
||||||
let fp' = dir ++ '/' : fp
|
|
||||||
exists <- doesFileExist fp'
|
|
||||||
if exists
|
|
||||||
then return $ Just $ Left fp'
|
|
||||||
else return Nothing
|
|
||||||
|
|
||||||
-- | Lookup files in a specific directory, and embed them into the haskell source.
|
|
||||||
--
|
|
||||||
-- A variation of fileLookupDir which allows subsites distributed via cabal to include
|
|
||||||
-- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler
|
|
||||||
-- for dispatching static content for a subsite.
|
|
||||||
mkEmbedFiles :: FilePath -> Q Exp
|
|
||||||
mkEmbedFiles d = do
|
|
||||||
fs <- qRunIO $ getFileList d
|
|
||||||
clauses <- mapM (mkClause . intercalate "/") fs
|
|
||||||
defC <- defaultClause
|
|
||||||
return $ static $ clauses ++ [defC]
|
|
||||||
where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f
|
|
||||||
f = mkName "f"
|
|
||||||
fun clauses = FunD f clauses
|
|
||||||
defaultClause = do
|
|
||||||
b <- [| return Nothing |]
|
|
||||||
return $ Clause [WildP] (NormalB b) []
|
|
||||||
|
|
||||||
mkClause path = do
|
|
||||||
content <- qRunIO $ readFile $ d ++ '/':path
|
|
||||||
let pat = LitP $ StringL path
|
|
||||||
foldAppE = foldl1 AppE
|
|
||||||
content' = return $ LitE $ StringL $ content
|
|
||||||
body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |]
|
|
||||||
return $ Clause [pat] body []
|
|
||||||
|
|
||||||
-- | Dispatch static route for a subsite
|
|
||||||
--
|
|
||||||
-- Subsites with static routes can't (yet) define Static routes the same way "master" sites can.
|
|
||||||
-- Instead of a subsite route:
|
|
||||||
-- /static StaticR Static getStatic
|
|
||||||
-- Use a normal route:
|
|
||||||
-- /static/*Strings StaticR GET
|
|
||||||
--
|
|
||||||
-- Then, define getStaticR something like:
|
|
||||||
-- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR
|
|
||||||
-- */ end CPP comment
|
|
||||||
getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep
|
|
||||||
getStaticHandler static toSubR pieces = do
|
|
||||||
toMasterR <- getRouteToMaster
|
|
||||||
toMasterHandler (toMasterR . toSubR) toSub route handler
|
|
||||||
where route = StaticRoute pieces []
|
|
||||||
toSub _ = static
|
|
||||||
staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep))
|
|
||||||
handler = fromMaybe notFound $ handleSite staticSite undefined route "GET"
|
|
||||||
|
|
||||||
getStaticRoute :: [String]
|
|
||||||
-> GHandler Static master (ContentType, Content)
|
|
||||||
getStaticRoute fp' = do
|
|
||||||
Static fl ctypes <- getYesodSub
|
|
||||||
when (any isUnsafe fp') notFound
|
|
||||||
let fp = intercalate "/" fp'
|
|
||||||
content <- liftIO $ fl fp
|
|
||||||
case content of
|
|
||||||
Nothing -> notFound
|
|
||||||
Just (Left fp'') -> do
|
|
||||||
let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes
|
|
||||||
sendFile ctype fp''
|
|
||||||
Just (Right bs) -> do
|
|
||||||
let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes
|
|
||||||
return (ctype, bs)
|
|
||||||
where
|
|
||||||
isUnsafe [] = True
|
|
||||||
isUnsafe ('.':_) = True
|
|
||||||
isUnsafe _ = False
|
|
||||||
|
|
||||||
notHidden :: FilePath -> Bool
|
|
||||||
notHidden ('.':_) = False
|
|
||||||
notHidden "tmp" = False
|
|
||||||
notHidden _ = True
|
|
||||||
|
|
||||||
getFileList :: FilePath -> IO [[String]]
|
|
||||||
getFileList = flip go id
|
|
||||||
where
|
|
||||||
go :: String -> ([String] -> [String]) -> IO [[String]]
|
|
||||||
go fp front = do
|
|
||||||
allContents <- filter notHidden `fmap` getDirectoryContents fp
|
|
||||||
let fullPath :: String -> String
|
|
||||||
fullPath f = fp ++ '/' : f
|
|
||||||
files <- filterM (doesFileExist . fullPath) allContents
|
|
||||||
let files' = map (front . return) files
|
|
||||||
dirs <- filterM (doesDirectoryExist . fullPath) allContents
|
|
||||||
dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs
|
|
||||||
return $ concat $ files' : dirs'
|
|
||||||
|
|
||||||
-- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create:
|
|
||||||
--
|
|
||||||
-- > style_css = StaticRoute ["style.css"] []
|
|
||||||
-- > js_script_js = StaticRoute ["js/script.js"] []
|
|
||||||
staticFiles :: FilePath -> Q [Dec]
|
|
||||||
staticFiles fp = do
|
|
||||||
fs <- qRunIO $ getFileList fp
|
|
||||||
concat `fmap` mapM go fs
|
|
||||||
where
|
|
||||||
replace' c
|
|
||||||
| 'A' <= c && c <= 'Z' = c
|
|
||||||
| 'a' <= c && c <= 'z' = c
|
|
||||||
| '0' <= c && c <= '9' = c
|
|
||||||
| otherwise = '_'
|
|
||||||
go f = do
|
|
||||||
let name = mkName $ intercalate "_" $ map (map replace') f
|
|
||||||
f' <- lift f
|
|
||||||
let sr = ConE $ mkName "StaticRoute"
|
|
||||||
hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f
|
|
||||||
let qs = ListE [TupE [LitE $ StringL hash, ListE []]]
|
|
||||||
return
|
|
||||||
[ SigD name $ ConT ''Route `AppT` ConT ''Static
|
|
||||||
, FunD name
|
|
||||||
[ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) []
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
|
|
||||||
testSuite :: Test
|
|
||||||
testSuite = testGroup "Yesod.Helpers.Static"
|
|
||||||
[ testCase "get file list" caseGetFileList
|
|
||||||
]
|
|
||||||
|
|
||||||
caseGetFileList :: Assertion
|
|
||||||
caseGetFileList = do
|
|
||||||
x <- getFileList "test"
|
|
||||||
x @?= [["foo"], ["bar", "baz"]]
|
|
||||||
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | md5-hashes the given lazy bytestring and returns the hash as
|
|
||||||
-- base64url-encoded string.
|
|
||||||
--
|
|
||||||
-- This function returns the first 8 characters of the hash.
|
|
||||||
base64md5 :: L.ByteString -> String
|
|
||||||
base64md5 = map go
|
|
||||||
. take 8
|
|
||||||
. S8.unpack
|
|
||||||
. Data.ByteString.Base64.encode
|
|
||||||
. Data.Serialize.encode
|
|
||||||
. md5
|
|
||||||
where
|
|
||||||
go '+' = '-'
|
|
||||||
go '/' = '_'
|
|
||||||
go c = c
|
|
||||||
@ -1,103 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
-- | Normal users should never need access to these.
|
|
||||||
module Yesod.Internal
|
|
||||||
( -- * Error responses
|
|
||||||
ErrorResponse (..)
|
|
||||||
-- * Header
|
|
||||||
, Header (..)
|
|
||||||
-- * Cookie names
|
|
||||||
, langKey
|
|
||||||
-- * Widgets
|
|
||||||
, Location (..)
|
|
||||||
, UniqueList (..)
|
|
||||||
, Script (..)
|
|
||||||
, Stylesheet (..)
|
|
||||||
, Title (..)
|
|
||||||
, Head (..)
|
|
||||||
, Body (..)
|
|
||||||
, locationToHamlet
|
|
||||||
, runUniqueList
|
|
||||||
, toUnique
|
|
||||||
-- * UTF8 helpers
|
|
||||||
, bsToChars
|
|
||||||
, lbsToChars
|
|
||||||
, charsToBs
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Text.Hamlet (Hamlet, hamlet, Html)
|
|
||||||
import Data.Monoid (Monoid (..))
|
|
||||||
import Data.List (nub)
|
|
||||||
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.Encoding.Error as T
|
|
||||||
|
|
||||||
import qualified Data.Text.Lazy as LT
|
|
||||||
import qualified Data.Text.Lazy.Encoding as LT
|
|
||||||
|
|
||||||
#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 String
|
|
||||||
| InvalidArgs [String]
|
|
||||||
| PermissionDenied String
|
|
||||||
| BadMethod String
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
----- header stuff
|
|
||||||
-- | Headers to be added to a 'Result'.
|
|
||||||
data Header =
|
|
||||||
AddCookie Int String String
|
|
||||||
| DeleteCookie String
|
|
||||||
| Header String String
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
langKey :: String
|
|
||||||
langKey = "_LANG"
|
|
||||||
|
|
||||||
data Location url = Local url | Remote String
|
|
||||||
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 . (:)
|
|
||||||
|
|
||||||
newtype Script url = Script { unScript :: Location url }
|
|
||||||
deriving (Show, Eq)
|
|
||||||
newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }
|
|
||||||
deriving (Show, Eq)
|
|
||||||
newtype Title = Title { unTitle :: Html }
|
|
||||||
|
|
||||||
newtype Head url = Head (Hamlet url)
|
|
||||||
deriving Monoid
|
|
||||||
newtype Body url = Body (Hamlet url)
|
|
||||||
deriving Monoid
|
|
||||||
|
|
||||||
lbsToChars :: L.ByteString -> String
|
|
||||||
lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode
|
|
||||||
|
|
||||||
bsToChars :: S.ByteString -> String
|
|
||||||
bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
|
|
||||||
|
|
||||||
charsToBs :: String -> S.ByteString
|
|
||||||
charsToBs = T.encodeUtf8 . T.pack
|
|
||||||
168
Yesod/Request.hs
168
Yesod/Request.hs
@ -1,168 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE PackageImports #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- 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 (..)
|
|
||||||
, RequestReader (..)
|
|
||||||
, FileInfo (..)
|
|
||||||
-- * Convenience functions
|
|
||||||
, waiRequest
|
|
||||||
, languages
|
|
||||||
-- * Lookup parameters
|
|
||||||
, lookupGetParam
|
|
||||||
, lookupPostParam
|
|
||||||
, lookupCookie
|
|
||||||
, lookupFile
|
|
||||||
-- ** Multi-lookup
|
|
||||||
, lookupGetParams
|
|
||||||
, lookupPostParams
|
|
||||||
, lookupCookies
|
|
||||||
, lookupFiles
|
|
||||||
-- * Parameter type synonyms
|
|
||||||
, ParamName
|
|
||||||
, ParamValue
|
|
||||||
, ParamError
|
|
||||||
) where
|
|
||||||
|
|
||||||
import qualified Network.Wai as W
|
|
||||||
import qualified Data.ByteString.Lazy as BL
|
|
||||||
import "transformers" Control.Monad.IO.Class
|
|
||||||
import Control.Monad (liftM)
|
|
||||||
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
|
|
||||||
import Data.Maybe (listToMaybe)
|
|
||||||
|
|
||||||
type ParamName = String
|
|
||||||
type ParamValue = String
|
|
||||||
type ParamError = String
|
|
||||||
|
|
||||||
-- | The reader monad specialized for 'Request'.
|
|
||||||
class Monad m => RequestReader m where
|
|
||||||
getRequest :: m Request
|
|
||||||
instance RequestReader ((->) Request) where
|
|
||||||
getRequest = id
|
|
||||||
|
|
||||||
-- | 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 the parseWaiRequest function in Yesod.Dispatch (not
|
|
||||||
-- exposed).
|
|
||||||
languages :: RequestReader m => m [String]
|
|
||||||
languages = reqLangs `liftM` getRequest
|
|
||||||
|
|
||||||
-- | Get the request\'s 'W.Request' value.
|
|
||||||
waiRequest :: RequestReader m => m W.Request
|
|
||||||
waiRequest = reqWaiRequest `liftM` getRequest
|
|
||||||
|
|
||||||
-- | A tuple containing both the POST parameters and submitted files.
|
|
||||||
type RequestBodyContents =
|
|
||||||
( [(ParamName, ParamValue)]
|
|
||||||
, [(ParamName, FileInfo)]
|
|
||||||
)
|
|
||||||
|
|
||||||
data FileInfo = FileInfo
|
|
||||||
{ fileName :: String
|
|
||||||
, fileContentType :: String
|
|
||||||
, fileContent :: BL.ByteString
|
|
||||||
}
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | The parsed request information.
|
|
||||||
data Request = Request
|
|
||||||
{ reqGetParams :: [(ParamName, ParamValue)]
|
|
||||||
, reqCookies :: [(ParamName, ParamValue)]
|
|
||||||
-- | The POST parameters and submitted files. This is stored in an IO
|
|
||||||
-- thunk, which essentially means it will be computed once at most, but
|
|
||||||
-- only if requested. This allows avoidance of the potentially costly
|
|
||||||
-- parsing of POST bodies for pages which do not use them.
|
|
||||||
--
|
|
||||||
-- Additionally, since the request body is not read until needed, you can
|
|
||||||
-- directly access the 'W.requestBody' record in 'reqWaiRequest' and
|
|
||||||
-- perform other forms of parsing. For example, when designing a web
|
|
||||||
-- service, you may want to accept JSON-encoded data. Just be aware that
|
|
||||||
-- if you do such parsing, the standard POST form parsing functions will
|
|
||||||
-- no longer work.
|
|
||||||
, reqRequestBody :: IO RequestBodyContents
|
|
||||||
, reqWaiRequest :: W.Request
|
|
||||||
-- | Languages which the client supports.
|
|
||||||
, reqLangs :: [String]
|
|
||||||
-- | A random, session-specific nonce used to prevent CSRF attacks.
|
|
||||||
, reqNonce :: String
|
|
||||||
}
|
|
||||||
|
|
||||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
|
||||||
lookup' a = map snd . filter (\x -> a == fst x)
|
|
||||||
|
|
||||||
-- | Lookup for GET parameters.
|
|
||||||
lookupGetParams :: RequestReader m => ParamName -> m [ParamValue]
|
|
||||||
lookupGetParams pn = do
|
|
||||||
rr <- getRequest
|
|
||||||
return $ lookup' pn $ reqGetParams rr
|
|
||||||
|
|
||||||
-- | Lookup for GET parameters.
|
|
||||||
lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)
|
|
||||||
lookupGetParam = liftM listToMaybe . lookupGetParams
|
|
||||||
|
|
||||||
-- | Lookup for POST parameters.
|
|
||||||
lookupPostParams :: (MonadIO m, RequestReader m)
|
|
||||||
=> ParamName
|
|
||||||
-> m [ParamValue]
|
|
||||||
lookupPostParams pn = do
|
|
||||||
rr <- getRequest
|
|
||||||
(pp, _) <- liftIO $ reqRequestBody rr
|
|
||||||
return $ lookup' pn pp
|
|
||||||
|
|
||||||
lookupPostParam :: (MonadIO m, RequestReader m)
|
|
||||||
=> ParamName
|
|
||||||
-> m (Maybe ParamValue)
|
|
||||||
lookupPostParam = liftM listToMaybe . lookupPostParams
|
|
||||||
|
|
||||||
-- | Lookup for POSTed files.
|
|
||||||
lookupFile :: (MonadIO m, RequestReader m)
|
|
||||||
=> ParamName
|
|
||||||
-> m (Maybe FileInfo)
|
|
||||||
lookupFile = liftM listToMaybe . lookupFiles
|
|
||||||
|
|
||||||
-- | Lookup for POSTed files.
|
|
||||||
lookupFiles :: (MonadIO m, RequestReader m)
|
|
||||||
=> ParamName
|
|
||||||
-> m [FileInfo]
|
|
||||||
lookupFiles pn = do
|
|
||||||
rr <- getRequest
|
|
||||||
(_, files) <- liftIO $ reqRequestBody rr
|
|
||||||
return $ lookup' pn files
|
|
||||||
|
|
||||||
-- | Lookup for cookie data.
|
|
||||||
lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)
|
|
||||||
lookupCookie = liftM listToMaybe . lookupCookies
|
|
||||||
|
|
||||||
-- | Lookup for cookie data.
|
|
||||||
lookupCookies :: RequestReader m => ParamName -> m [ParamValue]
|
|
||||||
lookupCookies pn = do
|
|
||||||
rr <- getRequest
|
|
||||||
return $ lookup' pn $ reqCookies rr
|
|
||||||
189
Yesod/Widget.hs
189
Yesod/Widget.hs
@ -1,189 +0,0 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE PackageImports #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
-- | 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 (..)
|
|
||||||
, liftHandler
|
|
||||||
-- * Creating
|
|
||||||
-- ** Head of page
|
|
||||||
, setTitle
|
|
||||||
, addHamletHead
|
|
||||||
, addHtmlHead
|
|
||||||
-- ** Body
|
|
||||||
, addHamlet
|
|
||||||
, addHtml
|
|
||||||
, addWidget
|
|
||||||
, addSubWidget
|
|
||||||
-- ** CSS
|
|
||||||
, addCassius
|
|
||||||
, addStylesheet
|
|
||||||
, addStylesheetRemote
|
|
||||||
, addStylesheetEither
|
|
||||||
-- ** Javascript
|
|
||||||
, addJulius
|
|
||||||
, addScript
|
|
||||||
, addScriptRemote
|
|
||||||
, addScriptEither
|
|
||||||
-- * Utilities
|
|
||||||
, extractBody
|
|
||||||
, newIdent
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Monoid
|
|
||||||
import Control.Monad.Trans.Writer
|
|
||||||
import Control.Monad.Trans.State
|
|
||||||
import Text.Hamlet
|
|
||||||
import Text.Cassius
|
|
||||||
import Text.Julius
|
|
||||||
import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
|
|
||||||
import Control.Applicative (Applicative)
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
|
||||||
import Yesod.Internal
|
|
||||||
|
|
||||||
import Control.Monad.IO.Peel (MonadPeelIO)
|
|
||||||
|
|
||||||
-- | 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 GWidget s m a = GWidget { unGWidget :: GWInner s m a }
|
|
||||||
deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
|
|
||||||
type GWInner sub master =
|
|
||||||
WriterT (Body (Route master)) (
|
|
||||||
WriterT (Last Title) (
|
|
||||||
WriterT (UniqueList (Script (Route master))) (
|
|
||||||
WriterT (UniqueList (Stylesheet (Route master))) (
|
|
||||||
WriterT (Maybe (Cassius (Route master))) (
|
|
||||||
WriterT (Maybe (Julius (Route master))) (
|
|
||||||
WriterT (Head (Route master)) (
|
|
||||||
StateT Int (
|
|
||||||
GHandler sub master
|
|
||||||
))))))))
|
|
||||||
instance Monoid (GWidget sub master ()) where
|
|
||||||
mempty = return ()
|
|
||||||
mappend x y = x >> y
|
|
||||||
|
|
||||||
instance HamletValue (GWidget s m ()) where
|
|
||||||
newtype HamletMonad (GWidget s m ()) a =
|
|
||||||
GWidget' { runGWidget' :: GWidget s m a }
|
|
||||||
type HamletUrl (GWidget s m ()) = Route m
|
|
||||||
toHamletValue = runGWidget'
|
|
||||||
htmlToHamletMonad = GWidget' . addHtml
|
|
||||||
urlToHamletMonad url params = GWidget' $
|
|
||||||
addHamlet $ \r -> preEscapedString (r url params)
|
|
||||||
fromHamletValue = GWidget'
|
|
||||||
instance Monad (HamletMonad (GWidget s m ())) where
|
|
||||||
return = GWidget' . return
|
|
||||||
x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y
|
|
||||||
|
|
||||||
-- | Lift an action in the 'GHandler' monad into an action in the 'GWidget'
|
|
||||||
-- monad.
|
|
||||||
liftHandler :: GHandler sub master a -> GWidget sub master a
|
|
||||||
liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift
|
|
||||||
|
|
||||||
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
|
|
||||||
addSubWidget sub w = do master <- liftHandler getYesod
|
|
||||||
let sr = fromSubRoute sub master
|
|
||||||
i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get
|
|
||||||
w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i
|
|
||||||
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
|
|
||||||
$ runWriterT $ runWriterT $ runWriterT
|
|
||||||
$ unGWidget w
|
|
||||||
let ((((((((a,
|
|
||||||
body),
|
|
||||||
title),
|
|
||||||
scripts),
|
|
||||||
stylesheets),
|
|
||||||
style),
|
|
||||||
jscript),
|
|
||||||
h),
|
|
||||||
i') = w'
|
|
||||||
GWidget $ do
|
|
||||||
tell body
|
|
||||||
lift $ tell title
|
|
||||||
lift $ lift $ tell scripts
|
|
||||||
lift $ lift $ lift $ tell stylesheets
|
|
||||||
lift $ lift $ lift $ lift $ tell style
|
|
||||||
lift $ lift $ lift $ lift $ lift $ tell jscript
|
|
||||||
lift $ lift $ lift $ lift $ lift $ lift $ tell h
|
|
||||||
lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i'
|
|
||||||
return a
|
|
||||||
|
|
||||||
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
|
|
||||||
-- set values.
|
|
||||||
setTitle :: Html -> GWidget sub master ()
|
|
||||||
setTitle = GWidget . lift . tell . Last . Just . Title
|
|
||||||
|
|
||||||
-- | Add a 'Hamlet' to the head tag.
|
|
||||||
addHamletHead :: Hamlet (Route master) -> GWidget sub master ()
|
|
||||||
addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head
|
|
||||||
|
|
||||||
-- | Add a 'Html' to the head tag.
|
|
||||||
addHtmlHead :: Html -> GWidget sub master ()
|
|
||||||
addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const
|
|
||||||
|
|
||||||
-- | Add a 'Hamlet' to the body tag.
|
|
||||||
addHamlet :: Hamlet (Route master) -> GWidget sub master ()
|
|
||||||
addHamlet = GWidget . tell . Body
|
|
||||||
|
|
||||||
-- | Add a 'Html' to the body tag.
|
|
||||||
addHtml :: Html -> GWidget sub master ()
|
|
||||||
addHtml = GWidget . tell . Body . const
|
|
||||||
|
|
||||||
-- | Add another widget. This is defined as 'id', by can help with types, and
|
|
||||||
-- makes widget blocks look more consistent.
|
|
||||||
addWidget :: GWidget s m () -> GWidget s m ()
|
|
||||||
addWidget = id
|
|
||||||
|
|
||||||
-- | Get a unique identifier.
|
|
||||||
newIdent :: GWidget sub master String
|
|
||||||
newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do
|
|
||||||
i <- get
|
|
||||||
let i' = i + 1
|
|
||||||
put i'
|
|
||||||
return $ "w" ++ show i'
|
|
||||||
|
|
||||||
-- | Add some raw CSS to the style tag.
|
|
||||||
addCassius :: Cassius (Route master) -> GWidget sub master ()
|
|
||||||
addCassius = GWidget . lift . lift . lift . lift . tell . Just
|
|
||||||
|
|
||||||
-- | Link to the specified local stylesheet.
|
|
||||||
addStylesheet :: Route master -> GWidget sub master ()
|
|
||||||
addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local
|
|
||||||
|
|
||||||
-- | Link to the specified remote stylesheet.
|
|
||||||
addStylesheetRemote :: String -> GWidget sub master ()
|
|
||||||
addStylesheetRemote =
|
|
||||||
GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote
|
|
||||||
|
|
||||||
addStylesheetEither :: Either (Route master) String -> GWidget sub master ()
|
|
||||||
addStylesheetEither = either addStylesheet addStylesheetRemote
|
|
||||||
|
|
||||||
addScriptEither :: Either (Route master) String -> GWidget sub master ()
|
|
||||||
addScriptEither = either addScript addScriptRemote
|
|
||||||
|
|
||||||
-- | Link to the specified local script.
|
|
||||||
addScript :: Route master -> GWidget sub master ()
|
|
||||||
addScript = GWidget . lift . lift . tell . toUnique . Script . Local
|
|
||||||
|
|
||||||
-- | Link to the specified remote script.
|
|
||||||
addScriptRemote :: String -> GWidget sub master ()
|
|
||||||
addScriptRemote =
|
|
||||||
GWidget . lift . lift . tell . toUnique . Script . Remote
|
|
||||||
|
|
||||||
-- | Include raw Javascript in the page's script tag.
|
|
||||||
addJulius :: Julius (Route master) -> GWidget sub master ()
|
|
||||||
addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just
|
|
||||||
|
|
||||||
-- | 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 :: GWidget s m () -> GWidget s m (Hamlet (Route m))
|
|
||||||
extractBody (GWidget w) =
|
|
||||||
GWidget $ mapWriterT (fmap go) w
|
|
||||||
where
|
|
||||||
go ((), Body h) = (h, Body mempty)
|
|
||||||
537
Yesod/Yesod.hs
537
Yesod/Yesod.hs
@ -1,537 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
-- | The basic typeclass for a Yesod application.
|
|
||||||
module Yesod.Yesod
|
|
||||||
( -- * Type classes
|
|
||||||
Yesod (..)
|
|
||||||
, YesodSite (..)
|
|
||||||
, YesodSubSite (..)
|
|
||||||
-- ** Breadcrumbs
|
|
||||||
, YesodBreadcrumbs (..)
|
|
||||||
, breadcrumbs
|
|
||||||
-- * Utitlities
|
|
||||||
, maybeAuthorized
|
|
||||||
, widgetToPageContent
|
|
||||||
, defaultLayoutJson
|
|
||||||
, jsonToRepJson
|
|
||||||
, redirectToPost
|
|
||||||
-- * Defaults
|
|
||||||
, defaultErrorHandler
|
|
||||||
-- * Data types
|
|
||||||
, AuthResult (..)
|
|
||||||
-- * Misc
|
|
||||||
, yesodVersion
|
|
||||||
#if TEST
|
|
||||||
, testSuite
|
|
||||||
#endif
|
|
||||||
) where
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Yesod.Content hiding (testSuite)
|
|
||||||
import Yesod.Handler hiding (testSuite)
|
|
||||||
import qualified Data.ByteString.UTF8 as BSU
|
|
||||||
#else
|
|
||||||
import Yesod.Content
|
|
||||||
import Yesod.Handler
|
|
||||||
#endif
|
|
||||||
|
|
||||||
import qualified Paths_yesod
|
|
||||||
import Data.Version (showVersion)
|
|
||||||
import Yesod.Widget
|
|
||||||
import Yesod.Request
|
|
||||||
import Yesod.Hamlet
|
|
||||||
import qualified Network.Wai as W
|
|
||||||
import Yesod.Internal
|
|
||||||
import Web.ClientSession (getKey, defaultKeyFile)
|
|
||||||
import qualified Web.ClientSession as CS
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
import qualified Data.ByteString.Char8 as S8
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import Data.Monoid
|
|
||||||
import Control.Monad.Trans.Writer
|
|
||||||
import Control.Monad.Trans.State hiding (get)
|
|
||||||
import Text.Hamlet
|
|
||||||
import Text.Cassius
|
|
||||||
import Text.Julius
|
|
||||||
import Web.Routes
|
|
||||||
import qualified Data.JSON.Types as J
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
import Test.Framework (testGroup, Test)
|
|
||||||
import Test.Framework.Providers.HUnit
|
|
||||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
|
||||||
import Test.HUnit hiding (Test)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if GHC7
|
|
||||||
#define HAMLET hamlet
|
|
||||||
#else
|
|
||||||
#define HAMLET $hamlet
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | This class is automatically instantiated when you use the template haskell
|
|
||||||
-- mkYesod function. You should never need to deal with it directly.
|
|
||||||
class Eq (Route y) => YesodSite y where
|
|
||||||
getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep))
|
|
||||||
type Method = String
|
|
||||||
|
|
||||||
-- | Same as 'YesodSite', but for subsites. Once again, users should not need
|
|
||||||
-- to deal with it directly, as the mkYesodSub creates instances appropriately.
|
|
||||||
class Eq (Route s) => YesodSubSite s y where
|
|
||||||
getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))
|
|
||||||
getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))
|
|
||||||
getSiteFromSubSite _ = getSubSite
|
|
||||||
|
|
||||||
-- | Define settings for a Yesod applications. The only required setting is
|
|
||||||
-- 'approot'; other than that, there are intelligent defaults.
|
|
||||||
class Eq (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 -> String
|
|
||||||
|
|
||||||
-- | The encryption key to be used for encrypting client sessions.
|
|
||||||
encryptKey :: a -> IO CS.Key
|
|
||||||
encryptKey _ = getKey defaultKeyFile
|
|
||||||
|
|
||||||
-- | Whether or not to use client sessions.
|
|
||||||
--
|
|
||||||
-- FIXME: A better API would be to have 'encryptKey' return a Maybe, but
|
|
||||||
-- that would be a breaking change. Please include in Yesod 0.7.
|
|
||||||
enableClientSessions :: a -> Bool
|
|
||||||
enableClientSessions _ = True
|
|
||||||
|
|
||||||
-- | 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 mmsg msg
|
|
||||||
%p.message $msg$
|
|
||||||
^pageBody.p^
|
|
||||||
|]
|
|
||||||
|
|
||||||
-- | Gets called at the beginning of each request. Useful for logging.
|
|
||||||
onRequest :: GHandler sub a ()
|
|
||||||
onRequest = return ()
|
|
||||||
|
|
||||||
-- | 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 String
|
|
||||||
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 $ not $ W.requestMethod wai `elem`
|
|
||||||
["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 split a raw PATH_INFO value into path pieces. It
|
|
||||||
-- returns a 'Left' value when you should redirect to the given path, and a
|
|
||||||
-- 'Right' value on successful parse.
|
|
||||||
--
|
|
||||||
-- By default, it splits paths on slashes, and ensures the following are true:
|
|
||||||
--
|
|
||||||
-- * No double slashes
|
|
||||||
--
|
|
||||||
-- * If the last path segment has a period, there is no trailing slash.
|
|
||||||
--
|
|
||||||
-- * Otherwise, ensures there /is/ a trailing slash.
|
|
||||||
splitPath :: a -> S.ByteString -> Either S.ByteString [String]
|
|
||||||
splitPath _ s =
|
|
||||||
if corrected == s
|
|
||||||
then Right $ filter (not . null)
|
|
||||||
$ decodePathInfo
|
|
||||||
$ S8.unpack s
|
|
||||||
else Left corrected
|
|
||||||
where
|
|
||||||
corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s
|
|
||||||
|
|
||||||
-- | Remove double slashes
|
|
||||||
rds :: String -> String
|
|
||||||
rds [] = []
|
|
||||||
rds [x] = [x]
|
|
||||||
rds (a:b:c)
|
|
||||||
| a == '/' && b == '/' = rds (b:c)
|
|
||||||
| otherwise = a : rds (b:c)
|
|
||||||
|
|
||||||
-- | Add a trailing slash if it is missing. Empty string is left alone.
|
|
||||||
ats :: String -> String
|
|
||||||
ats [] = []
|
|
||||||
ats t =
|
|
||||||
if last t == '/' || dbs (reverse t)
|
|
||||||
then t
|
|
||||||
else t ++ "/"
|
|
||||||
|
|
||||||
-- | Remove a trailing slash if the last piece has a period.
|
|
||||||
rts :: String -> String
|
|
||||||
rts [] = []
|
|
||||||
rts t =
|
|
||||||
if last t == '/' && dbs (tail $ reverse t)
|
|
||||||
then init t
|
|
||||||
else t
|
|
||||||
|
|
||||||
-- | Is there a period before a slash here?
|
|
||||||
dbs :: String -> Bool
|
|
||||||
dbs ('/':_) = False
|
|
||||||
dbs (_:'.':_) = True
|
|
||||||
dbs (_:x) = dbs x
|
|
||||||
dbs [] = False
|
|
||||||
|
|
||||||
|
|
||||||
-- | Join the pieces of a path together into an absolute URL. This should
|
|
||||||
-- be the inverse of 'splitPath'.
|
|
||||||
joinPath :: a -> String -> [String] -> [(String, String)] -> String
|
|
||||||
joinPath _ ar pieces qs =
|
|
||||||
ar ++ '/' : encodePathInfo (fixSegs pieces) qs
|
|
||||||
where
|
|
||||||
fixSegs [] = []
|
|
||||||
fixSegs [x]
|
|
||||||
| anyButLast (== '.') x = [x]
|
|
||||||
| otherwise = [x, ""] -- append trailing slash
|
|
||||||
fixSegs (x:xs) = x : fixSegs xs
|
|
||||||
anyButLast _ [] = False
|
|
||||||
anyButLast _ [_] = False
|
|
||||||
anyButLast p (x:xs) = p x || anyButLast p xs
|
|
||||||
|
|
||||||
-- | 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 :: String -- ^ filename extension
|
|
||||||
-> String -- ^ mime-type
|
|
||||||
-> L.ByteString -- ^ content
|
|
||||||
-> GHandler sub a (Maybe (Either String (Route a, [(String, String)])))
|
|
||||||
addStaticContent _ _ _ = return Nothing
|
|
||||||
|
|
||||||
-- | Whether or not to tie a session to a specific IP address. Defaults to
|
|
||||||
-- 'True'.
|
|
||||||
sessionIpAddress :: a -> Bool
|
|
||||||
sessionIpAddress _ = True
|
|
||||||
|
|
||||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
|
|
||||||
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 (String, 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 (String, [(Route y, String)])
|
|
||||||
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
|
|
||||||
|
|
||||||
-- | Provide both an HTML and JSON representation for a piece of data, using
|
|
||||||
-- the default layout for the HTML output ('defaultLayout').
|
|
||||||
defaultLayoutJson :: Yesod master
|
|
||||||
=> GWidget sub master ()
|
|
||||||
-> J.Value
|
|
||||||
-> GHandler sub master RepHtmlJson
|
|
||||||
defaultLayoutJson w json = do
|
|
||||||
RepHtml html' <- defaultLayout w
|
|
||||||
return $ RepHtmlJson html' $ toContent json
|
|
||||||
|
|
||||||
-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'.
|
|
||||||
jsonToRepJson :: J.Value -> GHandler sub master RepJson
|
|
||||||
jsonToRepJson = return . RepJson . toContent
|
|
||||||
|
|
||||||
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' = bsToChars $ W.pathInfo 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 ia msg
|
|
||||||
%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 "$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
|
|
||||||
w' <- flip evalStateT 0
|
|
||||||
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
|
|
||||||
$ runWriterT $ runWriterT $ runWriterT w
|
|
||||||
let ((((((((),
|
|
||||||
Body body),
|
|
||||||
Last mTitle),
|
|
||||||
scripts'),
|
|
||||||
stylesheets'),
|
|
||||||
style),
|
|
||||||
jscript),
|
|
||||||
Head head') = w'
|
|
||||||
let title = maybe mempty unTitle mTitle
|
|
||||||
let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
|
|
||||||
let stylesheets = map (locationToHamlet . unStylesheet)
|
|
||||||
$ runUniqueList stylesheets'
|
|
||||||
let cssToHtml (Css b) = Html b
|
|
||||||
celper :: Cassius url -> Hamlet url
|
|
||||||
celper = fmap cssToHtml
|
|
||||||
jsToHtml (Javascript b) = Html 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
|
|
||||||
cssLoc <-
|
|
||||||
case style of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just s -> do
|
|
||||||
x <- addStaticContent "css" "text/css; charset=utf-8"
|
|
||||||
$ renderCassius render s
|
|
||||||
return $ renderLoc x
|
|
||||||
jsLoc <-
|
|
||||||
case jscript of
|
|
||||||
Nothing -> return Nothing
|
|
||||||
Just s -> do
|
|
||||||
x <- addStaticContent "js" "text/javascript; charset=utf-8"
|
|
||||||
$ renderJulius render s
|
|
||||||
return $ renderLoc x
|
|
||||||
|
|
||||||
let head'' =
|
|
||||||
#if GHC7
|
|
||||||
[hamlet|
|
|
||||||
#else
|
|
||||||
[$hamlet|
|
|
||||||
#endif
|
|
||||||
$forall scripts s
|
|
||||||
%script!src=^s^
|
|
||||||
$forall stylesheets s
|
|
||||||
%link!rel=stylesheet!href=^s^
|
|
||||||
$maybe style s
|
|
||||||
$maybe cssLoc s
|
|
||||||
%link!rel=stylesheet!href=$s$
|
|
||||||
$nothing
|
|
||||||
%style ^celper.s^
|
|
||||||
$maybe jscript j
|
|
||||||
$maybe jsLoc s
|
|
||||||
%script!src=$s$
|
|
||||||
$nothing
|
|
||||||
%script ^jelper.j^
|
|
||||||
^head'^
|
|
||||||
|]
|
|
||||||
return $ PageContent title head'' body
|
|
||||||
|
|
||||||
#if TEST
|
|
||||||
testSuite :: Test
|
|
||||||
testSuite = testGroup "Yesod.Yesod"
|
|
||||||
[ testProperty "join/split path" propJoinSplitPath
|
|
||||||
, testCase "join/split path [\".\"]" caseJoinSplitPathDquote
|
|
||||||
, testCase "utf8 split path" caseUtf8SplitPath
|
|
||||||
, testCase "utf8 join path" caseUtf8JoinPath
|
|
||||||
]
|
|
||||||
|
|
||||||
data TmpYesod = TmpYesod
|
|
||||||
data TmpRoute = TmpRoute deriving Eq
|
|
||||||
type instance Route TmpYesod = TmpRoute
|
|
||||||
instance Yesod TmpYesod where approot _ = ""
|
|
||||||
|
|
||||||
propJoinSplitPath :: [String] -> Bool
|
|
||||||
propJoinSplitPath ss =
|
|
||||||
splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])
|
|
||||||
== Right ss'
|
|
||||||
where
|
|
||||||
ss' = filter (not . null) ss
|
|
||||||
|
|
||||||
caseJoinSplitPathDquote :: Assertion
|
|
||||||
caseJoinSplitPathDquote = do
|
|
||||||
splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."]
|
|
||||||
splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."]
|
|
||||||
joinPath TmpYesod "" ["z."] [] @?= "/z./"
|
|
||||||
x @?= Right ss
|
|
||||||
where
|
|
||||||
x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])
|
|
||||||
ss' = filter (not . null) ss
|
|
||||||
ss = ["a."]
|
|
||||||
|
|
||||||
caseUtf8SplitPath :: Assertion
|
|
||||||
caseUtf8SplitPath = do
|
|
||||||
Right ["שלום"] @=?
|
|
||||||
splitPath TmpYesod (BSU.fromString "/שלום/")
|
|
||||||
Right ["page", "Fooé"] @=?
|
|
||||||
splitPath TmpYesod (BSU.fromString "/page/Fooé/")
|
|
||||||
Right ["\156"] @=?
|
|
||||||
splitPath TmpYesod (BSU.fromString "/\156/")
|
|
||||||
Right ["ð"] @=?
|
|
||||||
splitPath TmpYesod (BSU.fromString "/%C3%B0/")
|
|
||||||
|
|
||||||
caseUtf8JoinPath :: Assertion
|
|
||||||
caseUtf8JoinPath = do
|
|
||||||
"/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | 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 :: Route master -> GHandler sub master a
|
|
||||||
redirectToPost dest = hamletToRepHtml
|
|
||||||
#if GHC7
|
|
||||||
[hamlet|
|
|
||||||
#else
|
|
||||||
[$hamlet|
|
|
||||||
#endif
|
|
||||||
!!!
|
|
||||||
%html
|
|
||||||
%head
|
|
||||||
%title Redirecting...
|
|
||||||
%body!onload="document.getElementById('form').submit()"
|
|
||||||
%form#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
|
|
||||||
|
|
||||||
yesodVersion :: String
|
|
||||||
yesodVersion = showVersion Paths_yesod.version
|
|
||||||
108
blog.hs
108
blog.hs
@ -1,108 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Helpers.Auth
|
|
||||||
import Yesod.Helpers.Crud
|
|
||||||
import Database.Persist.Sqlite
|
|
||||||
import Data.Time (Day)
|
|
||||||
|
|
||||||
share2 mkPersist mkIsForm [$persist|
|
|
||||||
Entry
|
|
||||||
title String "label=Entry title" "tooltip=Make it something cool"
|
|
||||||
posted JqueryDay Desc
|
|
||||||
content NicHtml
|
|
||||||
deriving
|
|
||||||
|]
|
|
||||||
instance Item Entry where
|
|
||||||
itemTitle = entryTitle
|
|
||||||
|
|
||||||
getAuth = const $ Auth
|
|
||||||
{ authIsOpenIdEnabled = False
|
|
||||||
, authRpxnowApiKey = Nothing
|
|
||||||
, authEmailSettings = Nothing
|
|
||||||
-- | client id, secret and requested permissions
|
|
||||||
, authFacebook = Just (clientId, secret, ["email"])
|
|
||||||
}
|
|
||||||
where
|
|
||||||
clientId = "134280699924829"
|
|
||||||
secret = "a7685e10c8977f5435e599aaf1d232eb"
|
|
||||||
|
|
||||||
data Blog = Blog Connection
|
|
||||||
type EntryCrud = Crud Blog Entry
|
|
||||||
mkYesod "Blog" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
/entry/#EntryId EntryR GET
|
|
||||||
/admin AdminR EntryCrud defaultCrud
|
|
||||||
/auth AuthR Auth getAuth
|
|
||||||
|]
|
|
||||||
instance Yesod Blog where
|
|
||||||
approot _ = "http://localhost:3000"
|
|
||||||
defaultLayout p = do
|
|
||||||
mcreds <- maybeCreds
|
|
||||||
admin <- maybeAuthorized $ AdminR CrudListR
|
|
||||||
hamletToContent [$hamlet|
|
|
||||||
!!!
|
|
||||||
%html
|
|
||||||
%head
|
|
||||||
%title $pageTitle.p$
|
|
||||||
^pageHead.p^
|
|
||||||
%style textarea.html{width:500px;height:200px}div.tooltip{font-size:80%;font-style:italic;color:#666}
|
|
||||||
%body
|
|
||||||
%p
|
|
||||||
%a!href=@RootR@ Homepage
|
|
||||||
$maybe admin a
|
|
||||||
\ | $
|
|
||||||
%a!href=@a@ Admin
|
|
||||||
\ | $
|
|
||||||
$maybe mcreds c
|
|
||||||
Welcome $
|
|
||||||
$maybe credsDisplayName.c dn
|
|
||||||
$dn$
|
|
||||||
$nothing
|
|
||||||
$credsIdent.c$
|
|
||||||
\ $
|
|
||||||
%a!href=@AuthR.Logout@ Logout
|
|
||||||
$nothing
|
|
||||||
%a!href=@AuthR.StartFacebookR@ Facebook Connect
|
|
||||||
^pageBody.p^
|
|
||||||
%p
|
|
||||||
Powered by Yesod Web Framework
|
|
||||||
|]
|
|
||||||
isAuthorized AdminR{} = do
|
|
||||||
mc <- maybeCreds
|
|
||||||
let x = (mc >>= credsEmail) == Just "michael@snoyman.com"
|
|
||||||
return $ if x then Nothing else Just "Permission denied"
|
|
||||||
isAuthorized _ = return Nothing
|
|
||||||
instance YesodAuth Blog where
|
|
||||||
defaultDest _ = RootR
|
|
||||||
defaultLoginRoute _ = RootR
|
|
||||||
instance YesodPersist Blog where
|
|
||||||
type YesodDB Blog = SqliteReader
|
|
||||||
runDB db = do
|
|
||||||
Blog conn <- getYesod
|
|
||||||
runSqlite db conn
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
entries <- runDB $ select [] [EntryPostedDesc]
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string "Blog tutorial homepage"
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 All Entries
|
|
||||||
%ul
|
|
||||||
$forall entries entry
|
|
||||||
%li
|
|
||||||
%a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
|
|
||||||
|]
|
|
||||||
|
|
||||||
getEntryR :: EntryId -> Handler Blog RepHtml
|
|
||||||
getEntryR eid = do
|
|
||||||
entry <- runDB (get eid) >>= maybe notFound return
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string $ entryTitle entry
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 $entryTitle.entry$
|
|
||||||
%h2 $show.unJqueryDay.entryPosted.entry$
|
|
||||||
#content $unNicHtml.entryContent.entry$
|
|
||||||
|]
|
|
||||||
main = withSqlite "blog.db3" $ \conn -> do
|
|
||||||
flip runSqlite conn $ initialize (undefined :: Entry)
|
|
||||||
toWaiApp (Blog conn) >>= basicHandler 3000
|
|
||||||
71
blog2.hs
71
blog2.hs
@ -1,71 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
import Yesod
|
|
||||||
import Yesod.Helpers.Crud
|
|
||||||
import Yesod.Form.Jquery
|
|
||||||
import Yesod.Form.Nic
|
|
||||||
import Database.Persist.Sqlite
|
|
||||||
import Database.Persist.TH
|
|
||||||
import Data.Time (Day)
|
|
||||||
|
|
||||||
share2 mkToForm mkPersist [$persist|
|
|
||||||
Entry
|
|
||||||
title String id=thetitle
|
|
||||||
day Day Desc toFormField=YesodJquery.jqueryDayField name=day
|
|
||||||
content Html' toFormField=YesodNic.nicHtmlField
|
|
||||||
deriving
|
|
||||||
|]
|
|
||||||
|
|
||||||
instance Item Entry where
|
|
||||||
itemTitle = entryTitle
|
|
||||||
|
|
||||||
data Blog = Blog { pool :: Pool Connection }
|
|
||||||
|
|
||||||
type EntryCrud = Crud Blog Entry
|
|
||||||
|
|
||||||
mkYesod "Blog" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
/entry/#EntryId EntryR GET
|
|
||||||
/admin AdminR EntryCrud defaultCrud
|
|
||||||
|]
|
|
||||||
|
|
||||||
instance Yesod Blog where
|
|
||||||
approot _ = "http://localhost:3000"
|
|
||||||
instance YesodJquery Blog
|
|
||||||
instance YesodNic Blog
|
|
||||||
|
|
||||||
instance YesodPersist Blog where
|
|
||||||
type YesodDB Blog = SqliteReader
|
|
||||||
runDB db = fmap pool getYesod>>= runSqlite db
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
entries <- runDB $ selectList [] [EntryDayDesc] 0 0
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string "Yesod Blog Tutorial Homepage"
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 Archive
|
|
||||||
%ul
|
|
||||||
$forall entries entry
|
|
||||||
%li
|
|
||||||
%a!href=@EntryR.fst.entry@ $entryTitle.snd.entry$
|
|
||||||
%p
|
|
||||||
%a!href=@AdminR.CrudListR@ Admin
|
|
||||||
|]
|
|
||||||
|
|
||||||
getEntryR entryid = do
|
|
||||||
entry <- runDB $ get404 entryid
|
|
||||||
applyLayoutW $ do
|
|
||||||
setTitle $ string $ entryTitle entry
|
|
||||||
addBody [$hamlet|
|
|
||||||
%h1 $entryTitle.entry$
|
|
||||||
%h2 $show.entryDay.entry$
|
|
||||||
$entryContent.entry$
|
|
||||||
|]
|
|
||||||
|
|
||||||
withBlog f = withSqlite ":memory:" 8 $ \p -> do
|
|
||||||
flip runSqlite p $ do
|
|
||||||
initialize (undefined :: Entry)
|
|
||||||
f $ Blog p
|
|
||||||
|
|
||||||
main = withBlog $ basicHandler 3000
|
|
||||||
40
freeform.hs
40
freeform.hs
@ -1,40 +0,0 @@
|
|||||||
{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
|
|
||||||
import Yesod
|
|
||||||
import Control.Applicative
|
|
||||||
|
|
||||||
data FreeForm = FreeForm
|
|
||||||
mkYesod "FreeForm" [$parseRoutes|
|
|
||||||
/ RootR GET
|
|
||||||
|]
|
|
||||||
instance Yesod FreeForm where approot _ = ""
|
|
||||||
|
|
||||||
data Person = Person String Int String
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
getRootR = do
|
|
||||||
((merr, mperson, form), enctype) <- runFormMonadGet $ do
|
|
||||||
(name, namef) <- stringField "Name" Nothing
|
|
||||||
(age, agef) <- intField "Age" $ Just 25
|
|
||||||
(color, colorf) <- stringField "Color" Nothing
|
|
||||||
let (merr, mperson) =
|
|
||||||
case Person <$> name <*> age <*> color of
|
|
||||||
FormSuccess p -> (Nothing, Just p)
|
|
||||||
FormFailure e -> (Just e, Nothing)
|
|
||||||
FormMissing -> (Nothing, Nothing)
|
|
||||||
let form = [$hamlet|
|
|
||||||
Hey, my name is ^fiInput.namef^ and I'm ^fiInput.agef^ years old and my favorite color is ^fiInput.colorf^.
|
|
||||||
|]
|
|
||||||
return (merr, mperson, form)
|
|
||||||
defaultLayout [$hamlet|
|
|
||||||
$maybe merr err
|
|
||||||
%ul!style=color:red
|
|
||||||
$forall err e
|
|
||||||
%li $e$
|
|
||||||
$maybe mperson person
|
|
||||||
%p Last person: $show.person$
|
|
||||||
%form!method=get!action=@RootR@!enctype=$enctype$
|
|
||||||
%p ^form^
|
|
||||||
%input!type=submit!value=Submit
|
|
||||||
|]
|
|
||||||
|
|
||||||
main = basicHandler 3000 FreeForm
|
|
||||||
@ -1,2 +0,0 @@
|
|||||||
cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/packages/archive//latest/doc/html'
|
|
||||||
scp -r dist/doc/html/yesod snoyberg_yesoddocs@ssh.phx.nearlyfreespeech.net:/home/public/haddock/
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
|
|
||||||
import Yesod
|
|
||||||
data HelloWorld = HelloWorld
|
|
||||||
mkYesod "HelloWorld" [$parseRoutes|/ Home GET|]
|
|
||||||
instance Yesod HelloWorld where approot _ = ""
|
|
||||||
getHome = return $ RepPlain $ toContent "Hello World!"
|
|
||||||
main = basicHandler 3000 HelloWorld
|
|
||||||
14
mail.hs
14
mail.hs
@ -1,14 +0,0 @@
|
|||||||
import Yesod.Mail
|
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L
|
|
||||||
import System.Environment
|
|
||||||
|
|
||||||
main = do
|
|
||||||
[dest] <- getArgs
|
|
||||||
let p1 = Part "text/html" None Inline $ L.pack "<h1>Hello World!!!</h1>"
|
|
||||||
lbs <- L.readFile "mail.hs"
|
|
||||||
let p2 = Part "text/plain" Base64 (Attachment "mail.hs") lbs
|
|
||||||
let mail = Mail
|
|
||||||
[("To", dest), ("Subject", "mail quine")]
|
|
||||||
"Plain stuff. Mime-clients should not show it."
|
|
||||||
[p1, p2]
|
|
||||||
renderSendMail mail
|
|
||||||
18
runtests.hs
18
runtests.hs
@ -1,18 +0,0 @@
|
|||||||
import Test.Framework (defaultMain)
|
|
||||||
|
|
||||||
import qualified Yesod.Content
|
|
||||||
import qualified Yesod.Json
|
|
||||||
import qualified Yesod.Dispatch
|
|
||||||
import qualified Yesod.Helpers.Static
|
|
||||||
import qualified Yesod.Yesod
|
|
||||||
import qualified Yesod.Handler
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = defaultMain
|
|
||||||
[ Yesod.Content.testSuite
|
|
||||||
, Yesod.Json.testSuite
|
|
||||||
, Yesod.Dispatch.testSuite
|
|
||||||
, Yesod.Helpers.Static.testSuite
|
|
||||||
, Yesod.Yesod.testSuite
|
|
||||||
, Yesod.Handler.testSuite
|
|
||||||
]
|
|
||||||
84
yesod.cabal
84
yesod.cabal
@ -20,90 +20,28 @@ flag test
|
|||||||
description: Build the executable to run unit tests
|
description: Build the executable to run unit tests
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
flag ghc7
|
|
||||||
|
|
||||||
library
|
library
|
||||||
if flag(ghc7)
|
build-depends: base >= 4 && < 5
|
||||||
build-depends: base >= 4.3 && < 5
|
, yesod-core >= 0.7 && < 0.8
|
||||||
cpp-options: -DGHC7
|
|
||||||
else
|
|
||||||
build-depends: base >= 4 && < 4.3
|
|
||||||
build-depends: time >= 1.1.4 && < 1.3
|
|
||||||
, wai >= 0.3 && < 0.4
|
|
||||||
, wai-extra >= 0.3 && < 0.4
|
|
||||||
, bytestring >= 0.9.1.4 && < 0.10
|
|
||||||
, directory >= 1 && < 1.2
|
|
||||||
, text >= 0.5 && < 0.12
|
|
||||||
, template-haskell
|
|
||||||
, web-routes-quasi >= 0.6.2 && < 0.7
|
|
||||||
, hamlet >= 0.6 && < 0.7
|
|
||||||
, blaze-builder >= 0.2.1 && < 0.3
|
|
||||||
, transformers >= 0.2 && < 0.3
|
|
||||||
, clientsession >= 0.4.0 && < 0.5
|
|
||||||
, pureMD5 >= 1.1.0.0 && < 2.2
|
|
||||||
, random >= 1.0.0.2 && < 1.1
|
|
||||||
, cereal >= 0.2 && < 0.4
|
|
||||||
, base64-bytestring >= 0.1 && < 0.2
|
|
||||||
, old-locale >= 1.0.0.2 && < 1.1
|
|
||||||
, neither >= 0.2 && < 0.3
|
|
||||||
, network >= 2.2.1.5 && < 2.4
|
|
||||||
, email-validate >= 0.2.5 && < 0.3
|
|
||||||
, web-routes >= 0.23 && < 0.24
|
|
||||||
, xss-sanitize >= 0.2.3 && < 0.3
|
|
||||||
, data-default >= 0.2 && < 0.3
|
|
||||||
, failure >= 0.1 && < 0.2
|
|
||||||
, containers >= 0.2 && < 0.5
|
|
||||||
, monad-peel >= 0.1 && < 0.2
|
, monad-peel >= 0.1 && < 0.2
|
||||||
, enumerator >= 0.4 && < 0.5
|
, transformers >= 0.2 && < 0.3
|
||||||
, cookie >= 0.0 && < 0.1
|
, wai >= 0.3 && < 0.4
|
||||||
, json-enumerator >= 0.0 && < 0.1
|
, hamlet >= 0.7 && < 0.8
|
||||||
, json-types >= 0.1 && < 0.2
|
|
||||||
exposed-modules: Yesod
|
exposed-modules: Yesod
|
||||||
Yesod.Content
|
|
||||||
Yesod.Dispatch
|
|
||||||
Yesod.Hamlet
|
|
||||||
Yesod.Handler
|
|
||||||
Yesod.Request
|
|
||||||
Yesod.Widget
|
|
||||||
Yesod.Yesod
|
|
||||||
Yesod.Helpers.AtomFeed
|
|
||||||
Yesod.Helpers.Sitemap
|
|
||||||
Yesod.Helpers.Static
|
|
||||||
other-modules: Yesod.Internal
|
|
||||||
Paths_yesod
|
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
|
|
||||||
executable yesod
|
executable yesod
|
||||||
if flag(ghc7)
|
build-depends: parsec >= 2.1 && < 4
|
||||||
build-depends: base >= 4.3 && < 5
|
, text >= 0.11 && < 0.12
|
||||||
cpp-options: -DGHC7
|
, bytestring >= 0.9 && < 0.10
|
||||||
else
|
, time >= 1.1.4 && < 1.3
|
||||||
build-depends: base >= 4 && < 4.3
|
, template-haskell
|
||||||
build-depends: parsec >= 2.1 && < 4
|
, directory >= 1.0 && < 1.2
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
main-is: scaffold.hs
|
main-is: scaffold.hs
|
||||||
other-modules: CodeGen
|
other-modules: CodeGen
|
||||||
extensions: TemplateHaskell
|
extensions: TemplateHaskell
|
||||||
|
|
||||||
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,
|
|
||||||
QuickCheck >= 2 && < 3
|
|
||||||
else
|
|
||||||
Buildable: False
|
|
||||||
ghc-options: -Wall
|
|
||||||
main-is: runtests.hs
|
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
location: git://github.com/snoyberg/yesod.git
|
location: git://github.com/snoyberg/yesod.git
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user