yesod 0.0.0.2 → 0.2.0
raw patch · 36 files changed
+2066/−2924 lines, 36 filesdep +MonadCatchIO-transformersdep +cerealdep +clientsessiondep −HStringTemplatedep −attemptdep −data-objectdep ~authenticatedep ~control-monad-attemptdep ~convertible-text
Dependencies added: MonadCatchIO-transformers, cereal, clientsession, hamlet, pureMD5, random, web-routes, web-routes-quasi
Dependencies removed: HStringTemplate, attempt, data-object, data-object-json, data-object-yaml, failure, file-embed, predicates, safe-failure, split, syb, web-encodings
Dependency ranges changed: authenticate, control-monad-attempt, convertible-text, old-locale, template-haskell, transformers, wai, wai-extra
Files
- CLI/skel/App.hs +0/−70
- CLI/skel/LICENSE +0/−25
- CLI/skel/settings.yaml +0/−5
- CLI/skel/static/style.css +0/−10
- CLI/skel/templates/homepage.st +0/−7
- CLI/skel/templates/layout.st +0/−11
- CLI/skel/webapp.cabal +0/−21
- CLI/yesod.hs +0/−76
- Data/Object/Html.hs +0/−252
- Web/Mime.hs +0/−110
- Yesod.hs +25/−34
- Yesod/Content.hs +255/−0
- Yesod/Definitions.hs +0/−68
- Yesod/Dispatch.hs +371/−0
- Yesod/Form.hs +16/−12
- Yesod/Hamlet.hs +58/−0
- Yesod/Handler.hs +324/−72
- Yesod/Helpers/AtomFeed.hs +42/−43
- Yesod/Helpers/Auth.hs +410/−185
- Yesod/Helpers/Sitemap.hs +36/−47
- Yesod/Helpers/Static.hs +99/−26
- Yesod/Internal.hs +30/−0
- Yesod/Json.hs +145/−0
- Yesod/Request.hs +91/−81
- Yesod/Resource.hs +0/−531
- Yesod/Response.hs +0/−251
- Yesod/Template.hs +0/−113
- Yesod/Yesod.hs +114/−121
- examples/fact.lhs +0/−104
- examples/hellotemplate.lhs +0/−33
- examples/helloworld.lhs +0/−19
- examples/i18n.hs +0/−33
- examples/pretty-yaml.hs +0/−38
- examples/tweedle.lhs +0/−407
- runtests.hs +8/−14
- yesod.cabal +42/−105
− CLI/skel/App.hs
@@ -1,70 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-import Yesod-import Yesod.Helpers.Static-import qualified Data.Object.Yaml-import qualified Safe.Failure--data $Datatype$ = $Datatype$- { settings :: Settings- , templateGroup :: TemplateGroup- }--data Settings = Settings- { sApproot :: String- , staticRoot :: String- , staticDir :: String- , templateDir :: String- , portNumber :: Int- }--settingsFile :: FilePath-settingsFile = "settings.yaml"--loadSettings :: IO Settings-loadSettings = do- m <- Data.Object.Yaml.decodeFile settingsFile >>= fromMapping- ar <- lookupScalar "approot" m- sr <- lookupScalar "static-root" m- sd <- lookupScalar "static-dir" m- td <- lookupScalar "template-dir" m- pn <- lookupScalar "port" m >>= Safe.Failure.read- return \$ Settings ar sr sd td pn--load$Datatype$ :: IO $Datatype$-load$Datatype$ = do- s <- loadSettings- tg <- loadTemplateGroup \$ templateDir s- return \$ $Datatype$ s tg--main :: IO ()-main = do- datatype <- load$Datatype$- app <- toWaiApp datatype- basicHandler (portNumber \$ settings datatype) app--instance Yesod $Datatype$ where- resources = [\$mkResources|-/:- GET: homepageH-/static/*: serveStatic'-|]- applyLayout = defaultApplyLayout--instance YesodApproot $Datatype$ where- approot = sApproot . settings--instance YesodTemplate $Datatype$ where- getTemplateGroup = templateGroup- defaultTemplateAttribs y _ = return- . setHtmlAttrib "approot" (approot y)- . setHtmlAttrib "staticroot" (staticRoot \$ settings y)--homepageH :: Handler $Datatype$ RepHtml-homepageH = templateHtml "homepage" return--serveStatic' :: Method -> [String]- -> Handler $Datatype$ [(ContentType, Content)]-serveStatic' method pieces = do- y <- getYesod- let sd = staticDir \$ settings y- serveStatic (fileLookupDir sd) method pieces
− CLI/skel/LICENSE
@@ -1,25 +0,0 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright $year$, $author$. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− CLI/skel/settings.yaml
@@ -1,5 +0,0 @@-approot: http://localhost:3000/-static-root: http://localhost:3000/static/-static-dir: static-template-dir: templates-port: 3000
− CLI/skel/static/style.css
@@ -1,10 +0,0 @@-html {- background: #ccc;-}-body {- width: 760px;- margin: 10px auto;- padding: 10px;- border: 1px solid #333;- background: #fff;-}
− CLI/skel/templates/homepage.st
@@ -1,7 +0,0 @@-\$layout(- title={Homepage};- content={- <h1>Homepage</h1>- <p>You probably want to put your own content here.</p>- }-)\$
− CLI/skel/templates/layout.st
@@ -1,11 +0,0 @@-<!DOCTYPE html>-<html>- <head>- <title>\$title\$</title>- <link rel="stylesheet" href="\$staticroot\$style.css">- \$extrahead\$- </head>- <body>- \$content\$- </body>-</html>
− CLI/skel/webapp.cabal
@@ -1,21 +0,0 @@-name: $project$-version: 0.0.0-license: BSD3-license-file: LICENSE-author: $author$ $email$-maintainer: $author$ $email$-synopsis: A web application based on Yesod.-description: The default web application. You might want to change this.-category: Web-stability: Stable-cabal-version: >= 1.2-build-type: Simple-homepage: $homepage$--executable $project$- build-depends: base >= 4 && < 5,- yesod >= 0.0.0 && < 0.1,- safe-failure >= 0.4.0 && < 0.5,- data-object-yaml >= 0.2.0.1 && < 0.3- main-is: $Datatype$.hs- ghc-options: -Wall
− CLI/yesod.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-import Data.FileEmbed-import Text.StringTemplate-import Data.ByteString.Char8 (ByteString, unpack)-import System.Directory-import System.Environment-import System.IO-import Data.Char--skel :: [(FilePath, ByteString)]-skel = $(embedDir "CLI/skel")--yesodInit :: FilePath -> [(String, String)] -> IO ()-yesodInit topDir a = do- mapM_ (\x -> createDirectoryIfMissing True $ topDir ++ x)- ["static", "templates"]- mapM_ go skel- where- go (fp, bs) = do- let temp = newSTMP $ unpack bs- writeFile (topDir ++ fp) $ toString $ setManyAttrib a temp--main :: IO ()-main = do- args <- getArgs- case args of- ["init"] -> yesodInit'- _ -> usage--usage :: IO ()-usage = putStrLn "Currently, the only support operation is \"init\"."--prompt :: String -> (String -> Bool) -> IO String-prompt s t = do- putStr s- hFlush stdout- x <- getLine- if t x- then return x- else do- putStrLn "That was not valid input."- prompt s t--yesodInit' :: IO ()-yesodInit' = do- putStrLn "Let's get started created a Yesod web application."- dest <-- prompt- "In which directory would you like to put the application? "- (not . null)- dt <-- prompt- "Give a data type name (first letter capital): "- (\x -> not (null x) && isUpper (head x))- pr <- prompt- "Name of project (cabal file): "- (not . null)- au <- prompt- "Author (cabal file): "- (not . null)- em <- prompt- "Author email (cabal file): "- (not . null)- ho <- prompt- "Homepage (cabal file): "- (not . null)- yesodInit (dest ++ "/")- [ ("Datatype", dt)- , ("project", pr)- , ("author", au)- , ("email", em)- , ("homepage", ho)- ]- renameFile (dest ++ "/webapp.cabal") (dest ++ "/" ++ pr ++ ".cabal")- renameFile (dest ++ "/App.hs") (dest ++ "/" ++ dt ++ ".hs")- putStrLn "Your project has been initialized."
− Data/Object/Html.hs
@@ -1,252 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}--- | An 'Html' data type and associated 'ConvertSuccess' instances. This has--- useful conversions in web development:------ * Automatic generation of simple HTML documents from 'HtmlObject' (mostly--- useful for testing, you would never want to actually show them to an end--- user).------ * Converts to JSON, which gives fully HTML escaped JSON. Very nice for Ajax.------ * Can be used with HStringTemplate.-module Data.Object.Html- ( -- * Data type- Html (..)- , HtmlDoc (..)- , HtmlFragment (..)- , HtmlObject- -- * XML helpers- , XmlDoc (..)- , cdata- -- * Standard 'Object' functions- , toHtmlObject- , fromHtmlObject- -- * Re-export- , module Data.Object-#if TEST- , testSuite-#endif- ) where--import Data.Generics-import Data.Object.Text-import Data.Object.String-import Data.Object.Json-import qualified Data.Text.Lazy as TL-import qualified Data.Text as TS-import Web.Encodings-import Text.StringTemplate.Classes-import Control.Arrow (second)-import Data.Attempt-import Data.Object--#if TEST-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)-import Text.StringTemplate-#endif---- | A single piece of HTML code.-data Html =- Html TS.Text -- ^ Already encoded HTML.- | Text TS.Text -- ^ Text which should be HTML escaped.- | Tag String [(String, String)] Html -- ^ Tag which needs a closing tag.- | EmptyTag String [(String, String)] -- ^ Tag without a closing tag.- | HtmlList [Html]- deriving (Eq, Show, Typeable)---- | A full HTML document.-newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }--type HtmlObject = Object String Html--instance ConvertSuccess Html HtmlObject where- convertSuccess = Scalar-instance ConvertSuccess [Html] HtmlObject where- convertSuccess = Sequence . map cs-instance ConvertSuccess [HtmlObject] HtmlObject where- convertSuccess = Sequence-instance ConvertSuccess [(String, HtmlObject)] HtmlObject where- convertSuccess = Mapping-instance ConvertSuccess [(String, Html)] HtmlObject where- convertSuccess = Mapping . map (second cs)-instance ConvertSuccess StringObject HtmlObject where- convertSuccess = mapKeysValues cs cs--toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject-toHtmlObject = cs--fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x-fromHtmlObject = ca--instance ConvertSuccess String Html where- convertSuccess = Text . cs-instance ConvertSuccess TS.Text Html where- convertSuccess = Text-instance ConvertSuccess Text Html where- convertSuccess = Text . cs--instance ConvertSuccess String HtmlObject where- convertSuccess = Scalar . cs-instance ConvertSuccess Text HtmlObject where- convertSuccess = Scalar . cs-instance ConvertSuccess TS.Text HtmlObject where- convertSuccess = Scalar . cs-instance ConvertSuccess [String] HtmlObject where- convertSuccess = Sequence . map cs-instance ConvertSuccess [Text] HtmlObject where- convertSuccess = Sequence . map cs-instance ConvertSuccess [TS.Text] HtmlObject where- convertSuccess = Sequence . map cs-instance ConvertSuccess [(String, String)] HtmlObject where- convertSuccess = omTO-instance ConvertSuccess [(Text, Text)] HtmlObject where- convertSuccess = omTO-instance ConvertSuccess [(TS.Text, TS.Text)] HtmlObject where- convertSuccess = omTO--showAttribs :: [(String, String)] -> String -> String-showAttribs pairs rest = foldr (($) . helper) rest pairs where- helper :: (String, String) -> String -> String- helper (k, v) rest' =- ' ' : encodeHtml k- ++ '=' : '"' : encodeHtml v- ++ '"' : rest'--htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML- -> Html- -> ([TS.Text] -> [TS.Text])-htmlToText _ (Html t) = (:) t-htmlToText _ (Text t) = (:) $ encodeHtml t-htmlToText xml (Tag n as content) = \rest ->- cs ('<' : n)- : cs (showAttribs as ">")- : htmlToText xml content- ( cs ('<' : '/' : n)- : cs ">"- : rest)-htmlToText xml (EmptyTag n as) = \rest ->- cs ('<' : n )- : cs (showAttribs as (if xml then "/>" else ">"))- : rest-htmlToText xml (HtmlList l) = flip (foldr ($)) (map (htmlToText xml) l)--newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text }-instance ConvertSuccess Html HtmlFragment where- convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ []-instance ConvertSuccess HtmlFragment Html where- convertSuccess = HtmlList . map Html . TL.toChunks . unHtmlFragment--- | Not fully typesafe. You must make sure that when converting to this, the--- 'Html' starts with a tag.-newtype XmlDoc = XmlDoc { unXmlDoc :: Text }-instance ConvertSuccess Html XmlDoc where- convertSuccess h = XmlDoc $ TL.fromChunks $- cs "<?xml version='1.0' encoding='utf-8' ?>\n"- : htmlToText True h []---- | Wrap an 'Html' in CDATA for XML output.-cdata :: Html -> Html-cdata h = HtmlList- [ Html $ cs "<![CDATA["- , h- , Html $ cs "]]>"- ]--instance ConvertSuccess (Html, Html) HtmlDoc where- convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $- cs "<!DOCTYPE html>\n"- : htmlToText False (Tag "html" [] $ HtmlList- [ Tag "head" [] h- , Tag "body" [] b- ]- ) []-instance ConvertSuccess (Html, HtmlObject) HtmlDoc where- convertSuccess (x, y) = cs (x, cs y :: Html)-instance ConvertSuccess (Html, HtmlObject) JsonDoc where- convertSuccess (_, y) = cs y--instance ConvertSuccess HtmlObject Html where- convertSuccess (Scalar h) = h- convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs- where- addLi = Tag "li" [] . cs- convertSuccess (Mapping pairs) =- Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where- addDtDd (k, v) =- [ Tag "dt" [] $ Text $ cs k- , Tag "dd" [] $ cs v- ]--instance ConvertSuccess Html JsonScalar where- convertSuccess = cs . unHtmlFragment . cs-instance ConvertAttempt Html JsonScalar where- convertAttempt = return . cs--instance ConvertSuccess HtmlObject JsonObject where- convertSuccess = mapKeysValues convertSuccess convertSuccess-instance ConvertAttempt HtmlObject JsonObject where- convertAttempt = return . cs--instance ConvertSuccess HtmlObject JsonDoc where- convertSuccess = cs . (cs :: HtmlObject -> JsonObject)-instance ConvertAttempt HtmlObject JsonDoc where- convertAttempt = return . cs--instance ToSElem HtmlObject where- toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h- toSElem (Sequence hs) = LI $ map toSElem hs- toSElem (Mapping pairs) = helper $ map (second toSElem) pairs where- helper :: [(String, SElem b)] -> SElem b- helper = SM . cs--#if TEST-caseHtmlToText :: Assertion-caseHtmlToText = do- let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList- [ Html $ cs "<br>Some HTML<br>"- , Text $ cs "<'this should be escaped'>"- , EmptyTag "img" [("src", "baz&")]- ]- let expected =- "<div id=\"foo\" class=\"bar\"><br>Some HTML<br>" ++- "<'this should be escaped'>" ++- "<img src=\"baz&\"></div>"- unHtmlFragment (cs actual) @?= (cs expected :: Text)--caseStringTemplate :: Assertion-caseStringTemplate = do- let content = Mapping- [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"- , Scalar $ Text $ cs "<hr>"])- , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])- ]- let temp = newSTMP "foo:$o.foo$,bar:$o.bar$"- let expected = "foo:<br><hr>,bar:<img src=\"file.jpg\">"- expected @=? toString (setAttribute "o" content temp)--caseJson :: Assertion-caseJson = do- let content = Mapping- [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"- , Scalar $ Text $ cs "<hr>"])- , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])- ]- let expected = "{\"bar\":\"<img src=\\\"file.jpg\\\">\"" ++- ",\"foo\":[\"<br>\",\"<hr>\"]" ++- "}"- JsonDoc (cs expected) @=? cs content--testSuite :: Test-testSuite = testGroup "Data.Object.Html"- [ testCase "caseHtmlToText" caseHtmlToText- , testCase "caseStringTemplate" caseStringTemplate- , testCase "caseJson" caseJson- ]--#endif
− Web/Mime.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}--- | Generic MIME type module. Could be spun off into its own package.-module Web.Mime- ( ContentType (..)- , contentTypeFromBS- , typeByExt- , ext- , simpleContentType-#if TEST- , testSuite-#endif- ) where--import Data.Function (on)-import Data.Convertible.Text-import Data.ByteString.Char8 (pack, ByteString, unpack)--#if TEST-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit hiding (Test)-import Test.QuickCheck-import Control.Monad (when)-#endif--data ContentType =- TypeHtml- | TypePlain- | TypeJson- | TypeXml- | TypeAtom- | TypeJpeg- | TypePng- | TypeGif- | TypeJavascript- | TypeCss- | TypeFlv- | TypeOgv- | TypeOctet- | TypeOther String- deriving (Show)--instance ConvertSuccess ContentType ByteString where- convertSuccess = pack . cs--instance ConvertSuccess ContentType [Char] where- convertSuccess TypeHtml = "text/html; charset=utf-8"- convertSuccess TypePlain = "text/plain; charset=utf-8"- convertSuccess TypeJson = "application/json; charset=utf-8"- convertSuccess TypeXml = "text/xml"- convertSuccess TypeAtom = "application/atom+xml"- convertSuccess TypeJpeg = "image/jpeg"- convertSuccess TypePng = "image/png"- convertSuccess TypeGif = "image/gif"- convertSuccess TypeJavascript = "text/javascript; charset=utf-8"- convertSuccess TypeCss = "text/css; charset=utf-8"- convertSuccess TypeFlv = "video/x-flv"- convertSuccess TypeOgv = "video/ogg"- convertSuccess TypeOctet = "application/octet-stream"- convertSuccess (TypeOther s) = s--simpleContentType :: ContentType -> String-simpleContentType = fst . span (/= ';') . cs--instance Eq ContentType where- (==) = (==) `on` (cs :: ContentType -> String)--contentTypeFromBS :: ByteString -> ContentType-contentTypeFromBS = TypeOther . unpack---- | Determine a mime-type based on the file extension.-typeByExt :: String -> ContentType-typeByExt "jpg" = TypeJpeg-typeByExt "jpeg" = TypeJpeg-typeByExt "js" = TypeJavascript-typeByExt "css" = TypeCss-typeByExt "html" = TypeHtml-typeByExt "png" = TypePng-typeByExt "gif" = TypeGif-typeByExt "txt" = TypePlain-typeByExt "flv" = TypeFlv-typeByExt "ogv" = TypeOgv-typeByExt _ = TypeOctet---- | 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- TypeJavascript @=? typeByExt (ext "foo.js")- TypeHtml @=? typeByExt (ext "foo.html")--#endif
Yesod.hs view
@@ -1,50 +1,41 @@ {-# LANGUAGE CPP #-}---------------------------------------------------------------- Module : Yesod--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ Lightweight framework for designing RESTful APIs.-------------------------------------------------------------+{-# LANGUAGE PackageImports #-} module Yesod ( module Yesod.Request- , module Yesod.Response+ , module Yesod.Content , module Yesod.Yesod- , module Yesod.Definitions , module Yesod.Handler- , module Yesod.Resource+ , module Yesod.Dispatch , module Yesod.Form- , module Data.Object.Html- , module Yesod.Template- , module Web.Mime+ , module Yesod.Hamlet+ , module Yesod.Json , Application- , Method (..)+ , cs+ , liftIO+ , Routes ) where #if TEST-import Yesod.Resource hiding (testSuite)-import Yesod.Response hiding (testSuite)-import Data.Object.Html hiding (testSuite)-import Yesod.Request hiding (testSuite)-import Web.Mime hiding (testSuite)+import Yesod.Content hiding (testSuite)+import Yesod.Json hiding (testSuite)+import Yesod.Dispatch hiding (testSuite) #else-import Yesod.Resource-import Yesod.Response-import Data.Object.Html-import Yesod.Request-import Web.Mime+import Yesod.Content+import Yesod.Json+import Yesod.Dispatch #endif +import Yesod.Request import Yesod.Form import Yesod.Yesod-import Yesod.Definitions-import Yesod.Handler-import Network.Wai (Application, Method (..))-import Yesod.Template+import Yesod.Handler hiding (runHandler)+import Network.Wai (Application)+import Yesod.Hamlet+import Data.Convertible.Text (cs)+#if MIN_VERSION_transformers(0,2,0)+import "transformers" Control.Monad.IO.Class (liftIO)+#else+import "transformers" Control.Monad.Trans (liftIO)+#endif+import Web.Routes.Quasi (Routes)
+ Yesod/Content.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-}++module Yesod.Content+ ( -- * Content+ Content (..)+ , toContent+ -- * Mime types+ -- ** Data type+ , ContentType (..)+ , contentTypeFromString+ , contentTypeToString+ -- ** File extensions+ , typeByExt+ , ext+ -- * Utilities+ , simpleContentType+ -- * Representations+ , ChooseRep+ , HasReps (..)+ , defChooseRep+ -- ** Specific content types+ , RepHtml (..)+ , RepJson (..)+ , RepHtmlJson (..)+ , RepPlain (..)+ , RepXml (..)+ -- * Utilities+ , formatW3+#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.Convertible.Text++import qualified Network.Wai as W+import qualified Network.Wai.Enumerator as WE++import Data.Function (on)+import Data.Time+import System.Locale++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit hiding (Test)+#endif++-- | There are two different methods available for providing content in the+-- response: via files and enumerators. The former allows server to use+-- optimizations (usually the sendfile system call) for serving static files.+-- The latter is a space-efficient approach to content.+--+-- It can be tedious to write enumerators; often times, you will be well served+-- to use 'toContent'.+data Content = ContentFile FilePath+ | ContentEnum (forall a.+ (a -> B.ByteString -> IO (Either a a))+ -> a+ -> IO (Either a a))++instance ConvertSuccess B.ByteString Content where+ convertSuccess bs = ContentEnum $ \f a -> f a bs+instance ConvertSuccess L.ByteString Content where+ convertSuccess = swapEnum . WE.fromLBS+instance ConvertSuccess T.Text Content where+ convertSuccess t = cs (cs t :: B.ByteString)+instance ConvertSuccess Text Content where+ convertSuccess lt = cs (cs lt :: L.ByteString)+instance ConvertSuccess String Content where+ convertSuccess s = cs (cs s :: Text)+instance ConvertSuccess (IO Text) Content where+ convertSuccess = swapEnum . WE.fromLBS' . fmap cs++-- | A synonym for 'convertSuccess' to make the desired output type explicit.+toContent :: ConvertSuccess x Content => x -> Content+toContent = cs++-- | 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)++swapEnum :: W.Enumerator -> Content+swapEnum (W.Enumerator e) = ContentEnum e++-- | 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 $ cs "")]++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 . contentTypeToString++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)++-- | Equality is determined by converting to a 'String' via+-- 'contentTypeToString'. This ensures that, for example, 'TypeJpeg' is the+-- same as 'TypeOther' \"image/jpeg\". However, note that 'TypeHtml' is *not*+-- the same as 'TypeOther' \"text/html\", since 'TypeHtml' is defined as UTF-8+-- encoded. See 'contentTypeToString'.+data ContentType =+ TypeHtml+ | TypePlain+ | TypeJson+ | TypeXml+ | TypeAtom+ | TypeJpeg+ | TypePng+ | TypeGif+ | TypeJavascript+ | TypeCss+ | TypeFlv+ | TypeOgv+ | TypeOctet+ | TypeOther String+ deriving (Show)++-- | This is simply a synonym for 'TypeOther'. However, equality works as+-- expected; see 'ContentType'.+contentTypeFromString :: String -> ContentType+contentTypeFromString = TypeOther++-- | This works as expected, with one caveat: the builtin textual content types+-- ('TypeHtml', 'TypePlain', etc) all include \"; charset=utf-8\" at the end of+-- their basic content-type. If another encoding is desired, please use+-- 'TypeOther'.+contentTypeToString :: ContentType -> String+contentTypeToString TypeHtml = "text/html; charset=utf-8"+contentTypeToString TypePlain = "text/plain; charset=utf-8"+contentTypeToString TypeJson = "application/json; charset=utf-8"+contentTypeToString TypeXml = "text/xml"+contentTypeToString TypeAtom = "application/atom+xml"+contentTypeToString TypeJpeg = "image/jpeg"+contentTypeToString TypePng = "image/png"+contentTypeToString TypeGif = "image/gif"+contentTypeToString TypeJavascript = "text/javascript; charset=utf-8"+contentTypeToString TypeCss = "text/css; charset=utf-8"+contentTypeToString TypeFlv = "video/x-flv"+contentTypeToString TypeOgv = "video/ogg"+contentTypeToString TypeOctet = "application/octet-stream"+contentTypeToString (TypeOther s) = s++-- | 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 (/= ';')++instance Eq ContentType where+ (==) = (==) `on` contentTypeToString++-- | Determine a mime-type based on the file extension.+typeByExt :: String -> ContentType+typeByExt "jpg" = TypeJpeg+typeByExt "jpeg" = TypeJpeg+typeByExt "js" = TypeJavascript+typeByExt "css" = TypeCss+typeByExt "html" = TypeHtml+typeByExt "png" = TypePng+typeByExt "gif" = TypeGif+typeByExt "txt" = TypePlain+typeByExt "flv" = TypeFlv+typeByExt "ogv" = TypeOgv+typeByExt _ = TypeOctet++-- | 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+ TypeJavascript @=? typeByExt (ext "foo.js")+ TypeHtml @=? typeByExt (ext "foo.html")+#endif++-- | Format a 'UTCTime' in W3 format; useful for setting cookies.+formatW3 :: UTCTime -> String+formatW3 = formatTime defaultTimeLocale "%FT%X-00:00"
− Yesod/Definitions.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}---------------------------------------------------------------- Module : Yesod.Definitions--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ Definitions throughout Restful.--------------------------------------------------------------module Yesod.Definitions- ( Resource- , Approot- , Language- , Location (..)- , showLocation- -- * Constant values- , authCookieName- , authDisplayName- , encryptedCookies- , langKey- , destCookieName- , destCookieTimeout- ) where--import Data.ByteString.Char8 (pack, ByteString)--type Resource = [String]---- | An absolute URL to the base of this application. This can almost be done--- programatically, but due to ambiguities in different ways of doing URL--- rewriting for (fast)cgi applications, it should be supplied by the user.-type Approot = String--type Language = String---- | A location string. Can either be given absolutely or as a suffix for the--- 'Approot'.-data Location = AbsLoc String | RelLoc String---- | Display a 'Location' in absolute form.-showLocation :: Approot -> Location -> String-showLocation _ (AbsLoc s) = s-showLocation ar (RelLoc s) = ar ++ s--authCookieName :: String-authCookieName = "IDENTIFIER"--authDisplayName :: String-authDisplayName = "DISPLAY_NAME"--encryptedCookies :: [ByteString]-encryptedCookies = [pack authDisplayName, pack authCookieName]--langKey :: String-langKey = "_LANG"--destCookieName :: String-destCookieName = "DEST"--destCookieTimeout :: Int-destCookieTimeout = 120
+ Yesod/Dispatch.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module Yesod.Dispatch+ ( -- * Quasi-quoted routing+ parseRoutes+ , mkYesod+ , mkYesodSub+ -- ** More fine-grained+ , mkYesodData+ , mkYesodDispatch+ -- ** Path pieces+ , SinglePiece (..)+ , MultiPiece (..)+ , Strings+ -- * Convert to WAI+ , toWaiApp+ , basicHandler+ -- * Utilities+ , fullRender+ , quasiRender+#if TEST+ , testSuite+#endif+ ) where++import Yesod.Handler+import Yesod.Yesod+import Yesod.Request+import Yesod.Internal++import Web.Routes.Quasi+import Language.Haskell.TH.Syntax++import qualified Network.Wai as W+import qualified Network.Wai.Enumerator as W+import Network.Wai.Middleware.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 Web.Routes (encodePathInfo)++import Control.Concurrent.MVar+import Control.Arrow ((***))+import Data.Convertible.Text (cs)++import Data.Time++import Control.Monad+import Data.Maybe+import Web.ClientSession++import Data.Serialize+import Network.Wai.Parse++#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 (\(x, y) -> x ++ y) . 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+ -> [Name] -- ^ a list of classes the master datatype must be an instance of+ -> [Resource]+ -> Q [Dec]+mkYesodSub name clazzes =+ fmap (\(x, y) -> x ++ y) . mkYesodGeneral name clazzes True++-- | 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. This function, paired with+-- 'mkYesodDispatch', do just that.+mkYesodData :: String -> [Resource] -> Q [Dec]+mkYesodData name res = do+ (x, _) <- mkYesodGeneral name [] False res+ let rname = mkName $ "resources" ++ name+ eres <- liftResources 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++explodeHandler :: HasReps c+ => GHandler sub master c+ -> (Routes master -> String)+ -> Routes sub+ -> (Routes sub -> Routes master)+ -> master+ -> (master -> sub)+ -> YesodApp+ -> String+ -> YesodApp+explodeHandler a b c d e f _ _ = runHandler a b (Just c) d e f++mkYesodGeneral :: String -> [Name] -> Bool -> [Resource] -> Q ([Dec], [Dec])+mkYesodGeneral name clazzes isSub res = do+ let name' = mkName name+ let site = mkName $ "site" ++ name+ let gsbod = NormalB $ VarE site+ let yes' = FunD (mkName "getSite") [Clause [] gsbod []]+ let yes = InstanceD [] (ConT ''YesodSite `AppT` ConT name') [yes']+ explode <- [|explodeHandler|]+ QuasiSiteDecs w x y z <- createQuasiSite QuasiSiteSettings+ { crRoutes = mkName $ name ++ "Routes"+ , crApplication = ConT ''YesodApp+ , crArgument = ConT $ mkName name+ , crExplode = explode+ , crResources = res+ , crSite = site+ , crMaster = if isSub then Right clazzes else Left (ConT name')+ }+ return ([w, x], (if isSub then id else (:) yes) [y, z])++sessionName :: String+sessionName = "_SESSION"++-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. You can use 'basicHandler' if you wish.+toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application+toWaiApp a =+ return $ gzip+ $ jsonp+ $ cleanPath+ $ toWaiApp' a++toWaiApp' :: (Yesod y, YesodSite y)+ => y+ -> [String]+ -> W.Request+ -> IO W.Response+toWaiApp' y segments env = do+ key' <- encryptKey y+ now <- getCurrentTime+ let getExpires m = fromIntegral (m * 60) `addUTCTime` now+ let exp' = getExpires $ clientSessionDuration y+ let host = W.remoteHost env+ let session' = fromMaybe [] $ do+ raw <- lookup W.Cookie $ W.requestHeaders env+ val <- lookup (B.pack sessionName) $ parseCookies raw+ decodeSession key' now host val+ let site = getSite+ method = B.unpack $ W.methodToBS $ W.requestMethod env+ types = httpAccept env+ pathSegments = filter (not . null) segments+ eurl = quasiParse site pathSegments+ render u = fromMaybe+ (fullRender (approot y) (quasiRender site) u)+ (urlRenderOverride y u)+ rr <- parseWaiRequest env session'+ onRequest y rr+ let ya = case eurl of+ Left _ -> runHandler (errorHandler y NotFound)+ render+ Nothing+ id+ y+ id+ Right url -> quasiDispatch site+ render+ url+ id+ y+ id+ (badMethodApp method)+ method+ let eurl' = either (const Nothing) Just eurl+ let eh er = runHandler (errorHandler y er) render eurl' id y id+ (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types+ let sessionVal = encodeSession key' exp' host sessionFinal+ let hs' = AddCookie (clientSessionDuration y) sessionName+ (cs sessionVal)+ : hs+ hs'' = map (headerToPair getExpires) hs'+ hs''' = (W.ContentType, cs $ contentTypeToString ct) : hs''+ return $ W.Response s hs''' $ case c of+ ContentFile fp -> Left fp+ ContentEnum e -> Right $ W.buffer+ $ W.Enumerator e++-- | Fully render a route to an absolute URL. Since Yesod does this for you+-- internally, you will rarely need access to this. However, if you need to+-- generate links *outside* of the Handler monad, this may be useful.+--+-- For example, if you want to generate an e-mail which links to your site,+-- this is the function you would want to use.+fullRender :: String -- ^ approot, no trailing slash+ -> (url -> [String])+ -> url+ -> String+fullRender ar render route =+ ar ++ '/' : encodePathInfo (fixSegs $ render route)++httpAccept :: W.Request -> [ContentType]+httpAccept = map (contentTypeFromString . B.unpack)+ . parseHttpAccept+ . fromMaybe B.empty+ . lookup W.Accept+ . W.requestHeaders++-- | Runs an application with CGI if CGI variables are present (namely+-- PATH_INFO); otherwise uses SimpleServer.+basicHandler :: Int -- ^ port number+ -> W.Application -> IO ()+basicHandler port app = do+ vars <- getEnvironment+ case lookup "PATH_INFO" vars of+ Nothing -> do+ putStrLn $ "http://localhost:" ++ show port ++ "/"+ SS.run port app+ Just _ -> CGI.run app++badMethodApp :: String -> YesodApp+badMethodApp m = YesodApp $ \eh req cts+ -> unYesodApp (eh $ BadMethod m) eh req cts++fixSegs :: [String] -> [String]+fixSegs [] = []+fixSegs [x]+ | any (== '.') x = [x]+ | otherwise = [x, ""] -- append trailing slash+fixSegs (x:xs) = x : fixSegs xs++parseWaiRequest :: W.Request+ -> [(String, String)] -- ^ session+ -> IO Request+parseWaiRequest env session' = do+ let gets' = map (cs *** cs) $ parseQueryString $ W.queryString env+ let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env+ cookies' = map (cs *** cs) $ parseCookies reqCookie+ acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env+ langs = map cs $ maybe [] parseHttpAccept acceptLang+ 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+ return $ Request gets' cookies' session' rbthunk env langs''++rbHelper :: W.Request -> IO RequestBodyContents+rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where+ fix1 = map (cs *** cs)+ fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs 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) =+ let expires = getExpires minutes+ in (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="+ ++ formatW3 expires)+headerToPair _ (DeleteCookie key) =+ (W.SetCookie, cs $+ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")+headerToPair _ (Header key value) = (W.responseHeaderFromBS $ cs key, cs value)++encodeSession :: 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 :: 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 <- get+ c <- get+ return $ SessionCookie a b c++putTime :: Putter UTCTime+putTime t@(UTCTime d _) = do+ put $ toModifiedJulianDay d+ let ndt = diffUTCTime t $ UTCTime d 0+ put $ toRational ndt++getTime :: Get UTCTime+getTime = do+ d <- get+ ndt <- get+ return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0++#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 (B.pack 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
Yesod/Form.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE CPP #-} -- | Parse forms (and query strings). module Yesod.Form ( Form (..)@@ -20,15 +21,18 @@ ) where import Yesod.Request-import Yesod.Response (ErrorResponse) import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) import Data.Convertible.Text-import Data.Attempt import Data.Maybe (fromMaybe)-import "transformers" Control.Monad.Trans (MonadIO)-import qualified Safe.Failure+#if MIN_VERSION_transformers(0,2,0)+import "transformers" Control.Monad.IO.Class+#else+import "transformers" Control.Monad.Trans+#endif+import Yesod.Internal+import Control.Monad.Attempt noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)"@@ -45,14 +49,14 @@ instance Applicative Form where pure x = Form $ \_ -> Right (Nothing, x) (Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of- (Right (_, f), Right (_, x)) -> Right $ (Nothing, f x)+ (Right (_, f), Right (_, x)) -> Right (Nothing, f x) (Left e1, Left e2) -> Left $ e1 ++ e2 (Left e, _) -> Left e (_, Left e) -> Left e type FormError = String -runFormGeneric :: MonadFailure ErrorResponse m+runFormGeneric :: Failure ErrorResponse m => (ParamName -> [ParamValue]) -> Form x -> m x runFormGeneric params (Form f) = case f params of@@ -60,7 +64,7 @@ Right (_, x) -> return x -- | Run a form against POST parameters.-runFormPost :: (RequestReader m, MonadFailure ErrorResponse m, MonadIO m)+runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m) => Form x -> m x runFormPost f = do rr <- getRequest@@ -68,14 +72,14 @@ runFormGeneric pp f -- | Run a form against GET parameters.-runFormGet :: (RequestReader m, MonadFailure ErrorResponse m)+runFormGet :: (RequestReader m, Failure ErrorResponse m) => Form x -> m x runFormGet f = do rr <- getRequest runFormGeneric (getParams rr) f input :: ParamName -> Form [ParamValue]-input pn = Form $ \l -> Right $ (Just pn, l pn)+input pn = Form $ \l -> Right (Just pn, l pn) applyForm :: (x -> Either FormError y) -> Form x -> Form y applyForm f (Form x') =@@ -118,9 +122,9 @@ checkInteger :: Form ParamValue -> Form Integer checkInteger = applyForm $ \pv ->- case Safe.Failure.read pv of- Nothing -> Left "Invalid integer"- Just i -> Right i+ case reads pv of+ [] -> Left "Invalid integer"+ ((i, _):_) -> Right i -- | Instead of calling 'failure' with an 'InvalidArgs', return the error -- messages.
+ Yesod/Hamlet.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Yesod.Hamlet+ ( -- * Hamlet library+ Hamlet+ , hamlet+ , HtmlContent (..)+ , htmlContentToText+ -- * Convert to something displayable+ , hamletToContent+ , hamletToRepHtml+ -- * Page templates+ , PageContent (..)+ )+ where++import Text.Hamlet+import Text.Hamlet.Monad (outputHtml, htmlContentToText)+import Yesod.Content+import Yesod.Handler+import Data.Convertible.Text+import Web.Routes.Quasi (Routes)++-- | 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 IO ()+data PageContent url = PageContent+ { pageTitle :: HtmlContent+ , pageHead :: Hamlet url IO ()+ , pageBody :: Hamlet url IO ()+ }++-- | Converts the given Hamlet template into 'Content', which can be used in a+-- Yesod 'Response'.+hamletToContent :: Hamlet (Routes master) IO () -> GHandler sub master Content+hamletToContent h = do+ render <- getUrlRender+ return $ ContentEnum $ go render+ where+ go render iter seed = do+ res <- runHamlet h render seed $ iter' iter+ case res of+ Left x -> return $ Left x+ Right ((), x) -> return $ Right x+ iter' iter seed text = iter seed $ cs text++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+hamletToRepHtml :: Hamlet (Routes master) IO () -> GHandler sub master RepHtml+hamletToRepHtml = fmap RepHtml . hamletToContent++instance Monad m => ConvertSuccess String (Hamlet url m ()) where+ convertSuccess = outputHtml . Unencoded . cs+instance ConvertSuccess String HtmlContent where+ convertSuccess = Unencoded . cs
Yesod/Handler.hs view
@@ -4,6 +4,9 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Handler@@ -20,134 +23,347 @@ module Yesod.Handler ( -- * Handler monad Handler+ , GHandler+ -- ** Read information from handler , getYesod- , runHandler- , liftIO- -- * Special handlers+ , getYesodSub+ , getUrlRender+ , getRoute+ , getRouteToMaster+ -- * Special responses+ -- ** Redirecting+ , RedirectType (..) , redirect- , sendFile+ , redirectParams+ , redirectString+ -- ** Errors , notFound+ , badMethod , permissionDenied , invalidArgs+ -- ** Sending static files+ , sendFile -- * Setting headers , addCookie , deleteCookie , header+ , setLanguage+ -- * Session+ , setSession+ , clearSession+ -- ** Ultimate destination+ , setUltDest+ , setUltDestString+ , setUltDest'+ , redirectUltDest+ -- ** Messages+ , setMessage+ , getMessage+ -- * Internal Yesod+ , runHandler+ , YesodApp (..) ) where +import Prelude hiding (catch) import Yesod.Request-import Yesod.Response-import Web.Mime+import Yesod.Content+import Yesod.Internal+import Web.Routes.Quasi (Routes)+import Data.List (foldl', intercalate)+import Text.Hamlet.Monad (htmlContentToText) -import Control.Exception hiding (Handler)+import Control.Exception hiding (Handler, catch)+import qualified Control.Exception as E import Control.Applicative +#if MIN_VERSION_transformers(0,2,0)+import "transformers" Control.Monad.IO.Class+#else import "transformers" Control.Monad.Trans-import Control.Monad.Attempt+#endif+import qualified Control.Monad.CatchIO as C+import Control.Monad.CatchIO (catch) import Control.Monad (liftM, ap) import System.IO-import Data.Object.Html import qualified Data.ByteString.Lazy as BL import qualified Network.Wai as W+import Control.Monad.Attempt -data HandlerData yesod = HandlerData Request yesod+import Data.Convertible.Text (cs)+import Text.Hamlet+import Numeric (showIntAtBase)+import Data.Char (ord, chr) ------- Handler monad-newtype Handler yesod a = Handler {- unHandler :: HandlerData yesod- -> IO ([Header], HandlerContents a)+data HandlerData sub master = HandlerData+ { handlerRequest :: Request+ , handlerSub :: sub+ , handlerMaster :: master+ , handlerRoute :: Maybe (Routes sub)+ , handlerRender :: (Routes master -> String)+ , handlerToMaster :: Routes sub -> Routes master+ }++-- | A generic handler monad, which can have a different subsite and master+-- site. This monad is a combination of reader for basic arguments, a writer+-- for headers, and an error-type monad for handling special responses.+newtype GHandler sub master a = Handler {+ unHandler :: HandlerData sub master+ -> IO ([Header], [(String, Maybe String)], HandlerContents a) }++-- | A 'GHandler' limited to the case where the master and sub sites are the+-- same. This is the usual case for application writing; only code written+-- specifically as a subsite need been concerned with the more general variety.+type Handler yesod = GHandler yesod yesod++-- | 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]+ -> IO (W.Status, [Header], ContentType, Content, [(String, String)])+ }+ data HandlerContents a =- HCSpecial SpecialResponse+ HCContent a | HCError ErrorResponse- | HCContent a+ | HCSendFile ContentType FilePath+ | HCRedirect RedirectType String -instance Functor (Handler yesod) where+instance Functor (GHandler sub master) where fmap = liftM-instance Applicative (Handler yesod) where+instance Applicative (GHandler sub master) where pure = return (<*>) = ap-instance Monad (Handler yesod) where+instance Monad (GHandler sub master) where fail = failure . InternalError -- We want to catch all exceptions anyway- return x = Handler $ \_ -> return ([], HCContent x)+ return x = Handler $ \_ -> return ([], [], HCContent x) (Handler handler) >>= f = Handler $ \rr -> do- (headers, c) <- handler rr- (headers', c') <-+ (headers, session', c) <- handler rr+ (headers', session'', c') <- case c of- (HCError e) -> return ([], HCError e)- (HCSpecial e) -> return ([], HCSpecial e)- (HCContent a) -> unHandler (f a) rr- return (headers ++ headers', c')-instance MonadIO (Handler yesod) where- liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')-instance Failure ErrorResponse (Handler yesod) where- failure e = Handler $ \_ -> return ([], HCError e)-instance RequestReader (Handler yesod) where- getRequest = Handler $ \(HandlerData rr _)- -> return ([], HCContent rr)+ HCContent a -> unHandler (f a) rr+ HCError e -> return ([], [], HCError e)+ HCSendFile ct fp -> return ([], [], HCSendFile ct fp)+ HCRedirect rt url -> return ([], [], HCRedirect rt url)+ return (headers ++ headers', session' ++ session'', c')+instance MonadIO (GHandler sub master) where+ liftIO i = Handler $ \_ -> i >>= \i' -> return ([], [], HCContent i')+instance C.MonadCatchIO (GHandler sub master) where+ catch (Handler m) f =+ Handler $ \d -> E.catch (m d) (\e -> unHandler (f e) d)+ block (Handler m) =+ Handler $ E.block . m+ unblock (Handler m) =+ Handler $ E.unblock . m+instance Failure ErrorResponse (GHandler sub master) where+ failure e = Handler $ \_ -> return ([], [], HCError e)+instance RequestReader (GHandler sub master) where+ getRequest = handlerRequest <$> getData -getYesod :: Handler yesod yesod-getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod)+getData :: GHandler sub master (HandlerData sub master)+getData = Handler $ \r -> return ([], [], HCContent r) -runHandler :: Handler yesod ChooseRep- -> (ErrorResponse -> Handler yesod ChooseRep)- -> Request- -> yesod- -> [ContentType]- -> IO Response-runHandler handler eh rr y cts = do+-- | Get the sub application argument.+getYesodSub :: GHandler sub master sub+getYesodSub = handlerSub <$> getData++-- | Get the master site appliation argument.+getYesod :: GHandler sub master master+getYesod = handlerMaster <$> getData++-- | Get the URL rendering function.+getUrlRender :: GHandler sub master (Routes master -> String)+getUrlRender = handlerRender <$> getData++-- | 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'.+getRoute :: GHandler sub master (Maybe (Routes sub))+getRoute = handlerRoute <$> getData++-- | Get the function to promote a route for a subsite to a route for the+-- master site.+getRouteToMaster :: GHandler sub master (Routes sub -> Routes master)+getRouteToMaster = handlerToMaster <$> getData++modifySession :: [(String, String)] -> (String, Maybe String)+ -> [(String, String)]+modifySession orig (k, v) =+ case v of+ Nothing -> dropKeys k orig+ Just v' -> (k, v') : dropKeys k orig++dropKeys :: String -> [(String, x)] -> [(String, x)]+dropKeys k = filter $ \(x, _) -> x /= k++-- | 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+ -> (Routes master -> String)+ -> Maybe (Routes sub)+ -> (Routes sub -> Routes master)+ -> master+ -> (master -> sub)+ -> YesodApp+runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do let toErrorHandler = InternalError . (show :: Control.Exception.SomeException -> String)- (headers, contents) <- Control.Exception.catch- (unHandler handler $ HandlerData rr y)- (\e -> return ([], HCError $ toErrorHandler e))+ (headers, session', contents) <- E.catch+ (unHandler handler HandlerData+ { handlerRequest = rr+ , handlerSub = tosa ma+ , handlerMaster = ma+ , handlerRoute = sroute+ , handlerRender = mrender+ , handlerToMaster = tomr+ })+ (\e -> return ([], [], HCError $ toErrorHandler e))+ let finalSession = foldl' modifySession (reqSession rr) session' let handleError e = do- Response _ hs ct c <- runHandler (eh e) safeEh rr y cts+ (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs- return $ Response (getStatus e) hs' ct c+ return (getStatus e, hs', ct, c, sess) let sendFile' ct fp = do c <- BL.readFile fp- return $ Response W.Status200 headers ct $ cs c+ return (W.Status200, headers, ct, cs c, finalSession) case contents of+ HCContent a -> do+ (ct, c) <- chooseRep a cts+ return (W.Status200, headers, ct, c, finalSession) HCError e -> handleError e- HCSpecial (Redirect rt loc) -> do+ HCRedirect rt loc -> do let hs = Header "Location" loc : headers- return $ Response (getRedirectStatus rt) hs TypePlain $ cs ""- HCSpecial (SendFile ct fp) -> Control.Exception.catch+ return (getRedirectStatus rt, hs, TypePlain, cs "", finalSession)+ HCSendFile ct fp -> E.catch (sendFile' ct fp) (handleError . toErrorHandler)- HCContent a -> do- (ct, c) <- a cts- return $ Response W.Status200 headers ct c -safeEh :: ErrorResponse -> Handler yesod ChooseRep-safeEh er = do+safeEh :: ErrorResponse -> YesodApp+safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er- return $ chooseRep- ( Tag "title" [] $ cs "Internal Server Error"- , toHtmlObject "Internal server error"- )+ return (W.Status500, [], TypePlain, cs "Internal Server Error", []) ------- Special handlers-specialResponse :: SpecialResponse -> Handler yesod a-specialResponse er = Handler $ \_ -> return ([], HCSpecial er)+-- | Redirect to the given route.+redirect :: RedirectType -> Routes master -> GHandler sub master a+redirect rt url = do+ r <- getUrlRender+ redirectString rt $ r url +-- | Redirects to the given route with the associated query-string parameters.+redirectParams :: RedirectType -> Routes master -> [(String, String)]+ -> GHandler sub master a+redirectParams rt url params = do+ r <- getUrlRender+ redirectString rt $ r url ++ '?' : encodeUrlPairs params+ where+ encodeUrlPairs = intercalate "&" . map encodeUrlPair+ encodeUrlPair (x, []) = escape x+ encodeUrlPair (x, y) = escape x ++ '=' : escape y+ escape = concatMap escape'+ escape' c+ | 'A' < c && c < 'Z' = [c]+ | 'a' < c && c < 'a' = [c]+ | '0' < c && c < '9' = [c]+ | c `elem` ".-~_" = [c]+ | c == ' ' = "+"+ | otherwise = '%' : myShowHex (ord c) ""+ myShowHex :: Int -> ShowS+ myShowHex n r = case showIntAtBase 16 (toChrHex) n r of+ [] -> "00"+ [c] -> ['0',c]+ s -> s+ toChrHex d+ | d < 10 = chr (ord '0' + fromIntegral d)+ | otherwise = chr (ord 'A' + fromIntegral (d - 10))+ -- | Redirect to the given URL.-redirect :: RedirectType -> String -> Handler yesod a-redirect rt = specialResponse . Redirect rt+redirectString :: RedirectType -> String -> GHandler sub master a+redirectString rt url = Handler $ \_ -> return ([], [], HCRedirect rt url) -sendFile :: ContentType -> FilePath -> Handler yesod a-sendFile ct = specialResponse . SendFile ct+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 :: Routes 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 <- getRoute+ tm <- getRouteToMaster+ maybe (return ()) setUltDest $ tm <$> route++-- | 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+ -> Routes master -- ^ default destination if nothing in session+ -> GHandler sub master ()+redirectUltDest rt def = do+ mdest <- lookupSession ultDestKey+ clearSession ultDestKey+ maybe (redirect rt def) (redirectString rt) mdest++msgKey :: String+msgKey = "_MSG"++-- | Sets a message in the user's session.+--+-- See 'getMessage'.+setMessage :: HtmlContent -> GHandler sub master ()+setMessage = setSession msgKey . cs . htmlContentToText++-- | Gets the message in the user's session, if available, and then clears the+-- variable.+--+-- See 'setMessage'.+getMessage :: GHandler sub master (Maybe HtmlContent)+getMessage = do+ clearSession msgKey+ fmap (fmap $ Encoded . cs) $ lookupSession msgKey++-- | 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 fp = Handler $ \_ -> return ([], [], HCSendFile ct fp)+ -- | 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 $ cs $ W.methodToBS $ W.requestMethod w++-- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a permissionDenied = failure PermissionDenied +-- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a invalidArgs = failure . InvalidArgs @@ -156,16 +372,52 @@ addCookie :: Int -- ^ minutes to timeout -> String -- ^ key -> String -- ^ value- -> Handler yesod ()+ -> GHandler sub master () addCookie a b = addHeader . AddCookie a b -- | Unset the cookie on the client.-deleteCookie :: String -> Handler yesod ()+deleteCookie :: String -> GHandler sub master () deleteCookie = addHeader . DeleteCookie +-- | Set the language header. Will show up in 'languages'.+setLanguage :: String -> GHandler sub master ()+setLanguage = addCookie 60 langKey+ -- | Set an arbitrary header on the client.-header :: String -> String -> Handler yesod ()+header :: String -> String -> GHandler sub master () header a = addHeader . Header a -addHeader :: Header -> Handler yesod ()-addHeader h = Handler $ \_ -> return ([h], HCContent ())+-- | 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 v = Handler $ \_ -> return ([], [(k, Just v)], HCContent ())++-- | Unsets a session variable. See 'setSession'.+clearSession :: String -> GHandler sub master ()+clearSession k = Handler $ \_ -> return ([], [(k, Nothing)], HCContent ())++addHeader :: Header -> GHandler sub master ()+addHeader h = Handler $ \_ -> return ([h], [], HCContent ())++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)
Yesod/Helpers/AtomFeed.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.AtomFeed@@ -14,64 +13,64 @@ -- --------------------------------------------------------- +-- | Generation of Atom newsfeeds. See+-- <http://en.wikipedia.org/wiki/Atom_(standard)>. module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..)- , AtomFeedResponse (..) , atomFeed+ , RepAtom (..) ) where import Yesod import Data.Time.Clock (UTCTime)-import Web.Encodings (formatW3)+import Text.Hamlet.Monad+import Text.Hamlet.Quasi -data AtomFeedResponse = AtomFeedResponse AtomFeed Approot+newtype RepAtom = RepAtom Content+instance HasReps RepAtom where+ chooseRep (RepAtom c) _ = return (TypeAtom, c) -atomFeed :: YesodApproot y => AtomFeed -> Handler y AtomFeedResponse-atomFeed f = do- y <- getYesod- return $ AtomFeedResponse f $ approot y+atomFeed :: AtomFeed (Routes master) -> GHandler sub master RepAtom+atomFeed = fmap RepAtom . hamletToContent . template -data AtomFeed = AtomFeed+data AtomFeed url = AtomFeed { atomTitle :: String- , atomLinkSelf :: Location- , atomLinkHome :: Location+ , atomLinkSelf :: url+ , atomLinkHome :: url , atomUpdated :: UTCTime- , atomEntries :: [AtomFeedEntry]+ , atomEntries :: [AtomFeedEntry url] }-instance HasReps AtomFeedResponse where- chooseRep = defChooseRep- [ (TypeAtom, return . cs)- ] -data AtomFeedEntry = AtomFeedEntry- { atomEntryLink :: Location+data AtomFeedEntry url = AtomFeedEntry+ { atomEntryLink :: url , atomEntryUpdated :: UTCTime , atomEntryTitle :: String- , atomEntryContent :: Html+ , atomEntryContent :: HtmlContent } -instance ConvertSuccess AtomFeedResponse Content where- convertSuccess = cs . (cs :: Html -> XmlDoc) . cs-instance ConvertSuccess AtomFeedResponse Html where- convertSuccess (AtomFeedResponse f ar) =- Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList- [ Tag "title" [] $ cs $ atomTitle f- , EmptyTag "link" [ ("rel", "self")- , ("href", showLocation ar $ atomLinkSelf f)- ]- , EmptyTag "link" [ ("href", showLocation ar $ atomLinkHome f)- ]- , Tag "updated" [] $ cs $ formatW3 $ atomUpdated f- , Tag "id" [] $ cs $ showLocation ar $ atomLinkHome f- , HtmlList $ map cs $ zip (atomEntries f) $ repeat ar- ]+xmlns :: AtomFeed url -> HtmlContent+xmlns _ = cs "http://www.w3.org/2005/Atom" -instance ConvertSuccess (AtomFeedEntry, Approot) Html where- convertSuccess (e, ar) = Tag "entry" [] $ HtmlList- [ Tag "id" [] $ cs $ showLocation ar $ atomEntryLink e- , EmptyTag "link" [("href", showLocation ar $ atomEntryLink e)]- , Tag "updated" [] $ cs $ formatW3 $ atomEntryUpdated e- , Tag "title" [] $ cs $ atomEntryTitle e- , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e- ]+template :: AtomFeed url -> Hamlet url IO ()+template arg = [$xhamlet|+<?xml version="1.0" encoding="utf-8"?>+%feed!xmlns=$xmlns.arg$+ %title $cs.atomTitle.arg$+ %link!rel=self!href=@atomLinkSelf.arg@+ %link!href=@atomLinkHome.arg@+ %updated $cs.formatW3.atomUpdated.arg$+ %id @atomLinkHome.arg@+ $forall atomEntries.arg entry+ ^entryTemplate.entry^+|]++entryTemplate :: AtomFeedEntry url -> Hamlet url IO ()+entryTemplate arg = [$xhamlet|+%entry+ %id @atomEntryLink.arg@+ %link!href=@atomEntryLink.arg@+ %updated $cs.formatW3.atomEntryUpdated.arg$+ %title $cs.atomEntryTitle.arg$+ %content!type=html $cdata.atomEntryContent.arg$+|]
Yesod/Helpers/Auth.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Auth@@ -15,246 +20,466 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth- ( authHandler+ ( -- * Subsite+ Auth (..)+ , AuthRoutes (..)+ , siteAuth+ -- * Settings , YesodAuth (..)- , maybeIdentifier- , authIdentifier- , displayName- , redirectLogin+ , Creds (..)+ , EmailCreds (..)+ , AuthType (..)+ , AuthEmailSettings (..)+ , inMemoryEmailSettings+ -- * Functions+ , maybeCreds+ , requireCreds ) where -import Web.Encodings import qualified Web.Authenticate.Rpxnow as Rpxnow import qualified Web.Authenticate.OpenId as OpenId import Yesod +import Data.Maybe+import Control.Monad+import System.Random+import Data.Digest.Pure.MD5+import Control.Applicative+import Control.Concurrent.MVar+import System.IO import Control.Monad.Attempt-import qualified Data.ByteString.Char8 as B8 -import Data.Maybe (fromMaybe)-import qualified Network.Wai as W-import Data.Typeable (Typeable)-import Control.Exception (Exception)-import Control.Applicative ((<$>))+class Yesod master => YesodAuth master where+ -- | Default destination on successful login or logout, if no other+ -- destination exists.+ defaultDest :: master -> Routes master --- FIXME check referer header to determine destination+ -- | Default page to redirect user to for logging in.+ defaultLoginRoute :: master -> Routes master -class YesodApproot a => YesodAuth a where- -- | The following breaks DRY, but I cannot think of a better solution- -- right now.+ -- | Callback for a successful login. --- -- The root relative to the application root. Should not begin with a slash- -- and should end with one.- authRoot :: a -> String- authRoot _ = "auth/"+ -- The second parameter can contain various information, depending on login+ -- mechanism.+ onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()+ onLogin _ _ = return () - -- | Absolute path to the default login path.- defaultLoginPath :: a -> String- defaultLoginPath a = approot a ++ authRoot a ++ "openid/"+ -- | Generate a random alphanumeric string.+ --+ -- This is used for verify string in email authentication.+ randomKey :: master -> IO String+ randomKey _ = do+ stdgen <- newStdGen+ return $ take 10 $ randomRs ('A', 'Z') stdgen - rpxnowApiKey :: a -> Maybe String- rpxnowApiKey _ = Nothing+-- | Each authentication subsystem (OpenId, Rpxnow, Email) has its own+-- settings. If those settings are not present, then relevant handlers will+-- simply return a 404.+data Auth = Auth+ { authIsOpenIdEnabled :: Bool+ , authRpxnowApiKey :: Maybe String+ , authEmailSettings :: Maybe AuthEmailSettings+ } - onRpxnowLogin :: Rpxnow.Identifier -> Handler a ()- onRpxnowLogin _ = return ()+-- | Which subsystem authenticated the user.+data AuthType = AuthOpenId | AuthRpxnow | AuthEmail+ deriving (Show, Read, Eq) -getFullAuthRoot :: YesodAuth y => Handler y String-getFullAuthRoot = do- y <- getYesod- ar <- getApproot- return $ ar ++ authRoot y+type Email = String+type VerKey = String+type VerUrl = String+type EmailId = Integer+type SaltedPass = String+type VerStatus = Bool -data AuthResource =- Check- | Logout- | Openid- | OpenidForward- | OpenidComplete- | LoginRpxnow- deriving (Show, Eq, Enum, Bounded)+-- | Data stored in a database for each e-mail address.+data EmailCreds = EmailCreds EmailId (Maybe SaltedPass) VerStatus VerKey -rc :: HasReps x => Handler y x -> Handler y ChooseRep-rc = fmap chooseRep+-- | For a sample set of settings for a trivial in-memory database, see+-- 'inMemoryEmailSettings'.+data AuthEmailSettings = AuthEmailSettings+ { addUnverified :: Email -> VerKey -> IO EmailId+ , sendVerifyEmail :: Email -> VerKey -> VerUrl -> IO ()+ , getVerifyKey :: EmailId -> IO (Maybe VerKey)+ , verifyAccount :: EmailId -> IO ()+ , setPassword :: EmailId -> String -> IO ()+ , getEmailCreds :: Email -> IO (Maybe EmailCreds)+ , getEmail :: EmailId -> IO (Maybe Email)+ } -authHandler :: YesodAuth y => W.Method -> [String] -> Handler y ChooseRep-authHandler W.GET ["check"] = rc authCheck-authHandler W.GET ["logout"] = rc authLogout-authHandler W.GET ["openid"] = rc authOpenidForm-authHandler W.GET ["openid", "forward"] = rc authOpenidForward-authHandler W.GET ["openid", "complete"] = rc authOpenidComplete--- two different versions of RPX protocol apparently, so just accepting all--- verbs-authHandler _ ["login", "rpxnow"] = rc rpxnowLogin-authHandler _ _ = notFound+-- | User credentials+data Creds = Creds+ { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.+ , credsAuthType :: AuthType -- ^ How the user was authenticated+ , credsEmail :: Maybe String -- ^ Verified e-mail address.+ , credsDisplayName :: Maybe String -- ^ Display name.+ , credsId :: Maybe Integer -- ^ Numeric ID, if used.+ }+ deriving (Show, Read, Eq) -data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)-instance ConvertSuccess OIDFormReq Html where- convertSuccess (OIDFormReq Nothing _) = cs ""- convertSuccess (OIDFormReq (Just s) _) =- Tag "p" [("class", "message")] $ cs s+credsKey :: String+credsKey = "_CREDS" -data ExpectedSingleParam = ExpectedSingleParam- deriving (Show, Typeable)-instance Exception ExpectedSingleParam+setCreds :: YesodAuth master+ => Creds -> [(String, String)] -> GHandler Auth master ()+setCreds creds extra = do+ setSession credsKey $ show creds+ onLogin creds extra -authOpenidForm :: Yesod y => Handler y ChooseRep-authOpenidForm = do+-- | Retrieves user credentials, if user is authenticated.+maybeCreds :: RequestReader r => r (Maybe Creds)+maybeCreds = do+ mcs <- lookupSession credsKey+ return $ mcs >>= readMay+ where+ readMay x = case reads x of+ (y, _):_ -> Just y+ _ -> Nothing++mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|+/check Check GET+/logout Logout GET+/openid OpenIdR GET+/openid/forward OpenIdForward GET+/openid/complete OpenIdComplete GET+/login/rpxnow RpxnowR++/register EmailRegisterR GET POST+/verify/#EmailId/#String EmailVerifyR GET+/login EmailLoginR GET POST+/set-password EmailPasswordR GET POST+|]++testOpenId :: GHandler Auth master ()+testOpenId = do+ a <- getYesodSub+ unless (authIsOpenIdEnabled a) notFound++getOpenIdR :: Yesod master => GHandler Auth master RepHtml+getOpenIdR = do+ testOpenId rr <- getRequest case getParams rr "dest" of [] -> return ()- (x:_) -> addCookie destCookieTimeout destCookieName x- let html =- HtmlList- [ case getParams rr "message" of- [] -> HtmlList []- (m:_) -> Tag "p" [("class", "message")] $ cs m- , Tag "form" [("method", "get"), ("action", "forward/")] $- HtmlList- [ Tag "label" [("for", "openid")] $ cs "OpenID: "- , EmptyTag "input" [("type", "text"), ("id", "openid"),- ("name", "openid")]- , EmptyTag "input" [("type", "submit"), ("value", "Login")]- ]- ]- applyLayout' "Log in via OpenID" html+ (x:_) -> setUltDestString x+ rtom <- getRouteToMaster+ message <- getMessage+ applyLayout "Log in via OpenID" (return ()) [$hamlet|+$maybe message msg+ %p.message $msg$+%form!method=get!action=@rtom.OpenIdForward@+ %label!for=openid OpenID: + %input#openid!type=text!name=openid+ %input!type=submit!value=Login+|] -authOpenidForward :: YesodAuth y => Handler y ()-authOpenidForward = do+getOpenIdForward :: GHandler Auth master ()+getOpenIdForward = do+ testOpenId rr <- getRequest oid <- case getParams rr "openid" of [x] -> return x- _ -> invalidArgs [("openid", show ExpectedSingleParam)]- authroot <- getFullAuthRoot- let complete = authroot ++ "/openid/complete/"+ _ -> invalidArgs [("openid", "Expected single parameter")]+ render <- getUrlRender+ toMaster <- getRouteToMaster+ let complete = render $ toMaster OpenIdComplete res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt- (\err -> redirect RedirectTemporary- $ "/auth/openid/?message=" ++ encodeUrl (show err))- (redirect RedirectTemporary)+ (\err -> do+ setMessage $ cs $ show err+ redirect RedirectTemporary $ toMaster OpenIdR)+ (redirectString RedirectTemporary) res -authOpenidComplete :: YesodApproot y => Handler y ()-authOpenidComplete = do+getOpenIdComplete :: YesodAuth master => GHandler Auth master ()+getOpenIdComplete = do+ testOpenId rr <- getRequest let gets' = reqGetParams rr res <- runAttemptT $ OpenId.authenticate gets'- let onFailure err = redirect RedirectTemporary- $ "/auth/openid/?message="- ++ encodeUrl (show err)+ toMaster <- getRouteToMaster+ let onFailure err = do+ setMessage $ cs $ show err+ redirect RedirectTemporary $ toMaster OpenIdR let onSuccess (OpenId.Identifier ident) = do- ar <- getApproot- header authCookieName ident- redirectToDest RedirectTemporary ar+ y <- getYesod+ setCreds (Creds ident AuthOpenId Nothing Nothing Nothing) []+ redirectUltDest RedirectTemporary $ defaultDest y attempt onFailure onSuccess res -rpxnowLogin :: YesodAuth y => Handler y ()-rpxnowLogin = do+handleRpxnowR :: YesodAuth master => GHandler Auth master ()+handleRpxnowR = do ay <- getYesod- let ar = approot ay- apiKey <- case rpxnowApiKey ay of+ auth <- getYesodSub+ apiKey <- case authRpxnowApiKey auth of Just x -> return x Nothing -> notFound rr <- getRequest pp <- postParams rr let token = case getParams rr "token" ++ pp "token" of- [] -> failure MissingToken+ [] -> invalidArgs [("token", "Value not supplied")] (x:_) -> x- let dest = case pp "dest" of- [] -> case getParams rr "dest" of- [] -> ar- ("":_) -> ar- (('#':rest):_) -> rest- (s:_) -> s- (d:_) -> d- ident <- liftIO $ Rpxnow.authenticate apiKey token- onRpxnowLogin ident- header authCookieName $ Rpxnow.identifier ident- header authDisplayName $ getDisplayName ident- redirectToDest RedirectTemporary dest--data MissingToken = MissingToken- deriving (Show, Typeable)-instance Exception MissingToken+ Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token+ let creds = Creds+ ident+ AuthRpxnow+ (lookup "verifiedEmail" extra)+ (getDisplayName extra)+ Nothing+ setCreds creds extra+ either (redirect RedirectTemporary) (redirectString RedirectTemporary) $+ case pp "dest" of+ (d:_) -> Right d+ [] -> case getParams rr "dest" of+ [] -> Left $ defaultDest ay+ ("":_) -> Left $ defaultDest ay+ (('#':rest):_) -> Right rest+ (s:_) -> Right s --- | Get some form of a display name, defaulting to the identifier.-getDisplayName :: Rpxnow.Identifier -> String-getDisplayName (Rpxnow.Identifier ident extra) = helper choices where+-- | Get some form of a display name.+getDisplayName :: [(String, String)] -> Maybe String+getDisplayName extra =+ foldr (\x -> mplus (lookup x extra)) Nothing choices+ where choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]- helper [] = ident- helper (x:xs) = case lookup x extra of- Nothing -> helper xs- Just y -> y -authCheck :: Yesod y => Handler y ChooseRep-authCheck = do- ident <- maybeIdentifier- dn <- displayName- applyLayoutJson "Authentication Status" $ cs- [ ("identifier", fromMaybe "" ident)- , ("displayName", fromMaybe "" dn)- ]+getCheck :: Yesod master => GHandler Auth master RepHtmlJson+getCheck = do+ creds <- maybeCreds+ applyLayoutJson "Authentication Status"+ (return ()) (html creds) (json creds)+ where+ html creds = [$hamlet|+%h1 Authentication Status+$if isNothing.creds+ %p Not logged in+$maybe creds c+ %p Logged in as $cs.credsIdent.c$+|]+ json creds =+ jsonMap+ [ ("ident", jsonScalar $ maybe (cs "") (cs . credsIdent) creds)+ , ("displayName", jsonScalar $ cs $ fromMaybe ""+ $ creds >>= credsDisplayName)+ ] -authLogout :: YesodAuth y => Handler y ()-authLogout = do- deleteCookie authCookieName- getApproot >>= redirectToDest RedirectTemporary+getLogout :: YesodAuth master => GHandler Auth master ()+getLogout = do+ y <- getYesod+ clearSession credsKey+ redirectUltDest RedirectTemporary $ defaultDest y --- | Gets the identifier for a user if available.-maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)-maybeIdentifier =- fmap cs . lookup (B8.pack authCookieName) . reqSession- <$> getRequest+-- | Retrieve user credentials. If user is not logged in, redirects to the+-- 'defaultLoginRoute'. Sets ultimate destination to current route, so user+-- should be sent back here after authenticating.+requireCreds :: YesodAuth master => GHandler sub master Creds+requireCreds =+ maybeCreds >>= maybe redirectLogin return+ where+ redirectLogin = do+ y <- getYesod+ setUltDest'+ redirect RedirectTemporary $ defaultLoginRoute y --- | Gets the display name for a user if available.-displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String)-displayName = do- rr <- getRequest- return $ fmap cs $ lookup (B8.pack authDisplayName) $ reqSession rr+getAuthEmailSettings :: GHandler Auth master AuthEmailSettings+getAuthEmailSettings = getYesodSub >>= maybe notFound return . authEmailSettings --- | Gets the identifier for a user. If user is not logged in, redirects them--- to the login page.-authIdentifier :: YesodAuth y => Handler y String-authIdentifier = maybeIdentifier >>= maybe redirectLogin return+getEmailRegisterR :: Yesod master => GHandler Auth master RepHtml+getEmailRegisterR = do+ _ae <- getAuthEmailSettings+ toMaster <- getRouteToMaster+ applyLayout "Register a new account" (return ()) [$hamlet|+%p Enter your e-mail address below, and a confirmation e-mail will be sent to you.+%form!method=post!action=@toMaster.EmailRegisterR@+ %label!for=email E-mail+ %input#email!type=email!name=email!width=150+ %input!type=submit!value=Register+|] --- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie--- appropriately.-redirectLogin :: YesodAuth y => Handler y a-redirectLogin =- defaultLoginPath `fmap` getYesod >>= redirectSetDest RedirectTemporary+postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml+postEmailRegisterR = do+ ae <- getAuthEmailSettings+ email <- runFormPost $ checkEmail $ required $ input "email"+ y <- getYesod+ mecreds <- liftIO $ getEmailCreds ae email+ (lid, verKey) <-+ case mecreds of+ Nothing -> liftIO $ do+ key <- randomKey y+ lid <- addUnverified ae email key+ return (lid, key)+ Just (EmailCreds lid _ _ key) -> return (lid, key)+ render <- getUrlRender+ tm <- getRouteToMaster+ let verUrl = render $ tm $ EmailVerifyR lid verKey+ liftIO $ sendVerifyEmail ae email verKey verUrl+ applyLayout "Confirmation e-mail sent" (return ()) [$hamlet|+%p A confirmation e-mail has been sent to $cs.email$.+|] --- | Determinge the path requested by the user (ie, the path info). This--- includes the query string.-requestPath :: (Functor m, Monad m, RequestReader m) => m String-requestPath = do- env <- waiRequest- let q = case B8.unpack $ W.queryString env of- "" -> ""- q'@('?':_) -> q'- q' -> '?' : q'- return $! dropSlash (B8.unpack $ W.pathInfo env) ++ q- where- dropSlash ('/':x) = x- dropSlash x = x+checkEmail :: Form ParamValue -> Form ParamValue+checkEmail = notEmpty -- FIXME consider including e-mail validation --- | Redirect to the given URL, and set a cookie with the current URL so the--- user will ultimately be sent back here.-redirectSetDest :: YesodApproot y => RedirectType -> String -> Handler y a-redirectSetDest rt dest = do- ar <- getApproot- rp <- requestPath- let curr = ar ++ rp- addCookie destCookieTimeout destCookieName curr- redirect rt dest+getEmailVerifyR :: YesodAuth master+ => Integer -> String -> GHandler Auth master RepHtml+getEmailVerifyR lid key = do+ ae <- getAuthEmailSettings+ realKey <- liftIO $ getVerifyKey ae lid+ memail <- liftIO $ getEmail ae lid+ case (realKey == Just key, memail) of+ (True, Just email) -> do+ liftIO $ verifyAccount ae lid+ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster EmailPasswordR+ _ -> applyLayout "Invalid verification key" (return ()) [$hamlet|+%p I'm sorry, but that was an invalid verification key.+ |] --- | Read the 'destCookieName' cookie and redirect to this destination. If the--- cookie is missing, then use the default path provided.-redirectToDest :: RedirectType -> String -> Handler y a-redirectToDest rt def = do- rr <- getRequest- dest <- case cookies rr destCookieName of- [] -> return def- (x:_) -> do- deleteCookie destCookieName- return x- redirect rt dest+getEmailLoginR :: Yesod master => GHandler Auth master RepHtml+getEmailLoginR = do+ _ae <- getAuthEmailSettings+ toMaster <- getRouteToMaster+ msg <- getMessage+ applyLayout "Login" (return ()) [$hamlet|+$maybe msg ms+ %p.message $ms$+%p Please log in to your account.+%p+ %a!href=@toMaster.EmailRegisterR@ I don't have an account+%form!method=post!action=@toMaster.EmailLoginR@+ %table+ %tr+ %th E-mail+ %td+ %input!type=email!name=email+ %tr+ %th Password+ %td+ %input!type=password!name=password+ %tr+ %td!colspan=2+ %input!type=submit!value=Login+|]++postEmailLoginR :: YesodAuth master => GHandler Auth master ()+postEmailLoginR = do+ ae <- getAuthEmailSettings+ (email, pass) <- runFormPost $ (,)+ <$> checkEmail (required $ input "email")+ <*> required (input "password")+ y <- getYesod+ mecreds <- liftIO $ getEmailCreds ae email+ let mlid =+ case mecreds of+ Just (EmailCreds lid (Just realpass) True _) ->+ if isValidPass pass realpass then Just lid else Nothing+ _ -> Nothing+ case mlid of+ Just lid -> do+ setCreds (Creds email AuthEmail (Just email) Nothing (Just lid)) []+ redirectUltDest RedirectTemporary $ defaultDest y+ Nothing -> do+ setMessage $ cs "Invalid email/password combination"+ toMaster <- getRouteToMaster+ redirect RedirectTemporary $ toMaster EmailLoginR++getEmailPasswordR :: Yesod master => GHandler Auth master RepHtml+getEmailPasswordR = do+ _ae <- getAuthEmailSettings+ toMaster <- getRouteToMaster+ mcreds <- maybeCreds+ case mcreds of+ Just (Creds _ AuthEmail _ _ (Just _)) -> return ()+ _ -> do+ setMessage $ cs "You must be logged in to set a password"+ redirect RedirectTemporary $ toMaster EmailLoginR+ msg <- getMessage+ applyLayout "Set password" (return ()) [$hamlet|+$maybe msg ms+ %p.message $ms$+%h3 Set a new password+%form!method=post!action=@toMaster.EmailPasswordR@+ %table+ %tr+ %th New password+ %td+ %input!type=password!name=new+ %tr+ %th Confirm+ %td+ %input!type=password!name=confirm+ %tr+ %td!colspan=2+ %input!type=submit!value=Submit+|]++postEmailPasswordR :: YesodAuth master => GHandler Auth master ()+postEmailPasswordR = do+ ae <- getAuthEmailSettings+ (new, confirm) <- runFormPost $ (,)+ <$> notEmpty (required $ input "new")+ <*> notEmpty (required $ input "confirm")+ toMaster <- getRouteToMaster+ when (new /= confirm) $ do+ setMessage $ cs "Passwords did not match, please try again"+ redirect RedirectTemporary $ toMaster EmailPasswordR+ mcreds <- maybeCreds+ lid <- case mcreds of+ Just (Creds _ AuthEmail _ _ (Just lid)) -> return lid+ _ -> do+ setMessage $ cs "You must be logged in to set a password"+ redirect RedirectTemporary $ toMaster EmailLoginR+ salted <- liftIO $ saltPass new+ liftIO $ setPassword ae lid salted+ setMessage $ cs "Password updated"+ redirect RedirectTemporary $ toMaster EmailLoginR++saltLength :: Int+saltLength = 5++isValidPass :: String -- ^ cleartext password+ -> String -- ^ salted password+ -> Bool+isValidPass clear salted =+ let salt = take saltLength salted+ in salted == saltPass' salt clear++saltPass :: String -> IO String+saltPass pass = do+ stdgen <- newStdGen+ let salt = take saltLength $ randomRs ('A', 'Z') stdgen+ return $ saltPass' salt pass++saltPass' :: String -> String -> String+saltPass' salt pass = salt ++ show (md5 $ cs $ salt ++ pass)++inMemoryEmailSettings :: IO AuthEmailSettings+inMemoryEmailSettings = do+ mm <- newMVar []+ return AuthEmailSettings+ { addUnverified = \email verkey -> modifyMVar mm $ \m -> do+ let helper (_, EmailCreds x _ _ _) = x+ let newId = 1 + maximum (0 : map helper m)+ let ec = EmailCreds newId Nothing False verkey+ return ((email, ec) : m, newId)+ , sendVerifyEmail = \_email _verkey verurl ->+ hPutStrLn stderr $ "Please go to: " ++ verurl+ , getVerifyKey = \eid -> withMVar mm $ \m -> return $+ lookup eid $ map (\(_, EmailCreds eid' _ _ vk) -> (eid', vk)) m+ , verifyAccount = \eid -> modifyMVar_ mm $ return . map (vago eid)+ , setPassword = \eid pass -> modifyMVar_ mm $ return . map (spgo eid pass)+ , getEmailCreds = \email -> withMVar mm $ return . lookup email+ , getEmail = \eid -> withMVar mm $ \m -> return $+ case filter (\(_, EmailCreds eid' _ _ _) -> eid == eid') m of+ ((email, _):_) -> Just email+ _ -> Nothing+ }+ where+ vago eid (email, EmailCreds eid' pass status key)+ | eid == eid' = (email, EmailCreds eid pass True key)+ | otherwise = (email, EmailCreds eid' pass status key)+ spgo eid pass (email, EmailCreds eid' pass' status key)+ | eid == eid' = (email, EmailCreds eid (Just pass) status key)+ | otherwise = (email, EmailCreds eid' pass' status key)
Yesod/Helpers/Sitemap.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE QuasiQuotes #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Sitemap@@ -15,16 +13,17 @@ -- --------------------------------------------------------- +-- | Generates XML sitemap files.+--+-- See <http://www.sitemaps.org/>. module Yesod.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) , SitemapChangeFreq (..)- , SitemapResponse (..) ) where import Yesod-import Web.Encodings (formatW3) import Data.Time (UTCTime) data SitemapChangeFreq = Always@@ -34,53 +33,43 @@ | Monthly | Yearly | Never-instance ConvertSuccess SitemapChangeFreq String where- convertSuccess Always = "always"- convertSuccess Hourly = "hourly"- convertSuccess Daily = "daily"- convertSuccess Weekly = "weekly"- convertSuccess Monthly = "monthly"- convertSuccess Yearly = "yearly"- convertSuccess Never = "never"-instance ConvertSuccess SitemapChangeFreq Html where- convertSuccess = (cs :: String -> Html) . cs -data SitemapUrl = SitemapUrl- { sitemapLoc :: Location+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 }-data SitemapResponse = SitemapResponse [SitemapUrl] Approot-instance ConvertSuccess SitemapResponse Content where- convertSuccess = cs . (cs :: Html -> XmlDoc) . cs-instance ConvertSuccess SitemapResponse Html where- convertSuccess (SitemapResponse urls ar) =- Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls- where- sitemapNS = "http://www.sitemaps.org/schemas/sitemap/0.9"- helper :: SitemapUrl -> Html- helper (SitemapUrl loc modTime freq pri) =- Tag "url" [] $ HtmlList- [ Tag "loc" [] $ cs $ showLocation ar loc- , Tag "lastmod" [] $ cs $ formatW3 modTime- , Tag "changefreq" [] $ cs freq- , Tag "priority" [] $ cs $ show pri- ] -instance HasReps SitemapResponse where- chooseRep = defChooseRep- [ (TypeXml, return . cs)- ]+sitemapNS :: HtmlContent+sitemapNS = cs "http://www.sitemaps.org/schemas/sitemap/0.9" -sitemap :: YesodApproot y => [SitemapUrl] -> Handler y SitemapResponse-sitemap urls = do- yesod <- getYesod- return $ SitemapResponse urls $ approot yesod+template :: [SitemapUrl url] -> Hamlet url IO ()+template urls = [$hamlet|+%urlset!xmlns=$sitemapNS$+ $forall urls url+ %url+ %loc @sitemapLoc.url@+ %lastmod $cs.formatW3.sitemapLastMod.url$+ %changefreq $cs.showFreq.sitemapChangeFreq.url$+ %priority $cs.show.priority.url$+|] -robots :: YesodApproot yesod => Handler yesod [(ContentType, Content)]-robots = do- yesod <- getYesod- return $ staticRep TypePlain $ "Sitemap: " ++ showLocation- (approot yesod)- (RelLoc "sitemap.xml")+sitemap :: [SitemapUrl (Routes master)] -> GHandler sub master RepXml+sitemap = fmap RepXml . hamletToContent . template++-- | A basic robots file which just lists the "Sitemap: " line.+robots :: Routes sub -- ^ sitemap url+ -> GHandler sub master RepPlain+robots smurl = do+ tm <- getRouteToMaster+ RepPlain `fmap` hamletToContent [$hamlet|Sitemap: @tm.smurl@|]
Yesod/Helpers/Static.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Helpers.Static@@ -10,47 +12,68 @@ -- Stability : Unstable -- Portability : portable ----- Serve static files from a Yesod app.++-- | 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- ( serveStatic- , FileLookup+ ( -- * Subsite+ Static (..)+ , StaticRoutes (..)+ , siteStatic+ -- * Lookup files in filesystem , fileLookupDir+ , staticFiles+#if TEST+ , testSuite+#endif ) where -import System.Directory (doesFileExist)+import System.Directory import Control.Monad import Yesod import Data.List (intercalate)+import Language.Haskell.TH.Syntax -type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))+#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+#endif --- | A 'FileLookup' for files in a directory. Note that this function does not--- check if the requested path does unsafe things, eg expose hidden files. You--- should provide this checking elsewhere.+-- | A function for looking up file contents. For serving from the file system,+-- see 'fileLookupDir'.+data Static = Static (FilePath -> IO (Maybe (Either FilePath Content)))++$(mkYesodSub "Static" [] [$parseRoutes|+*Strings StaticRoute GET+|])++-- | Lookup files in a specific directory. ----- If you are just using this in combination with serveStatic, serveStatic--- provides this checking.-fileLookupDir :: FilePath -> FileLookup-fileLookupDir dir fp = do+-- 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.+fileLookupDir :: FilePath -> Static+fileLookupDir dir = Static $ \fp -> do let fp' = dir ++ '/' : fp exists <- doesFileExist fp' if exists then return $ Just $ Left fp' else return Nothing -serveStatic :: FileLookup -> Method -> [String]- -> Handler y [(ContentType, Content)]-serveStatic fl GET fp = getStatic fl fp-serveStatic _ _ _ = notFound--getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)]-getStatic fl fp' = do+getStaticRoute :: [String]+ -> GHandler Static master [(ContentType, Content)]+getStaticRoute fp' = do+ Static fl <- getYesodSub when (any isUnsafe fp') notFound let fp = intercalate "/" fp' content <- liftIO $ fl fp@@ -58,7 +81,57 @@ Nothing -> notFound Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp'' Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)]- where- isUnsafe [] = True- isUnsafe ('.':_) = True- isUnsafe _ = False+ where+ isUnsafe [] = True+ isUnsafe ('.':_) = True+ isUnsafe _ = False++notHidden :: FilePath -> Bool+notHidden ('.':_) = 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'++staticFiles :: FilePath -> Q [Dec]+staticFiles fp = do+ fs <- qRunIO $ getFileList fp+ concat `fmap` mapM go fs+ where+ replace '.' = '_'+ replace c = c+ go f = do+ let name = mkName $ intercalate "_" $ map (map replace) f+ f' <- lift f+ let sr = ConE $ mkName "StaticRoute"+ return+ [ SigD name $ ConT ''StaticRoutes+ , FunD name+ [ Clause [] (NormalB $ sr `AppE` f') []+ ]+ ]++#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
+ Yesod/Internal.hs view
@@ -0,0 +1,30 @@+-- | Normal users should never need access to these.+module Yesod.Internal+ ( -- * Error responses+ ErrorResponse (..)+ -- * Header+ , Header (..)+ -- * Cookie names+ , langKey+ ) where++-- | 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, String)]+ | PermissionDenied+ | 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"
+ Yesod/Json.hs view
@@ -0,0 +1,145 @@+-- | Efficient generation of JSON documents, with HTML-entity encoding handled via types.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+module Yesod.Json+ ( -- * Monad+ Json+ , jsonToContent+ , jsonToRepJson+ -- * Generate Json output+ , jsonScalar+ , jsonList+ , jsonList'+ , jsonMap+ , jsonMap'+#if TEST+ , testSuite+#endif+ )+ where++import Text.Hamlet.Monad+import Control.Applicative+import Data.Text (pack)+import qualified Data.Text as T+import Data.Char (isControl)+import Yesod.Hamlet+import Control.Monad (when)+import Yesod.Handler+import Web.Routes.Quasi (Routes)+import Numeric (showHex)++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Data.Text.Lazy (unpack)+import Yesod.Content hiding (testSuite)+#else+import Yesod.Content+#endif++-- | A monad for generating Json output. In truth, it is just a newtype wrapper+-- around 'Hamlet'; we thereby get the benefits of Hamlet (interleaving IO and+-- enumerator output) without accidently mixing non-JSON content.+--+-- This is an opaque type to avoid any possible insertion of non-JSON content.+-- Due to the limited nature of the JSON format, you can create any valid JSON+-- document you wish using only 'jsonScalar', 'jsonList' and 'jsonMap'.+newtype Json url a = Json { unJson :: Hamlet url IO a }+ deriving (Functor, Applicative, Monad)++-- | Extract the final result from the given 'Json' value.+--+-- See also: applyLayoutJson in "Yesod.Yesod".+jsonToContent :: Json (Routes master) () -> GHandler sub master Content+jsonToContent = hamletToContent . unJson++-- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'.+jsonToRepJson :: Json (Routes master) () -> GHandler sub master RepJson+jsonToRepJson = fmap RepJson . jsonToContent++-- | Outputs a single scalar. This function essentially:+--+-- * Performs HTML entity escaping as necesary.+--+-- * Performs JSON encoding.+--+-- * Wraps the resulting string in quotes.+jsonScalar :: HtmlContent -> Json url ()+jsonScalar s = Json $ do+ outputString "\""+ output $ encodeJson $ htmlContentToText s+ outputString "\""+ where+ encodeJson = T.concatMap (T.pack . encodeJsonChar)++ encodeJsonChar '\b' = "\\b"+ encodeJsonChar '\f' = "\\f"+ encodeJsonChar '\n' = "\\n"+ encodeJsonChar '\r' = "\\r"+ encodeJsonChar '\t' = "\\t"+ encodeJsonChar '"' = "\\\""+ encodeJsonChar '\\' = "\\\\"+ encodeJsonChar c+ | not $ isControl c = [c]+ | c < '\x10' = '\\' : 'u' : '0' : '0' : '0' : hexxs+ | c < '\x100' = '\\' : 'u' : '0' : '0' : hexxs+ | c < '\x1000' = '\\' : 'u' : '0' : hexxs+ where hexxs = showHex (fromEnum c) ""+ encodeJsonChar c = [c]++-- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"].+jsonList :: [Json url ()] -> Json url ()+jsonList = jsonList' . fromList++-- | Same as 'jsonList', but uses an 'Enumerator' for input.+jsonList' :: Enumerator (Json url ()) (Json url) -> Json url ()+jsonList' (Enumerator enum) = do+ Json $ outputString "["+ _ <- enum go False+ Json $ outputString "]"+ where+ go putComma j = do+ when putComma $ Json $ outputString ","+ () <- j+ return $ Right True++-- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}.+jsonMap :: [(String, Json url ())] -> Json url ()+jsonMap = jsonMap' . fromList++-- | Same as 'jsonMap', but uses an 'Enumerator' for input.+jsonMap' :: Enumerator (String, Json url ()) (Json url) -> Json url ()+jsonMap' (Enumerator enum) = do+ Json $ outputString "{"+ _ <- enum go False+ Json $ outputString "}"+ where+ go putComma (k, v) = do+ when putComma $ Json $ outputString ","+ jsonScalar $ Unencoded $ pack k+ Json $ outputString ":"+ () <- v+ return $ Right True++#if TEST++testSuite :: Test+testSuite = testGroup "Yesod.Json"+ [ testCase "simple output" caseSimpleOutput+ ]++caseSimpleOutput :: Assertion+caseSimpleOutput = do+ let j = do+ jsonMap+ [ ("foo" , jsonList+ [ jsonScalar $ Encoded $ pack "bar"+ , jsonScalar $ Encoded $ pack "baz"+ ])+ ]+ t <- hamletToText id $ unJson j+ "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack t++#endif
Yesod/Request.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Yesod.Request@@ -15,76 +11,96 @@ -- Stability : Stable -- Portability : portable ----- Code for extracting parameters from requests.+-- | Provides a parsed version of the raw 'W.Request' data. -- --------------------------------------------------------- module Yesod.Request (- -- * Request- Request (..)+ -- * Request datatype+ RequestBodyContents+ , Request (..) , RequestReader (..)+ , FileInfo (..)+ -- * Convenience functions , waiRequest- , cookies+ , languages+ -- * Lookup parameters+ , lookupGetParam+ , lookupPostParam+ , lookupCookie+ , lookupSession+ -- ** Alternate , getParams , postParams- , languages- , parseWaiRequest- -- * Parameter+ , cookies+ , session+ -- * Parameter type synonyms , ParamName , ParamValue , ParamError-#if TEST- , testSuite-#endif ) where import qualified Network.Wai as W-import Data.Function.Predicate (equals)-import Yesod.Definitions-import Web.Encodings-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Convertible.Text-import Control.Arrow ((***))-import Data.Maybe (fromMaybe)+#if MIN_VERSION_transformers(0,2,0)+import "transformers" Control.Monad.IO.Class+#else import "transformers" Control.Monad.Trans-import Control.Concurrent.MVar--#if TEST-import Test.Framework (testGroup, Test)---import Test.Framework.Providers.HUnit---import Test.HUnit hiding (Test) #endif+import Control.Monad (liftM)+import Network.Wai.Parse+import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r type ParamName = String type ParamValue = String type ParamError = String -class RequestReader m where+-- | The reader monad specialized for 'Request'.+class Monad m => RequestReader m where getRequest :: m Request instance RequestReader ((->) Request) where getRequest = id -languages :: (Functor m, RequestReader m) => m [Language]-languages = reqLangs `fmap` getRequest+-- | 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.+--+-- * 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 req 'W.Request' value.-waiRequest :: (Functor m, RequestReader m) => m W.Request-waiRequest = reqWaiRequest `fmap` 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 String BL.ByteString)]+ , [(ParamName, FileInfo BL.ByteString)] ) --- | The req information passed through W, cleaned up a bit.+-- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)]- , reqSession :: [(B.ByteString, B.ByteString)]+ -- | Session data stored in a cookie via the clientsession package.+ , reqSession :: [(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. , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request- , reqLangs :: [Language]+ -- | Languages which the client supports.+ , reqLangs :: [String] } multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue]@@ -94,58 +110,52 @@ | otherwise = multiLookup rest pn -- | All GET paramater values with the given name.-getParams :: Request -> ParamName -> [ParamValue]-getParams rr = multiLookup $ reqGetParams rr+getParams :: RequestReader m => m (ParamName -> [ParamValue])+getParams = do+ rr <- getRequest+ return $ multiLookup $ reqGetParams rr +-- | Lookup for GET parameters.+lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupGetParam pn = do+ rr <- getRequest+ return $ lookup pn $ reqGetParams rr+ -- | All POST paramater values with the given name. postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue]) postParams rr = do (pp, _) <- liftIO $ reqRequestBody rr return $ multiLookup pp --- | 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)+-- | Lookup for POST parameters.+lookupPostParam :: (MonadIO m, RequestReader m)+ => ParamName+ -> m (Maybe ParamValue)+lookupPostParam pn = do+ rr <- getRequest+ (pp, _) <- liftIO $ reqRequestBody rr+ return $ lookup pn pp -- | All cookies with the given name.-cookies :: Request -> ParamName -> [ParamValue]-cookies rr name = map snd . filter (fst `equals` name) . reqCookies $ rr+cookies :: RequestReader m => m (ParamName -> [ParamValue])+cookies = do+ rr <- getRequest+ return $ multiLookup $ reqCookies rr -parseWaiRequest :: W.Request- -> [(B.ByteString, B.ByteString)] -- ^ session- -> IO Request-parseWaiRequest env session = do- let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env- let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env- cookies' = map (cs *** cs) $ parseCookies reqCookie- acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env- langs = map cs $ maybe [] parseHttpAccept acceptLang- 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- return $ Request gets' cookies' session rbthunk env langs''+-- | Lookup for cookie data.+lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupCookie pn = do+ rr <- getRequest+ return $ lookup pn $ reqCookies rr -rbHelper :: W.Request -> IO RequestBodyContents-rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where- fix1 = map (cs *** cs)- fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs b) c)+-- | All session data with the given name.+session :: RequestReader m => m (ParamName -> [ParamValue])+session = do+ rr <- getRequest+ return $ multiLookup $ reqSession rr -#if TEST-testSuite :: Test-testSuite = testGroup "Yesod.Request"- [- ]-#endif+-- | Lookup for session data.+lookupSession :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupSession pn = do+ rr <- getRequest+ return $ lookup pn $ reqSession rr
− Yesod/Resource.hs
@@ -1,531 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}---------------------------------------------------------------- Module : Yesod.Resource--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ Defines the ResourceName class.--------------------------------------------------------------module Yesod.Resource- ( mkResources- , mkResourcesNoCheck-#if TEST- -- * Testing- , testSuite-#endif- ) where--import Data.List.Split (splitOn)-import Yesod.Definitions-import Data.List (nub)-import Data.Char (isDigit)--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Network.Wai (Method (..), methodFromBS, methodToBS)-{- Debugging-import Language.Haskell.TH.Ppr-import System.IO--}--import Data.Typeable-import Control.Exception (Exception)-import Data.Attempt -- for failure stuff-import Data.Object.Text-import Control.Monad ((<=<), unless, zipWithM)-import Data.Object.Yaml-import Yesod.Handler-import Data.Maybe (fromJust)-import Yesod.Response (chooseRep)-import Control.Arrow-import Data.ByteString (ByteString)--#if TEST-import Control.Monad (replicateM)-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit hiding (Test)-import Test.QuickCheck-import Control.Monad (when)-#endif--mkResources :: QuasiQuoter-mkResources = QuasiQuoter (strToExp True) undefined--mkResourcesNoCheck :: QuasiQuoter-mkResourcesNoCheck = QuasiQuoter (strToExp False) undefined---- | Resource Pattern Piece-data RPP =- Static String- | DynStr String- | DynInt String- | Slurp String -- ^ take up the rest of the pieces. must be last- deriving (Eq, Show)---- | Resource Pattern-newtype RP = RP { unRP :: [RPP] }- deriving (Eq, Show)--isSlurp :: RPP -> Bool-isSlurp (Slurp _) = True-isSlurp _ = False--data InvalidResourcePattern =- SlurpNotLast String- | EmptyResourcePatternPiece String- deriving (Show, Typeable)-instance Exception InvalidResourcePattern-readRP :: MonadFailure InvalidResourcePattern m- => ResourcePattern- -> m RP-readRP "" = return $ RP []-readRP "/" = return $ RP []-readRP rps = fmap RP $ helper $ splitOn "/" $ correct rps where- correct = correct1 . correct2 where- correct1 ('/':rest) = rest- correct1 x = x- correct2 x- | null x = x- | last x == '/' = init x- | otherwise = x- helper [] = return []- helper (('$':name):rest) = do- rest' <- helper rest- return $ DynStr name : rest'- helper (('#':name):rest) = do- rest' <- helper rest- return $ DynInt name : rest'- helper (('*':name):rest) = do- rest' <- helper rest- unless (null rest') $ failure $ SlurpNotLast rps- return $ Slurp name : rest'- helper ("":_) = failure $ EmptyResourcePatternPiece rps- helper (name:rest) = do- rest' <- helper rest- return $ Static name : rest'-instance ConvertSuccess RP String where- convertSuccess = concatMap helper . unRP where- helper (Static s) = '/' : s- helper (DynStr s) = '/' : '$' : s- helper (Slurp s) = '/' : '*' : s- helper (DynInt s) = '/' : '#' : s--type ResourcePattern = String---- | Determing whether the given resource fits the resource pattern.-doesPatternMatch :: RP -> Resource -> Bool-doesPatternMatch rp r = case doPatternPiecesMatch (unRP rp) r of- Nothing -> False- _ -> True---- | Extra the 'UrlParam's from a resource known to match the given 'RP'. This--- is a partial function.-paramsFromMatchingPattern :: RP -> Resource -> [UrlParam]-paramsFromMatchingPattern rp =- map snd . fromJust . doPatternPiecesMatch (unRP rp)--doPatternPiecesMatch :: MonadFailure NoMatch m- => [RPP]- -> Resource- -> m [(String, UrlParam)]-doPatternPiecesMatch rp r- | not (null rp) && isSlurp (last rp) = do- let rp' = init rp- (r1, r2) = splitAt (length rp') r- smap <- doPatternPiecesMatch rp' r1- let Slurp slurpKey = last rp- return $ (slurpKey, SlurpParam r2) : smap- | length rp /= length r = failure NoMatch- | otherwise = concat `fmap` zipWithM doesPatternPieceMatch rp r--data NoMatch = NoMatch-doesPatternPieceMatch :: MonadFailure NoMatch m- => RPP- -> String- -> m [(String, UrlParam)]-doesPatternPieceMatch (Static x) y = if x == y then return [] else failure NoMatch-doesPatternPieceMatch (DynStr x) y = return [(x, StringParam y)]-doesPatternPieceMatch (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last"-doesPatternPieceMatch (DynInt x) y- | all isDigit y = return [(x, IntParam $ read y)]- | otherwise = failure NoMatch---- | Determine if two resource patterns can lead to an overlap (ie, they can--- both match a single resource).-overlaps :: [RPP] -> [RPP] -> Bool-overlaps [] [] = True-overlaps [] _ = False-overlaps _ [] = False-overlaps (Slurp _:_) _ = True-overlaps _ (Slurp _:_) = True-overlaps (DynStr _:x) (_:y) = overlaps x y-overlaps (_:x) (DynStr _:y) = overlaps x y-overlaps (DynInt _:x) (DynInt _:y) = overlaps x y-overlaps (DynInt _:x) (Static s:y)- | all isDigit s = overlaps x y- | otherwise = False-overlaps (Static s:x) (DynInt _:y)- | all isDigit s = overlaps x y- | otherwise = False-overlaps (Static a:x) (Static b:y) = a == b && overlaps x y--data OverlappingPatterns =- OverlappingPatterns [(ResourcePattern, ResourcePattern)]- deriving (Show, Typeable, Eq)-instance Exception OverlappingPatterns--getAllPairs :: [x] -> [(x, x)]-getAllPairs [] = []-getAllPairs [_] = []-getAllPairs (x:xs) = map ((,) x) xs ++ getAllPairs xs---- | Ensures that we have a consistent set of resource patterns.-checkPatterns :: (MonadFailure OverlappingPatterns m,- MonadFailure InvalidResourcePattern m)- => [ResourcePattern]- -> m [RP]-checkPatterns rpss = do- rps <- mapM (runKleisli $ Kleisli return &&& Kleisli readRP) rpss- let overlaps' = concatMap helper $ getAllPairs rps- unless (null overlaps') $ failure $ OverlappingPatterns overlaps'- return $ map snd rps- where- helper :: ((ResourcePattern, RP), (ResourcePattern, RP))- -> [(ResourcePattern, ResourcePattern)]- helper ((a, RP x), (b, RP y))- | overlaps x y = [(a, b)]- | otherwise = []--data RPNode = RPNode RP MethodMap- deriving (Show, Eq)-data MethodMap = AllMethods String | Methods [(Method, String)]- deriving (Show, Eq)-instance ConvertAttempt TextObject [RPNode] where- convertAttempt = mapM helper <=< fromMapping where- helper :: (Text, TextObject) -> Attempt RPNode- helper (rp, rest) = do- verbMap <- fromTextObject rest- rp' <- readRP $ cs rp- return $ RPNode rp' verbMap-instance ConvertAttempt TextObject MethodMap where- convertAttempt (Scalar s) = return $ AllMethods $ cs s- convertAttempt (Mapping m) = Methods `fmap` mapM helper m where- helper :: (Text, TextObject) -> Attempt (Method, String)- helper (v, Scalar f) = return (methodFromBS $ cs v, cs f)- helper (_, x) = failure $ MethodMapNonScalar x- convertAttempt o = failure $ MethodMapSequence o-data RPNodeException = MethodMapNonScalar TextObject- | MethodMapSequence TextObject- deriving (Show, Typeable)-instance Exception RPNodeException--checkRPNodes :: (MonadFailure OverlappingPatterns m,- MonadFailure RepeatedMethod m,- MonadFailure InvalidResourcePattern m- )- => [RPNode]- -> m [RPNode]-checkRPNodes nodes = do- _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes- mapM_ (\(RPNode _ v) -> checkMethodMap v) nodes- return nodes- where- checkMethodMap (AllMethods _) = return ()- checkMethodMap (Methods vs) =- let vs' = map fst vs- res = nub vs' == vs'- in unless res $ failure $ RepeatedMethod vs--newtype RepeatedMethod = RepeatedMethod [(Method, String)]- deriving (Show, Typeable)-instance Exception RepeatedMethod--rpnodesTHCheck :: [RPNode] -> Q Exp-rpnodesTHCheck nodes = do- nodes' <- runIO $ checkRPNodes nodes- {- For debugging purposes- rpnodesTH nodes' >>= runIO . putStrLn . pprint- runIO $ hFlush stdout- -}- rpnodesTH nodes'--notFoundMethod :: Method -> Handler yesod a-notFoundMethod _verb = notFound--rpnodesTH :: [RPNode] -> Q Exp-rpnodesTH ns = do- b <- mapM helper ns- nfv <- [|notFoundMethod|]- ow <- [|otherwise|]- let b' = b ++ [(NormalG ow, nfv)]- return $ LamE [VarP $ mkName "resource"]- $ CaseE (TupE []) [Match WildP (GuardedB b') []]- where- helper :: RPNode -> Q (Guard, Exp)- helper (RPNode rp vm) = do- rp' <- lift rp- cpb <- [|doesPatternMatch|]- let r' = VarE $ mkName "resource"- let g = cpb `AppE` rp' `AppE` r'- vm' <- liftMethodMap vm r' rp- let vm'' = LamE [VarP $ mkName "verb"] vm'- return (NormalG g, vm'')--data UrlParam = SlurpParam { slurpParam :: [String] }- | StringParam { stringParam :: String }- | IntParam { intParam :: Integer }--getUrlParam :: RP -> Resource -> Int -> UrlParam-getUrlParam rp = (!!) . paramsFromMatchingPattern rp--getUrlParamSlurp :: RP -> Resource -> Int -> [String]-getUrlParamSlurp rp r = slurpParam . getUrlParam rp r--getUrlParamString :: RP -> Resource -> Int -> String-getUrlParamString rp r = stringParam . getUrlParam rp r--getUrlParamInt :: RP -> Resource -> Int -> Integer-getUrlParamInt rp r = intParam . getUrlParam rp r--applyUrlParams :: RP -> Exp -> Exp -> Q Exp-applyUrlParams rp@(RP rpps) r f = do- getFs <- helper 0 rpps- return $ foldl AppE f getFs- where- helper :: Int -> [RPP] -> Q [Exp]- helper _ [] = return []- helper i (Static _:rest) = helper i rest- helper i (DynStr _:rest) = do- rp' <- lift rp- str <- [|getUrlParamString|]- i' <- lift i- rest' <- helper (i + 1) rest- return $ str `AppE` rp' `AppE` r `AppE` i' : rest'- helper i (DynInt _:rest) = do- rp' <- lift rp- int <- [|getUrlParamInt|]- i' <- lift i- rest' <- helper (i + 1) rest- return $ int `AppE` rp' `AppE` r `AppE` i' : rest'- helper i (Slurp _:rest) = do- rp' <- lift rp- slurp <- [|getUrlParamSlurp|]- i' <- lift i- rest' <- helper (i + 1) rest- return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest'--instance Lift RP where- lift (RP rpps) = do- rpps' <- lift rpps- rp <- [|RP|]- return $ rp `AppE` rpps'-instance Lift RPP where- lift (Static s) = do- st <- [|Static|]- return $ st `AppE` (LitE $ StringL s)- lift (DynStr s) = do- d <- [|DynStr|]- return $ d `AppE` (LitE $ StringL s)- lift (DynInt s) = do- d <- [|DynInt|]- return $ d `AppE` (LitE $ StringL s)- lift (Slurp s) = do- sl <- [|Slurp|]- return $ sl `AppE` (LitE $ StringL s)-liftMethodMap :: MethodMap -> Exp -> RP -> Q Exp-liftMethodMap (AllMethods s) r rp = do- -- handler function- let f = VarE $ mkName s- -- applied to the verb- let f' = f `AppE` VarE (mkName "verb")- -- apply all the url params- f'' <- applyUrlParams rp r f'- -- and apply chooseRep- cr <- [|fmap chooseRep|]- let f''' = cr `AppE` f''- return f'''-liftMethodMap (Methods vs) r rp = do- cr <- [|fmap chooseRep|]- vs' <- mapM (helper cr) vs- return $ CaseE (TupE []) [Match WildP (GuardedB $ vs' ++ [whenNotFound]) []]- --return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound]- where- helper :: Exp -> (Method, String) -> Q (Guard, Exp)- helper cr (v, fName) = do- method' <- liftMethod v- equals <- [|(==)|]- let eq = equals- `AppE` method'- `AppE` VarE ((mkName "verb"))- let g = NormalG $ eq- let f = VarE $ mkName fName- f' <- applyUrlParams rp r f- let f'' = cr `AppE` f'- return (g, f'')- whenNotFound :: (Guard, Exp)- whenNotFound =- (NormalG $ ConE $ mkName "True",- VarE $ mkName "notFound")--liftMethod :: Method -> Q Exp-liftMethod m = do- cs' <- [|cs :: String -> ByteString|]- methodFromBS' <- [|methodFromBS|]- let s = LitE $ StringL $ cs $ methodToBS m- return $ methodFromBS' `AppE` AppE cs' s--strToExp :: Bool -> String -> Q Exp-strToExp toCheck s = do- rpnodes <- runIO $ decode (cs s) >>= \to -> convertAttemptWrap (to :: TextObject)- (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes--#if TEST----- Testing-testSuite :: Test-testSuite = testGroup "Yesod.Resource"- [ testCase "non-overlap" caseOverlap1- , testCase "overlap" caseOverlap2- , testCase "overlap-slurp" caseOverlap3- , testCase "checkPatterns" caseCheckPatterns- , testProperty "show pattern" prop_showPattern- , testCase "integers" caseIntegers- , testCase "read patterns from YAML" caseFromYaml- , testCase "checkRPNodes" caseCheckRPNodes- , testCase "readRP" caseReadRP- ]--instance Arbitrary RP where- arbitrary = do- size <- elements [1..10]- rpps <- replicateM size arbitrary- let rpps' = filter (not . isSlurp) rpps- extra <- arbitrary- return $ RP $ rpps' ++ [extra]--caseOverlap' :: String -> String -> Bool -> Assertion-caseOverlap' x y b = do- x' <- readRP x- y' <- readRP y- assert $ overlaps (unRP x') (unRP y') == b--caseOverlap1 :: Assertion-caseOverlap1 = caseOverlap' "/foo/$bar/" "/foo/baz/$bin" False-caseOverlap2 :: Assertion-caseOverlap2 = caseOverlap' "/foo/bar" "/foo/$baz" True-caseOverlap3 :: Assertion-caseOverlap3 = caseOverlap' "/foo/bar/baz/$bin" "*slurp" True--caseCheckPatterns :: Assertion-caseCheckPatterns = do- let res = checkPatterns [p1, p2, p3, p4, p5]- attempt helper (fail "Did not fail") res- where- p1 = cs "/foo/bar/baz"- p2 = cs "/foo/$bar/baz"- p3 = cs "/bin"- p4 = cs "/bin/boo"- p5 = cs "/bin/*slurp"- expected = OverlappingPatterns- [ (p1, p2)- , (p4, p5)- ]- helper e = case cast e of- Nothing -> fail "Wrong exception"- Just op -> do- expected @=? op--prop_showPattern :: RP -> Bool-prop_showPattern p = readRP (cs p) == Just p--caseIntegers :: Assertion-caseIntegers = do- let p1 = "/foo/#bar/"- p2 = "/foo/#baz/"- p3 = "/foo/$bin/"- p4 = "/foo/4/"- p5 = "/foo/bar/"- p6 = "/foo/*slurp/"- checkOverlap :: String -> String -> Bool -> IO ()- checkOverlap a b c = do- rpa <- readRP a- rpb <- readRP b- let res1 = overlaps (unRP rpa) (unRP $ rpb)- let res2 = overlaps (unRP rpb) (unRP $ rpa)- when (res1 /= c || res2 /= c) $ assertString $ a- ++ (if c then " does not overlap with " else " overlaps with ")- ++ b- checkOverlap p1 p2 True- checkOverlap p1 p3 True- checkOverlap p1 p4 True- checkOverlap p1 p5 False- checkOverlap p1 p6 True--instance Arbitrary RPP where- arbitrary = do- constr <- elements [Static, DynStr, Slurp, DynInt]- size <- elements [1..10]- s <- replicateM size $ elements ['a'..'z']- return $ constr s--caseFromYaml :: Assertion-caseFromYaml = do- rp1 <- readRP "static/*filepath"- rp2 <- readRP "page"- rp3 <- readRP "page/$page"- rp4 <- readRP "user/#id"- let expected =- [ RPNode rp1 $ AllMethods "getStatic"- , RPNode rp2 $ Methods [(GET, "pageIndex"), (PUT, "pageAdd")]- , RPNode rp3 $ Methods [ (GET, "pageDetail")- , (DELETE, "pageDelete")- , (POST, "pageUpdate")- ]- , RPNode rp4 $ Methods [(GET, "userInfo")]- ]- contents' <- decodeFile "Test/resource-patterns.yaml"- contents <- convertAttemptWrap (contents' :: TextObject)- expected @=? contents--caseCheckRPNodes :: Assertion-caseCheckRPNodes = do- good' <- decodeFile "Test/resource-patterns.yaml"- good <- convertAttemptWrap (good' :: TextObject)- Just good @=? checkRPNodes good- rp1 <- readRP "foo/bar"- rp2 <- readRP "$foo/bar"- let bad1 = [ RPNode rp1 $ AllMethods "foo"- , RPNode rp2 $ AllMethods "bar"- ]- Nothing @=? checkRPNodes bad1- rp' <- readRP ""- let bad2 = [RPNode rp' $ Methods [(GET, "foo"), (GET, "bar")]]- Nothing @=? checkRPNodes bad2--caseReadRP :: Assertion-caseReadRP = do- Just (RP [Static "foo", DynStr "bar", DynInt "baz", Slurp "bin"]) @=?- readRP "foo/$bar/#baz/*bin/"- Just (RP [Static "foo", DynStr "bar", DynInt "baz", Slurp "bin"]) @=?- readRP "foo/$bar/#baz/*bin"- Nothing @=? readRP "/foo//"- Just (RP []) @=? readRP "/"- Nothing @=? readRP "/*slurp/anything"-#endif
− Yesod/Response.hs
@@ -1,251 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}---------------------------------------------------------------- Module : Yesod.Response--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ Generating responses.--------------------------------------------------------------module Yesod.Response- ( -- * Representations- Content (..)- , ChooseRep- , HasReps (..)- , defChooseRep- , ioTextToContent- , hoToJsonContent- -- ** Convenience wrappers- , staticRep- -- ** Specific content types- , RepHtml (..)- , RepJson (..)- , RepHtmlJson (..)- -- * Response type- , Response (..)- -- * Special responses- , RedirectType (..)- , getRedirectStatus- , SpecialResponse (..)- -- * Error responses- , ErrorResponse (..)- , getStatus- -- * Header- , Header (..)- , headerToPair- -- * Converting to WAI values- , responseToWaiResponse-#if TEST- -- * Tests- , testSuite- , runContent-#endif- ) where--import Data.Time.Clock-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.Object.Json--import Web.Encodings (formatW3)-import qualified Network.Wai as W-import qualified Network.Wai.Enumerator as WE--#if TEST-import Yesod.Request hiding (testSuite)-import Data.Object.Html hiding (testSuite)-import Web.Mime hiding (testSuite)-#else-import Yesod.Request-import Data.Object.Html-import Web.Mime-#endif--#if TEST-import Test.Framework (testGroup, Test)-#endif--data Content = ContentFile FilePath- | ContentEnum (forall a.- (a -> B.ByteString -> IO (Either a a))- -> a- -> IO (Either a a))--instance ConvertSuccess B.ByteString Content where- convertSuccess bs = ContentEnum $ \f a -> f a bs-instance ConvertSuccess L.ByteString Content where- convertSuccess = swapEnum . WE.fromLBS-instance ConvertSuccess T.Text Content where- convertSuccess t = cs (cs t :: B.ByteString)-instance ConvertSuccess Text Content where- convertSuccess lt = cs (cs lt :: L.ByteString)-instance ConvertSuccess String Content where- convertSuccess s = cs (cs s :: Text)-instance ConvertSuccess HtmlDoc Content where- convertSuccess = cs . unHtmlDoc-instance ConvertSuccess XmlDoc Content where- convertSuccess = cs . unXmlDoc--type ChooseRep = [ContentType] -> IO (ContentType, Content)---- | It would be nice to simplify 'Content' to the point where this is--- unnecesary.-ioTextToContent :: IO Text -> Content-ioTextToContent = swapEnum . WE.fromLBS' . fmap cs--swapEnum :: W.Enumerator -> Content-swapEnum (W.Enumerator e) = ContentEnum e--hoToJsonContent :: HtmlObject -> Content-hoToJsonContent = cs . unJsonDoc . cs---- | Any type which can be converted to representations.-class HasReps a where- chooseRep :: a -> ChooseRep---- | A helper method for generating 'HasReps' instances.-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"- (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 $ cs "")]--instance HasReps [(ContentType, Content)] where- chooseRep a cts = return $- case filter (\(ct, _) -> simpleContentType ct `elem`- map simpleContentType cts) a of- ((ct, c):_) -> (ct, c)- _ -> case a of- (x:_) -> x- _ -> error "chooseRep [(ContentType, Content)] of empty"--instance HasReps (Html, HtmlObject) where- chooseRep = defChooseRep- [ (TypeHtml, return . cs . unHtmlDoc . cs)- , (TypeJson, return . cs . unJsonDoc . cs)- ]---- | Data with a single representation.-staticRep :: ConvertSuccess x Content- => ContentType- -> x- -> [(ContentType, Content)]-staticRep ct x = [(ct, cs x)]--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)- ]--data Response = Response W.Status [Header] ContentType Content---- | Different types of redirects.-data RedirectType = RedirectPermanent- | RedirectTemporary- | RedirectSeeOther- deriving (Show, Eq)--getRedirectStatus :: RedirectType -> W.Status-getRedirectStatus RedirectPermanent = W.Status301-getRedirectStatus RedirectTemporary = W.Status302-getRedirectStatus RedirectSeeOther = W.Status303---- | Special types of responses which should short-circuit normal response--- processing.-data SpecialResponse =- Redirect RedirectType String- | SendFile ContentType FilePath- deriving (Show, Eq)---- | 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 [(ParamName, ParamError)]- | PermissionDenied- deriving (Show, Eq)--getStatus :: ErrorResponse -> W.Status-getStatus NotFound = W.Status404-getStatus (InternalError _) = W.Status500-getStatus (InvalidArgs _) = W.Status400-getStatus PermissionDenied = W.Status403------- header stuff--- | Headers to be added to a 'Result'.-data Header =- AddCookie Int String String- | DeleteCookie String- | Header String String- deriving (Eq, Show)---- | Convert Header to a key/value pair.-headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString)-headerToPair (AddCookie minutes key value) = do- now <- getCurrentTime- let expires = addUTCTime (fromIntegral $ minutes * 60) now- return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="- ++ formatW3 expires)-headerToPair (DeleteCookie key) = return- (W.SetCookie, cs $- key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")-headerToPair (Header key value) =- return (W.responseHeaderFromBS $ cs key, cs value)--responseToWaiResponse :: Response -> IO W.Response-responseToWaiResponse (Response sc hs ct c) = do- hs' <- mapM headerToPair hs- let hs'' = (W.ContentType, cs ct) : hs'- return $ W.Response sc hs'' $ case c of- ContentFile fp -> Left fp- ContentEnum e -> Right $ W.Enumerator e--#if TEST-runContent :: Content -> IO L.ByteString-runContent (ContentFile fp) = L.readFile fp-runContent (ContentEnum c) = WE.toLBS $ W.Enumerator c------- Testing-testSuite :: Test-testSuite = testGroup "Yesod.Response"- [- ]-#endif
− Yesod/Template.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Template- ( YesodTemplate (..)- , NoSuchTemplate- , Template- , TemplateGroup- , loadTemplateGroup- , defaultApplyLayout- -- * HTML templates- , HtmlTemplate (..)- , templateHtml- , templateHtmlJson- , setHtmlAttrib- ) where--import Data.Object.Html-import Data.Typeable (Typeable)-import Control.Exception (Exception)-import Data.Object.Text (Text)-import Text.StringTemplate-import Yesod.Response-import Yesod.Yesod-import Yesod.Handler-import Control.Monad (join)-import Yesod.Request (Request, getRequest)--type Template = StringTemplate Text-type TemplateGroup = STGroup Text--class Yesod y => YesodTemplate y where- getTemplateGroup :: y -> TemplateGroup- defaultTemplateAttribs :: y -> Request -> HtmlTemplate- -> IO HtmlTemplate- defaultTemplateAttribs _ _ = return--getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup-getTemplateGroup' = getTemplateGroup `fmap` getYesod--newtype NoSuchTemplate = NoSuchTemplate String- deriving (Show, Typeable)-instance Exception NoSuchTemplate--loadTemplateGroup :: FilePath -> IO TemplateGroup-loadTemplateGroup = directoryGroupRecursiveLazy--defaultApplyLayout :: YesodTemplate y- => y- -> Request- -> String -- ^ title- -> Html -- ^ body- -> Content-defaultApplyLayout y req t b =- case getStringTemplate "layout" $ getTemplateGroup y of- Nothing -> cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)- Just temp ->- ioTextToContent- $ fmap (render . unHtmlTemplate)- $ defaultTemplateAttribs y req- $ setHtmlAttrib "title" t- $ setHtmlAttrib "content" b- $ HtmlTemplate temp--type TemplateName = String-newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template }---- | Return a result using a template generating HTML alone.-templateHtml :: YesodTemplate y- => TemplateName- -> (HtmlTemplate -> IO HtmlTemplate)- -> Handler y RepHtml-templateHtml tn f = do- tg <- getTemplateGroup'- y <- getYesod- t <- case getStringTemplate tn tg of- Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn- Just x -> return x- rr <- getRequest- return $ RepHtml $ ioTextToContent- $ fmap (render . unHtmlTemplate)- $ join- $ fmap f- $ defaultTemplateAttribs y rr- $ HtmlTemplate t--setHtmlAttrib :: ConvertSuccess x HtmlObject- => String -> x -> HtmlTemplate -> HtmlTemplate-setHtmlAttrib k v (HtmlTemplate t) =- HtmlTemplate $ setAttribute k (toHtmlObject v) t---- | Return a result using a template and 'HtmlObject' generating either HTML--- or JSON output.-templateHtmlJson :: YesodTemplate y- => TemplateName- -> HtmlObject- -> (HtmlObject -> HtmlTemplate -> IO HtmlTemplate)- -> Handler y RepHtmlJson-templateHtmlJson tn ho f = do- tg <- getTemplateGroup'- y <- getYesod- rr <- getRequest- t <- case getStringTemplate tn tg of- Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn- Just x -> return x- return $ RepHtmlJson- ( ioTextToContent- $ fmap (render . unHtmlTemplate)- $ join- $ fmap (f ho)- $ defaultTemplateAttribs y rr- $ HtmlTemplate t- )- (hoToJsonContent ho)
Yesod/Yesod.hs view
@@ -1,44 +1,51 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-} -- | The basic typeclass for a Yesod application. module Yesod.Yesod- ( Yesod (..)- , YesodApproot (..)- , applyLayout'+ ( -- * Type classes+ Yesod (..)+ , YesodSite (..)+ -- * Convenience functions+ , applyLayout , applyLayoutJson- , getApproot- , toWaiApp- , basicHandler+ -- * Defaults+ , defaultErrorHandler ) where -import Data.Object.Html-import Data.Object.Json (unJsonDoc)-import Yesod.Response+import Yesod.Content import Yesod.Request-import Yesod.Definitions+import Yesod.Hamlet import Yesod.Handler-import qualified Data.ByteString as B--import Data.Maybe (fromMaybe)-import Web.Mime-import Web.Encodings (parseHttpAccept)-+import Data.Convertible.Text import qualified Network.Wai as W-import Network.Wai.Middleware.CleanPath-import Network.Wai.Middleware.ClientSession-import Network.Wai.Middleware.Jsonp-import Network.Wai.Middleware.MethodOverride-import Network.Wai.Middleware.Gzip+import Yesod.Json+import Yesod.Internal+import Web.ClientSession (getKey, defaultKeyFile, Key) -import qualified Network.Wai.Handler.SimpleServer as SS-import qualified Network.Wai.Handler.CGI as CGI-import System.Environment (getEnvironment)+import Web.Routes.Quasi (QuasiSite (..), Routes) +-- | This class is automatically instantiated when you use the template haskell+-- mkYesod function. You should never need to deal with it directly.+class YesodSite y where+ getSite :: QuasiSite YesodApp y y++-- | Define settings for a Yesod applications. The only required setting is+-- 'approot'; other than that, there are intelligent defaults. class Yesod a where- -- | Please use the Quasi-Quoter, you\'ll be happier. For more information,- -- see the examples/fact.lhs sample.- resources :: Resource -> W.Method -> Handler a ChooseRep+ -- | 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 Word256+ encryptKey :: a -> IO Key encryptKey _ = getKey defaultKeyFile -- | Number of minutes before a client session times out. Defaults to@@ -47,114 +54,100 @@ clientSessionDuration = const 120 -- | Output error response pages.- errorHandler :: ErrorResponse -> Handler a ChooseRep- errorHandler = defaultErrorHandler+ errorHandler :: Yesod y+ => a+ -> ErrorResponse+ -> Handler y ChooseRep+ errorHandler _ = defaultErrorHandler - -- | Applies some form of layout to <title> and <body> contents of a page.- applyLayout :: a- -> Request- -> String -- ^ title- -> Html -- ^ body- -> Content- applyLayout _ _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)+ -- | Applies some form of layout to the contents of a page.+ defaultLayout :: PageContent (Routes a) -> GHandler sub a Content+ defaultLayout p = hamletToContent [$hamlet|+!!!+%html+ %head+ %title $pageTitle.p$+ ^pageHead.p^+ %body+ ^pageBody.p^+|] -- | Gets called at the beginning of each request. Useful for logging. onRequest :: a -> Request -> IO () onRequest _ _ = return () -class Yesod a => YesodApproot a where- -- | An absolute URL to the root of the application.- approot :: a -> Approot+ -- | 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 -> Routes a -> Maybe String+ urlRenderOverride _ _ = Nothing --- | A convenience wrapper around 'applyLayout'.-applyLayout' :: Yesod y- => String- -> Html- -> Handler y ChooseRep-applyLayout' t b = do- y <- getYesod- rr <- getRequest- return $ chooseRep- [ (TypeHtml, applyLayout y rr t b)- ]+-- | Apply the default layout ('defaultLayout') to the given title and body.+applyLayout :: Yesod master+ => String -- ^ title+ -> Hamlet (Routes master) IO () -- ^ head+ -> Hamlet (Routes master) IO () -- ^ body+ -> GHandler sub master RepHtml+applyLayout t h b =+ RepHtml `fmap` defaultLayout PageContent+ { pageTitle = cs t+ , pageHead = h+ , pageBody = b+ } --- | A convenience wrapper around 'applyLayout' which provides a JSON--- representation of the body.-applyLayoutJson :: Yesod y- => String- -> HtmlObject- -> Handler y ChooseRep-applyLayoutJson t b = do- y <- getYesod- rr <- getRequest- return $ chooseRep- [ (TypeHtml, applyLayout y rr t $ cs b)- , (TypeJson, cs $ unJsonDoc $ cs b)- ]+-- | Provide both an HTML and JSON representation for a piece of data, using+-- the default layout for the HTML output ('defaultLayout').+applyLayoutJson :: Yesod master+ => String -- ^ title+ -> Hamlet (Routes master) IO () -- ^ head+ -> Hamlet (Routes master) IO () -- ^ body+ -> Json (Routes master) ()+ -> GHandler sub master RepHtmlJson+applyLayoutJson t h html json = do+ html' <- defaultLayout PageContent+ { pageTitle = cs t+ , pageHead = h+ , pageBody = html+ }+ json' <- jsonToContent json+ return $ RepHtmlJson html' json' -getApproot :: YesodApproot y => Handler y Approot-getApproot = approot `fmap` getYesod+applyLayout' :: Yesod master+ => String -- ^ title+ -> Hamlet (Routes master) IO () -- ^ body+ -> GHandler sub master ChooseRep+applyLayout' s = fmap chooseRep . applyLayout s (return ()) +-- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> Handler y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest- applyLayout' "Not Found" $ cs $ toHtmlObject- [ ("Not found", cs $ W.pathInfo r :: String)- ]+ applyLayout' "Not Found" $ [$hamlet|+%h1 Not Found+%p $Unencoded.cs.pathInfo.r$+|]+ where+ pathInfo = W.pathInfo defaultErrorHandler PermissionDenied =- applyLayout' "Permission Denied" $ cs "Permission denied"+ applyLayout' "Permission Denied" $ [$hamlet|+%h1 Permission denied|] defaultErrorHandler (InvalidArgs ia) =- applyLayout' "Invalid Arguments" $ cs $ toHtmlObject- [ ("errorMsg", toHtmlObject "Invalid arguments")- , ("messages", toHtmlObject ia)- ]+ applyLayout' "Invalid Arguments" $ [$hamlet|+%h1 Invalid Arguments+%dl+ $forall ia pair+ %dt $cs.fst.pair$+ %dd $cs.snd.pair$+|] defaultErrorHandler (InternalError e) =- applyLayout' "Internal Server Error" $ cs $ toHtmlObject- [ ("Internal server error", e)- ]--toWaiApp :: Yesod y => y -> IO W.Application-toWaiApp a = do- key <- encryptKey a- let mins = clientSessionDuration a- return $ gzip- $ jsonp- $ methodOverride- $ cleanPath- $ \thePath -> clientsession encryptedCookies key mins- $ toWaiApp' a thePath--toWaiApp' :: Yesod y- => y- -> [B.ByteString]- -> [(B.ByteString, B.ByteString)]- -> W.Request- -> IO W.Response-toWaiApp' y resource session env = do- let types = httpAccept env- handler = resources (map cs resource) $ W.requestMethod env- rr <- parseWaiRequest env session- onRequest y rr- res <- runHandler handler errorHandler rr y types- responseToWaiResponse res--httpAccept :: W.Request -> [ContentType]-httpAccept = map contentTypeFromBS- . parseHttpAccept- . fromMaybe B.empty- . lookup W.Accept- . W.requestHeaders---- | Runs an application with CGI if CGI variables are present (namely--- PATH_INFO); otherwise uses SimpleServer.-basicHandler :: Int -- ^ port number- -> W.Application -> IO ()-basicHandler port app = do- vars <- getEnvironment- case lookup "PATH_INFO" vars of- Nothing -> do- putStrLn $ "http://localhost:" ++ show port ++ "/"- SS.run port app- Just _ -> CGI.run app+ applyLayout' "Internal Server Error" $ [$hamlet|+%h1 Internal Server Error+%p $cs.e$+|]+defaultErrorHandler (BadMethod m) =+ applyLayout' "Bad Method" $ [$hamlet|+%h1 Method Not Supported+%p Method "$cs.m$" not supported+|]
− examples/fact.lhs
@@ -1,104 +0,0 @@-> {-# LANGUAGE QuasiQuotes #-}--I in general recommend type signatures for everything. However, I wanted-to show in this example how it is possible to get away without the-signatures.--> {-# OPTIONS_GHC -fno-warn-missing-signatures #-}--There are only two imports: Yesod includes all of the code we need for creating-a web application, while Network.Wai.Handler.SimpleServer allows us to test our-application easily. A Yesod app can in general run on any WAI handler, so this-application is easily convertible to CGI, FastCGI, or even run on the Happstack-server.--> import Yesod-> import Network.Wai.Handler.SimpleServer--The easiest way to start writing a Yesod app is to follow the Yesod typeclass.-You define some data type which will contain all the specific settings and data-you want in your application. This might include database connections,-templates, etc. It's entirely up to you.--For our simple demonstration, we need no extra data, so we simply define Fact-as:--> data Fact = Fact--Now we need to declare an instance of Yesod for Fact. The most important-function to declare is handlers, which defines which functions deal with which-resources (aka URLs).--You can declare the function however you want, but Yesod.Resource declares a-convenient "resources" quasi-quoter which takes YAML content and generates the-function for you. There is a lot of cool stuff to do with representations going-on here, but this is not the appropriate place to discuss it.---> instance Yesod Fact where--The structure is very simply: top level key is a "resource pattern". A resource pattern is simply a bunch of slash-separated strings, called "resource pattern pieces". There are three special ways to start a piece:--* $: will take any string--* \#: will take any integer--* \*: will "slurp" up all the remaining pieces. Useful for something like- /static/*filepath--Otherwise, the piece is treated as a literal string which must be matched.---Now we have a mapping of verbs to handler functions. We could instead simply-specify a single function which handles all verbs. (Note: a verb is just a-request method.)--\begin{code}- resources = [$mkResources|-/:- GET: index-/#num:- GET: fact-/fact:- GET: factRedirect-|]-\end{code}--This does what it looks like: serves a static HTML file.--> index = sendFile TypeHtml "examples/fact.html" >> return ()--HtmlObject is a funny beast. Basically, it allows multiple representations of-data, all with HTML entities escaped properly. These representations include:--* Simple HTML document (only recommended for testing).-* JSON (great for Ajax)-* Input to a HStringTemplate (great for no-Javascript fallback).--For simplicity here, we don't include a template, though it would be trivial to-do so (see the hellotemplate example).--> fact i = applyLayoutJson "Factorial result" $ cs-> [ ("input", show i)-> , ("result", show $ product [1..fromIntegral i :: Integer])-> ]--I've decided to have a redirect instead of serving the some data in two-locations. It fits in more properly with the RESTful principal of one name for-one piece of data.--> factRedirect :: Handler y ()-> factRedirect = do-> res <- runFormPost $ catchFormError -> $ checkInteger-> $ required-> $ input "num"-> let i = either (const "1") show res-> redirect RedirectPermanent $ "../" ++ i ++ "/"--You could replace this main to use any WAI handler you want. For production,-you could use CGI, FastCGI or a more powerful server. Just check out Hackage-for options (any package starting hack-handler- should suffice).--> main :: IO ()-> main = putStrLn "Running..." >> toWaiApp Fact >>= run 3000
− examples/hellotemplate.lhs
@@ -1,33 +0,0 @@-\begin{code}-{-# LANGUAGE QuasiQuotes #-}--import Yesod-import Network.Wai.Handler.SimpleServer--data HelloWorld = HelloWorld TemplateGroup-instance YesodTemplate HelloWorld where- getTemplateGroup (HelloWorld tg) = tg- defaultTemplateAttribs _ _ = return- . setHtmlAttrib "default" "<DEFAULT>"-instance Yesod HelloWorld where- resources = [$mkResources|-/:- Get: helloWorld-/groups:- Get: helloGroup-|]--helloWorld :: Handler HelloWorld RepHtml-helloWorld = templateHtml "template" $ return- . setHtmlAttrib "title" "Hello world!"- . setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!"--helloGroup :: YesodTemplate y => Handler y RepHtmlJson-helloGroup = templateHtmlJson "real-template" (cs "bar") $ \ho ->- return . setHtmlAttrib "foo" ho--main :: IO ()-main = do- putStrLn "Running..."- loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000-\end{code}
− examples/helloworld.lhs
@@ -1,19 +0,0 @@-\begin{code}-{-# LANGUAGE QuasiQuotes #-}--import Yesod-import Network.Wai.Handler.SimpleServer--data HelloWorld = HelloWorld-instance Yesod HelloWorld where- resources = [$mkResources|-/:- Get: helloWorld-|]--helloWorld :: Handler HelloWorld ChooseRep-helloWorld = applyLayout' "Hello World" $ cs "Hello world!"--main :: IO ()-main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000-\end{code}
− examples/i18n.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-import Yesod-import Network.Wai.Handler.SimpleServer--data I18N = I18N--instance Yesod I18N where- resources = [$mkResources|-/:- Get: homepage-/set/$lang:- Get: setLang-|]--homepage :: Handler y [(ContentType, Content)]-homepage = do- ls <- languages- let hello = chooseHello ls- return [(TypePlain, cs hello :: Content)]--chooseHello :: [Language] -> String-chooseHello [] = "Hello"-chooseHello ("he":_) = "שלום"-chooseHello ("es":_) = "Hola"-chooseHello (_:rest) = chooseHello rest--setLang :: String -> Handler y ()-setLang lang = do- addCookie 1 langKey lang- redirect RedirectTemporary "/"--main :: IO ()-main = putStrLn "Running..." >> toWaiApp I18N >>= run 3000
− examples/pretty-yaml.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-import Yesod-import Data.Object.Yaml-import Network.Wai.Handler.SimpleServer-import Web.Encodings-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L--data PY = PY TemplateGroup-instance YesodTemplate PY where- getTemplateGroup (PY tg) = tg- defaultTemplateAttribs _ _ = return-instance Yesod PY where- resources = [$mkResources|-/:- GET: homepageH- POST: showYamlH-|]--homepageH :: Handler PY RepHtml-homepageH = templateHtml "pretty-yaml" return--showYamlH :: Handler PY RepHtmlJson-showYamlH = do- rr <- getRequest- (_, files) <- liftIO $ reqRequestBody rr- fi <- case lookup "yaml" files of- Nothing -> invalidArgs [("yaml", "Missing input")]- Just x -> return x- to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi- let ho' = fmap Text to- templateHtmlJson "pretty-yaml" ho' $ \ho ->- return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)--main :: IO ()-main = do- putStrLn "Running..."- loadTemplateGroup "examples" >>= toWaiApp . PY >>= run 3000
− examples/tweedle.lhs
@@ -1,407 +0,0 @@-#!/usr/bin/env runhaskell-> {-# LANGUAGE QuasiQuotes #-}--While coming up on the first release of Yesod, I realized I needed a nice, comprehensive tutorial. I didn't want to do the typical blog example, since it's so trite. I considered doing a Reddit or Twitter clone (the former became a bit of a meme a few weeks ago), but then I needed to set up a bug tracker for some commercial projects I was working on, and I decided that it would be a great example program.--Before getting started, a quick word of warning: Yesod at this point really provides nothing in terms of data storage (aka, the model). There is wonderful integration with the data-object package, and the data-object-yaml package provides good serialization, but this is all very inefficient in practice. For simplicity, I've gone ahead and used this as the storage model; this should not be done for production code.--There's a lot of boilerplate code at the beginning that just has to do with object storage; if you'd like to skip it, just start reading from the main function.--Anyway, here's the import list.--> import Yesod-> import Yesod.Helpers.Auth-> import Data.Object.Yaml-> import Data.Object.String-> import Control.Concurrent-> import qualified Safe.Failure as SF-> import Data.Time-> import Data.Attempt (Attempt, fromAttempt)-> import Control.Arrow (second)-> import qualified Network.Wai.Handler.SimpleServer-> import Data.Monoid-> import Data.Text (pack)-> import Control.Applicative ((<$>), (<*>))-> import Data.Maybe (fromMaybe)--One of the goals of Yesod is to make it work with the compiler to help you program. Instead of configuration files, it uses typeclasses to both change default behavior and enable extra features. An example of the former is error pages, while an example of the latter is authentication.--To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle.--> data Tweedle = Tweedle Settings (MVar Category) TemplateGroup--(For now, just ignore the TemplateGroup, its purpose becomes apparent later.)--This issue database is fully hierarchical: each category can contain subcategories and issues. This might be too much nesting for many uses, but it's what my project demanded.--Also, if I cared about efficiency here, a trie or map would probably be a better data structure. As stated above, it doesn't matter.--> data Category = Category-> { subCats :: [Category]-> , subIssues :: [Issue]-> , categoryId :: Integer-> , catName :: String-> }--> data Issue = Issue-> { issueName :: String-> , issueMessages :: [Message]-> , issueId :: Integer-> }--Further simplifications: authors will just be represented by their OpenID URL.--> data Message = Message-> { messageAuthor :: OpenId-> , messageStatus :: Maybe String-> , messagePriority :: Maybe String-> , messageText :: String-> , messageCreation :: UTCTime-> }--> type OpenId = String--We need to be able to serialize this data to and from YAML files. You can consider all of the following code boilerplate.--> messageToSO :: Message -> StringObject-> messageToSO m = Mapping $ map (second Scalar)-> [ ("author", messageAuthor m)-> , ("status", show $ messageStatus m)-> , ("priority", show $ messagePriority m)-> , ("text", messageText m)-> , ("creation", show $ messageCreation m)-> ]-> messageFromSO :: StringObject -> Attempt Message-> messageFromSO so = do-> m <- fromMapping so-> a <- lookupScalar "author" m-> s <- lookupScalar "status" m >>= SF.read-> p <- lookupScalar "priority" m >>= SF.read-> t <- lookupScalar "text" m-> c <- lookupScalar "creation" m >>= SF.read-> return $ Message a s p t c-> issueToSO :: Issue -> StringObject-> issueToSO i = Mapping-> [ ("name", Scalar $ issueName i)-> , ("messages", Sequence $ map messageToSO $ issueMessages i)-> , ("id", Scalar $ show $ issueId i)-> ]-> issueFromSO :: StringObject -> Attempt Issue-> issueFromSO so = do-> m <- fromMapping so-> n <- lookupScalar "name" m-> i <- lookupScalar "id" m >>= SF.read-> ms <- lookupSequence "messages" m >>= mapM messageFromSO-> return $ Issue n ms i-> categoryToSO :: Category -> StringObject-> categoryToSO c = Mapping-> [ ("cats", Sequence $ map categoryToSO $ subCats c)-> , ("issues", Sequence $ map issueToSO $ subIssues c)-> , ("id", Scalar $ show $ categoryId c)-> , ("name", Scalar $ catName c)-> ]-> categoryFromSO :: StringObject -> Attempt Category-> categoryFromSO so = do-> m <- fromMapping so-> cats <- lookupSequence "cats" m >>= mapM categoryFromSO-> issues <- lookupSequence "issues" m >>= mapM issueFromSO-> i <- lookupScalar "id" m >>= SF.read-> n <- lookupScalar "name" m-> return $ Category cats issues i n--Well, that was a mouthful. You can safely ignore all of that: it has nothing to do with actual web programming.--Next is the Settings datatype. Normally I create a settings file so I can easily make changes between development and production systems without recompiling, but once again we are aiming for simplicity here.--> data Settings = Settings--Many web frameworks make the simplifying assumptions that "/" will be the path to the root of your application. In real life, this doesn't always happen. In Yesod, you must specify explicitly your application root and then create an instance of YesodApproot (see below). Again, the compiler will let you know this: once you use a feature that depends on knowing the approot, you'll get a compiler error if you haven't created the instance.--> { sApproot :: String-> , issueFile :: FilePath--Yesod comes built in with support for HStringTemplate. You'll see later how this ties in with data-object (and in particular HtmlObject) to help avoid XSS attacks.--> , templatesDir :: FilePath-> }--And now we'll hardcode the settings instead of loading from a file. I'll do it in the IO monad anyway, since that would be the normal function signature.--> loadSettings :: IO Settings-> loadSettings = return $ Settings "http://localhost:3000/" "issues.yaml" "examples/tweedle-templates"--And now we need a function to load up our Tweedle data type.--> loadTweedle :: IO Tweedle-> loadTweedle = do-> settings <- loadSettings--Note that this will die unless an issues file is present. We could instead check for the file and create it if missing, but instead, just put the following into issues.yaml:--{cats: [], issues: [], id: 0, name: "Top Category"}--> issuesSO <- decodeFile $ issueFile settings-> issues <- fromAttempt $ categoryFromSO issuesSO-> missues <- newMVar issues-> tg <- loadTemplateGroup $ templatesDir settings-> return $ Tweedle settings missues tg--And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer.--> main :: IO ()-> main = do-> putStrLn "Running at http://localhost:3000/"-> tweedle <- loadTweedle-> app <- toWaiApp tweedle-> Network.Wai.Handler.SimpleServer.run 3000 app--Well, that was a *lot* of boilerplate code that had nothing to do with web programming. Now the real stuff begins. I would recommend trying to run the code up to now an see what happens. The compiler will complain that there is no instance of Yesod for Tweedle. This is what I meant by letting the compiler help us out. So now we've got to create the Yesod instance.--The Yesod typeclass includes many functions, most of which have default implementations. I'm not going to go through all of them here, please see the documentation.--> instance Yesod Tweedle where--The most important function is resources: this is where all of the URL mapping will occur. Yesod adheres to Restful principles very strongly. A "resource" is essentially a URL. Each resource should be unique; for example, do not create /user/5/ as well as /user/by-number/5/. In addition to resources, we also determine which function should handle your request based on the request method. In other words, a POST and a GET are completely different.--One of the middlewares that Yesod installs is called MethodOverride; please see the documentation there for more details, but essentially it allows us to work past a limitation in the form tag of HTML to use PUT and DELETE methods as well.--Instead of using regular expressions to handle the URL mapping, Yesod uses resource patterns. A resource is a set of tokens separated by slashes. Each of those tokens can be one of:--* A static string.-* An integer variable (begins with #), which will match any integer.-* A string varaible (begins with $), which will match any single value.-* A "slurp" variable, which will match all of the remaining tokens. It must be the last token.--Yesod uses quasi quotation to make specifying the resource pattern simple and safe: your entire set of patterns is checked at compile time to see if you have overlapping rules.--> resources = [$mkResources|--Now we need to figure out all of the resources available in our application. We'll need a homepage:--> /:-> GET: homepageH--We will also need to allow authentication. We use the slurp pattern here and accept all request methods. The authHandler method (in the Yesod.Helpers.Auth module) will handle everything itself.--> /auth/*: authHandler--We're going to refer to categories and issues by their unique numerical id. We're also going to make this system append only: there is no way to change the history.--> /category/#id: # notice that "id" is ignored by Yesod-> GET: categoryDetailsH-> PUT: createCategoryH-> /category/#id/issues:-> PUT: createIssueH-> /issue/#id:-> GET: issueDetailsH-> PUT: addMessageH-> |]--So if you make a PUT request to "/category/5", you will be creating a subcategory of category 5. "GET /issue/27/" will display details on issue 27. This is all we need.--If you try to compile the code until this point, the compiler will tell you that you have to define all of the above-mentioned functions. We'll do that in a second; for now, if you'd like to see the rest of the error messages, uncomment this next block of code.--> {--> homepageH = return ()-> categoryDetailsH _ = return ()-> createCategoryH _ = return ()-> createIssueH _ = return ()-> issueDetailsH _ = return ()-> addMessageH _ = return ()-> -}--Now the compiler is telling us that there's no instance of YesodAuth for Tweedle. YesodAuth- as you might imagine- keeps settings on authentication. We're going to go ahead a create an instance now. The default settings work if you set up authHandler for "/auth/*" (which we did) and are using openid (which we are). So all we need to do is:--> instance YesodAuth Tweedle--Running that tells us that we're missing a YesodApproot instance as well. That's easy enough to fix:--> instance YesodApproot Tweedle where-> approot (Tweedle settings _ _) = sApproot settings--Congratulations, you have a working web application! Gratned, it doesn't actually do much yet, but you *can* use it to log in via openid. Just go to http://localhost:3000/auth/openid/.--Now it's time to implement the real code here. We'll start with the homepage. For this program, I just want the homepage to redirect to the main category (which will be category 0). So let's create that redirect:--> homepageH :: Handler Tweedle ()-> homepageH = do-> ar <- getApproot-> redirect RedirectPermanent $ ar ++ "category/0/"--Simple enough. Notice that we used the getApproot function; if we wanted, we could have just assumed the approot was "/", but this is more robust.--Now the category details function. We're just going to have two lists: subcategories and direct subissues. Each one will have a name and numerical ID.--But here's a very nice feature of Yesod: We're going to have multiple representations of this data. The main one people will use is the HTML representation. However, we're also going to provide a JSON representation. This will make it very simple to write clients or to AJAXify this application in the future.--> categoryDetailsH :: Integer -> Handler Tweedle RepHtmlJson--That function signature tells us a lot: the parameter is the category ID, and we'll be returning something that has both an HTML and JSON representation.--> categoryDetailsH catId = do--getYesod returns our Tweedle data type. Remember, we wrapped it in an MVar; since this is a read-only operation, will unwrap the MVar immediately.--> Tweedle _ mvarTopCat _ <- getYesod-> topcat <- liftIO $ readMVar mvarTopCat--Next we need to find the requested category. You'll see the (boilerplate) function below. If the category doesn't exist, we want to return a 404 response page. So:--> (parents, cat) <- maybe notFound return $ findCat catId [] topcat--Now we want to convert the category into an HtmlObject. By doing so, we will get automatic HTML entity encoding; in other words, no XSS attacks.--> let catHelper (Category _ _ cid name) = Mapping-> [ ("name", Scalar $ Text $ pack name)-> , ("id", Scalar $ Text $ pack $ show cid)-> ]-> let statusHelper = fromMaybe "No status set"-> . getLast . mconcat . map (Last . messageStatus)-> let priorityHelper = fromMaybe "No priority set"-> . getLast . mconcat . map (Last . messagePriority)-> let issueHelper (Issue name messages iid) = Mapping-> [ ("name", Scalar $ Text $ pack name)-> , ("id", Scalar $ Text $ pack $ show iid)-> , ("status", Scalar $ Text $ pack $ statusHelper messages)-> , ("priority", Scalar $ Text $ pack $ priorityHelper messages)-> ]-> let ho = Mapping-> [ ("cats", Sequence $ map catHelper $ subCats cat)-> , ("issues", Sequence $ map issueHelper $ subIssues cat)-> ]--And now we'll use a String Template to display the whole thing.--> templateHtmlJson "category-details" ho $ \_ -> return-> . setHtmlAttrib "cat" ho-> . setHtmlAttrib "name" (catName cat)-> . setHtmlAttrib "parents" (Sequence $ map catHelper parents)--> findCat :: Integer -> [Category] -> Category -> Maybe ([Category], Category)-> findCat i parents c@(Category cats _ i' _)-> | i == i' = Just (parents, c)-> | otherwise = getFirst $ mconcat $ map (First . findCat i (parents ++ [c])) cats--Now we get a new missing instance: YesodTemplate. As you can imagine, this is because of calling the templateHtmlJson function. This is easily enough solved (and explains why we needed TemplateGroup as part of Tweedle).--> instance YesodTemplate Tweedle where-> getTemplateGroup (Tweedle _ _ tg) = tg--Now we actually get some output! I'm not going to cover the syntax of string templates here, but you should read the files in the examples/tweedle-templates directory.--Next, we need to implement createCategoryH. There are two parts to this process: parsing the form submission, and then modifying the database. Pay attention to the former, but you can ignore the latter if you wish. Also, this code does not do much for error checking, as that would needlessly complicate matters.--> createCategoryH :: Integer -> Handler Tweedle ()-> createCategoryH parentid = do--Yesod uses a formlets-style interface for parsing submissions. This following line says we want a parameter named catname, which precisely one value (required) and that value must have a non-zero length (notEmpty).--> catname <- runFormPost $ notEmpty $ required $ input "catname"-> newid <- modifyDB $ createCategory parentid catname-> ar <- getApproot-> redirect RedirectPermanent $ ar ++ "category/" ++ show newid ++ "/"--And here's the database modification code we need. Once again, this is not web-specific.--> modifyDB :: (Category -> (Category, x)) -> Handler Tweedle x-> modifyDB f = do-> Tweedle settings mcat _ <- getYesod-> liftIO $ modifyMVar mcat $ \cat -> do-> let (cat', x) = f cat-> encodeFile (issueFile settings) $ categoryToSO cat'-> return (cat', x)--> createCategory :: Integer -> String -> Category -> (Category, Integer)-> createCategory parentid catname topcat =-> let newid = highCatId topcat + 1-> topcat' = addChild parentid (Category [] [] newid catname) topcat-> in (topcat', newid)-> where-> highCatId (Category cats _ i _) = maximum $ i : map highCatId cats-> addChild i' newcat (Category cats issues i name)-> | i' /= i = Category (map (addChild i' newcat) cats) issues i name-> | otherwise = Category (cats ++ [newcat]) issues i name--Next is creating an issue. This is almost identical to creating a category.--> createIssueH :: Integer -> Handler Tweedle ()-> createIssueH catid = do-> issuename <- runFormPost $ notEmpty $ required $ input "issuename"-> newid <- modifyDB $ createIssue catid issuename-> ar <- getApproot-> redirect RedirectPermanent $ ar ++ "issue/" ++ show newid ++ "/"--> createIssue :: Integer -> String -> Category -> (Category, Integer)-> createIssue catid issuename topcat =-> let newid = highIssueId topcat + 1-> topcat' = addIssue catid (Issue issuename [] newid) topcat-> in (topcat', newid)-> where-> highIssueId (Category cats issues _ _) =-> maximum $ 0 : (map issueId issues) ++ map highIssueId cats-> addIssue i' newissue (Category cats issues i name)-> | i' /= i = Category (map (addIssue i' newissue) cats) issues i name-> | otherwise = Category cats (issues ++ [newissue]) i name--Two functions to go. Now we want to show details of issues. This isn't too different from categoryDetailsH above, except for one feature: we need to know if a user is logged in. If they are logged in, we'll show an "add message" box; otherwise, we'll show a login box. Once again, we're getting the JSON representation easily.--> issueDetailsH :: Integer -> Handler Tweedle RepHtmlJson-> issueDetailsH iid = do-> Tweedle _ mvarTopCat _ <- getYesod-> topcat <- liftIO $ readMVar mvarTopCat-> (cat, issue) <- maybe notFound return $ findIssue iid topcat-> let messageHelper m = Mapping $ map (second $ Scalar . Text . pack)-> $ (maybe id (\x -> (:) ("status", x)) $ messageStatus m)-> $ (maybe id (\x -> (:) ("priority", x)) $ messagePriority m)-> [ ("author", messageAuthor m)-> , ("text", messageText m)-> , ("creation", show $ messageCreation m)-> ]-> let ho = Mapping-> [ ("name", Scalar $ Text $ pack $ issueName issue)-> , ("messages", Sequence $ map messageHelper $ issueMessages issue)-> ]--Now we determine is the user is logged in via the maybeIdentifier function. Later on, we'll see how we can force a user to be logged in using authIdentifier.--> ident <- maybeIdentifier--> templateHtmlJson "issue-details" ho $ \_ -> return-> . setHtmlAttrib "issue" ho-> . maybe id (setHtmlAttrib "ident") ident-> . setHtmlAttrib "cat" (Mapping-> [ ("name", Scalar $ Text $ pack $ catName cat)-> , ("id", Scalar $ Text $ pack $ show $ categoryId cat)-> ])--And now the supporting model code. This function returns the requested Issue along with the containing category.--> findIssue :: Integer -> Category -> Maybe (Category, Issue)-> findIssue iid c@(Category cats issues _ _) =-> case filter (\issue -> issueId issue == iid) issues of-> [] -> getFirst $ mconcat $ map (First . findIssue iid) cats-> (issue:_) -> Just (c, issue)--Cool, just one function left! This should probably all make sense by now. Notice, however, the use of authIdentifier: if the user is not logged in, they will be redirected to the login page automatically.--> addMessageH :: Integer -> Handler Tweedle ()-> addMessageH issueid = do-> ident <- authIdentifier-> (status, priority, text) <- runFormPost $-> (,,)-> <$> optional (input "status")-> <*> optional (input "priority")-> <*> required (input "text")-> now <- liftIO getCurrentTime-> let message = Message ident status priority text now-> modifyDB $ addMessage issueid message-> ar <- getApproot-> redirect RedirectPermanent $ ar ++ "issue/" ++ show issueid ++ "/"--> addMessage :: Integer -> Message -> Category -> (Category, ())-> addMessage issueid message (Category cats issues catid catname) =-> (Category (map (fst . addMessage issueid message) cats) (map go issues) catid catname, ())-> where-> go (Issue name messages iid)-> | iid == issueid = Issue name (messages ++ [message]) iid-> | otherwise = Issue name messages iid
runtests.hs view
@@ -1,20 +1,14 @@ import Test.Framework (defaultMain) -import qualified Yesod.Response-import qualified Yesod.Resource-import qualified Yesod.Request-import qualified Data.Object.Html-import qualified Test.Errors-import qualified Test.QuasiResource-import qualified Web.Mime+import qualified Yesod.Content+import qualified Yesod.Json+import qualified Yesod.Dispatch+import qualified Yesod.Helpers.Static main :: IO () main = defaultMain- [ Yesod.Response.testSuite- , Yesod.Resource.testSuite- , Yesod.Request.testSuite- , Data.Object.Html.testSuite- , Test.Errors.testSuite- , Test.QuasiResource.testSuite- , Web.Mime.testSuite+ [ Yesod.Content.testSuite+ , Yesod.Json.testSuite+ , Yesod.Dispatch.testSuite+ , Yesod.Helpers.Static.testSuite ]
yesod.cabal view
@@ -1,87 +1,72 @@ name: yesod-version: 0.0.0.2+version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: A library for creating RESTful web applications.-description: This package stradles the line between framework and simply a controller. It provides minimal support for model and view, mostly focusing on making a controller which adheres strictly to RESTful principles.+synopsis: Creation of type-safe, RESTful web applications.+description:+ Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.+ .+ The Yesod documentation site <http://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.+ .+ As a quick overview, here is a fully-functional Hello World application:+ .+ > {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}+ > import Yesod+ > data HelloWorld = HelloWorld+ > mkYesod "HelloWorld" [$parseRoutes|/ Home GET|]+ > instance Yesod HelloWorld where approot _ = ""+ > getHome = return $ RepPlain $ cs "Hello World!"+ > main = toWaiApp HelloWorld >>= basicHandler 3000 category: Web-stability: unstable+stability: Stable cabal-version: >= 1.6 build-type: Simple-homepage: http://www.yesodweb.com/code.html-extra-source-files: CLI/skel/App.hs,- CLI/skel/static/style.css,- CLI/skel/settings.yaml,- CLI/skel/LICENSE,- CLI/skel/webapp.cabal,- CLI/skel/templates/layout.st,- CLI/skel/templates/homepage.st+homepage: http://docs.yesodweb.com/yesod/ flag buildtests description: Build the executable to run unit tests default: False -flag buildsamples- description: Build the executable sample applications.- default: False--flag nolib- description: Skip building of the library.- default: False- library- if flag(nolib)- Buildable: False- else- Buildable: True build-depends: base >= 4 && < 5,- old-locale >= 1.0.0.1 && < 1.1, time >= 1.1.3 && < 1.2,- wai >= 0.0.0 && < 0.1,- wai-extra >= 0.0.0 && < 0.1,- split >= 0.1.1 && < 0.2,- authenticate >= 0.4.0 && < 0.5,- predicates >= 0.1 && < 0.2,+ wai >= 0.1.0 && < 0.2,+ wai-extra >= 0.1.2 && < 0.2,+ authenticate >= 0.6.2 && < 0.7, bytestring >= 0.9.1.4 && < 0.10,- web-encodings >= 0.2.4 && < 0.3,- data-object >= 0.2.0 && < 0.3,- data-object-yaml >= 0.2.0 && < 0.3, directory >= 1 && < 1.1,- transformers >= 0.1.4.0 && < 0.2,- control-monad-attempt >= 0.0.0 && < 0.1,- syb, text >= 0.5 && < 0.8,- convertible-text >= 0.2.0 && < 0.3,- HStringTemplate >= 0.6.2 && < 0.7,- data-object-json >= 0.0.0 && < 0.1,- attempt >= 0.2.1 && < 0.3,- template-haskell,- failure >= 0.0.0 && < 0.1,- safe-failure >= 0.4.0 && < 0.5+ convertible-text >= 0.3.0 && < 0.4,+ template-haskell >= 2.4 && < 2.5,+ web-routes >= 0.22 && < 0.23,+ web-routes-quasi >= 0.3 && < 0.4,+ hamlet >= 0.2.2 && < 0.3,+ transformers >= 0.1 && < 0.3,+ clientsession >= 0.4.0 && < 0.5,+ MonadCatchIO-transformers >= 0.1 && < 0.3,+ pureMD5 >= 1.1.0.0 && < 1.2,+ random >= 1.0.0.2 && < 1.1,+ control-monad-attempt >= 0.3 && < 0.4,+ cereal >= 0.2 && < 0.3,+ old-locale >= 1.0.0.2 && < 1.1 exposed-modules: Yesod- Yesod.Request- Yesod.Response- Yesod.Definitions+ Yesod.Content+ Yesod.Dispatch Yesod.Form+ Yesod.Hamlet Yesod.Handler- Yesod.Resource+ Yesod.Internal+ Yesod.Json+ Yesod.Request Yesod.Yesod- Yesod.Template- Data.Object.Html- Yesod.Helpers.Auth- Yesod.Helpers.Static Yesod.Helpers.AtomFeed+ Yesod.Helpers.Auth Yesod.Helpers.Sitemap- Web.Mime+ Yesod.Helpers.Static ghc-options: -Wall -executable yesod- ghc-options: -Wall- build-depends: file-embed >= 0.0.3 && < 0.1- main-is: CLI/yesod.hs- executable runtests if flag(buildtests) Buildable: True@@ -95,54 +80,6 @@ Buildable: False ghc-options: -Wall main-is: runtests.hs--executable helloworld- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/helloworld.lhs--executable hellotemplate- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/hellotemplate.lhs--executable fact- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/fact.lhs--executable i18n- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/i18n.hs--executable pretty-yaml- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/pretty-yaml.hs--executable tweedle- if flag(buildsamples)- Buildable: True- else- Buildable: False- ghc-options: -Wall- main-is: examples/tweedle.lhs source-repository head type: git