diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,10 +2,6 @@ > module Main where > import Distribution.Simple -> import System.Cmd (system) > main :: IO () -> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) - -> runTests' :: a -> b -> c -> d -> IO () -> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return () +> main = defaultMain diff --git a/Yesod.hs b/Yesod.hs --- a/Yesod.hs +++ b/Yesod.hs @@ -1,48 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | This module simply re-exports from other modules for your convenience. module Yesod - ( module Yesod.Request + ( -- * Re-exports from yesod-core + module Yesod.Request , module Yesod.Content - , module Yesod.Yesod + , module Yesod.Core , module Yesod.Handler , module Yesod.Dispatch + , module Yesod.Widget , module Yesod.Form - , module Yesod.Hamlet , module Yesod.Json - , module Yesod.Widget + , module Yesod.Persist + -- * Running your application + , warp + , warpDebug + , develServer + -- * Commonly referenced functions/datatypes , Application , lift , liftIO - , MonadInvertIO - , mempty + , MonadPeelIO + -- * Utilities , showIntegral , readIntegral + -- * Hamlet library + -- ** Hamlet + , hamlet + , xhamlet + , Hamlet + , Html + , renderHamlet + , renderHtml + , string + , preEscapedString + , cdata + -- ** Julius + , julius + , Julius + , renderJulius + -- ** Cassius + , cassius + , Cassius + , renderCassius ) where -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) -import Yesod.Dispatch hiding (testSuite) -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (runHandler, testSuite) -#else import Yesod.Content -import Yesod.Json import Yesod.Dispatch -import Yesod.Yesod +import Yesod.Core import Yesod.Handler hiding (runHandler) -#endif +import Text.Hamlet +import Text.Cassius +import Text.Julius import Yesod.Request -import Yesod.Form import Yesod.Widget +import Yesod.Form +import Yesod.Json +import Yesod.Persist import Network.Wai (Application) -import Yesod.Hamlet +import Network.Wai.Middleware.Debug +#if !GHC7 +import Network.Wai.Handler.DevelServer (runQuit) +#endif import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO) -import Data.Monoid (mempty) -import Control.Monad.Invert (MonadInvertIO) +import Control.Monad.IO.Peel (MonadPeelIO) +import Network.Wai.Handler.Warp (run) +import System.IO (stderr, hPutStrLn) + +import qualified Data.Text.Lazy.IO as TIO +import qualified Data.Attoparsec.Text.Lazy as A +import Control.Applicative ((<|>)) +import Data.Maybe (mapMaybe) +import Data.Char (isSpace) + showIntegral :: Integral a => a -> String showIntegral x = show (fromIntegral x :: Integer) @@ -51,3 +84,66 @@ case reads s of (i, _):_ -> Just $ fromInteger i [] -> Nothing + +-- | A convenience method to run an application using the Warp webserver on the +-- specified port. Automatically calls 'toWaiApp'. +warp :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () +warp port a = toWaiApp a >>= run port + +-- | Same as 'warp', but also sends a message to stderr for each request, and +-- an \"application launched\" message as well. Can be useful for development. +warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () +warpDebug port a = do + hPutStrLn stderr $ "Application launched, listening on port " ++ show port + toWaiApp a >>= run port . debug + +-- | Run a development server, where your code changes are automatically +-- reloaded. +develServer :: Int -- ^ port number + -> String -- ^ module name holding the code + -> String -- ^ name of function providing a with-application + -> IO () +#if GHC7 +develServer = error "Unfortunately, the hint package has not yet been ported to GHC 7, and therefore wai-handler-devel has not either. Once this situation is addressed, a new version of Yesod will be released." +#else +develServer port modu func = do + mapM_ putStrLn + [ "Starting your server process. Code changes will be automatically" + , "loaded as you save your files. Type \"quit\" to exit." + , "You can view your app at http://localhost:" ++ show port ++ "/" + , "" + ] + runQuit port modu func determineHamletDeps +#endif + +data TempType = Hamlet | Cassius | Julius | Widget + deriving Show + +-- | Determine which Hamlet files a Haskell file depends upon. +determineHamletDeps :: FilePath -> IO [FilePath] +determineHamletDeps x = do + y <- TIO.readFile x + let z = A.parse (A.many $ (parser <|> (A.anyChar >> return Nothing))) y + case z of + A.Fail{} -> return [] + A.Done _ r -> return $ mapMaybe go r + where + go (Just (Hamlet, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go (Just (Widget, f)) = Just $ "hamlet/" ++ f ++ ".hamlet" + go _ = Nothing + parser = do + typ <- (A.string "$(hamletFile " >> return Hamlet) + <|> (A.string "$(cassiusFile " >> return Cassius) + <|> (A.string "$(juliusFile " >> return Julius) + <|> (A.string "$(widgetFile " >> return Widget) + <|> (A.string "$(Settings.hamletFile " >> return Hamlet) + <|> (A.string "$(Settings.cassiusFile " >> return Cassius) + <|> (A.string "$(Settings.juliusFile " >> return Julius) + <|> (A.string "$(Settings.widgetFile " >> return Widget) + A.skipWhile isSpace + _ <- A.char '"' + y <- A.many1 $ A.satisfy (/= '"') + _ <- A.char '"' + A.skipWhile isSpace + _ <- A.char ')' + return $ Just (typ, y) diff --git a/Yesod/Content.hs b/Yesod/Content.hs deleted file mode 100644 --- a/Yesod/Content.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} - -module Yesod.Content - ( -- * Content - Content - , emptyContent - , ToContent (..) - -- * Mime types - -- ** Data type - , ContentType - , typeHtml - , typePlain - , typeJson - , typeXml - , typeAtom - , typeJpeg - , typePng - , typeGif - , typeJavascript - , typeCss - , typeFlv - , typeOgv - , typeOctet - -- ** File extensions - , typeByExt - , ext - -- * Utilities - , simpleContentType - -- * Representations - , ChooseRep - , HasReps (..) - , defChooseRep - -- ** Specific content types - , RepHtml (..) - , RepJson (..) - , RepHtmlJson (..) - , RepPlain (..) - , RepXml (..) - -- * Utilities - , formatW3 - , formatRFC1123 - , formatCookieExpires -#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 qualified Network.Wai as W - -import Data.Time -import System.Locale - -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy.Encoding - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -type Content = W.ResponseBody - --- | Zero-length enumerator. -emptyContent :: Content -emptyContent = W.ResponseLBS L.empty - --- | Anything which can be converted into 'Content'. Most of the time, you will --- want to use the 'ContentEnum' constructor. An easier approach will be to use --- a pre-defined 'toContent' function, such as converting your data into a lazy --- bytestring and then calling 'toContent' on that. -class ToContent a where - toContent :: a -> Content - -instance ToContent B.ByteString where - toContent = W.ResponseLBS . L.fromChunks . return -instance ToContent L.ByteString where - toContent = W.ResponseLBS -instance ToContent T.Text where - toContent = toContent . Data.Text.Encoding.encodeUtf8 -instance ToContent Text where - toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 -instance ToContent String where - toContent = toContent . T.pack - --- | A function which gives targetted representations of content based on the --- content-types the user accepts. -type ChooseRep = - [ContentType] -- ^ list of content-types user accepts, ordered by preference - -> IO (ContentType, Content) - --- | Any type which can be converted to representations. -class HasReps a where - chooseRep :: a -> ChooseRep - --- | A helper method for generating 'HasReps' instances. --- --- This function should be given a list of pairs of content type and conversion --- functions. If none of the content types match, the first pair is used. -defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep -defChooseRep reps a ts = do - let (ct, c) = - case mapMaybe helper ts of - (x:_) -> x - [] -> case reps of - [] -> error "Empty reps to defChooseRep" - (x:_) -> x - c' <- c a - return (ct, c') - where - helper ct = do - c <- lookup ct reps - return (ct, c) - -instance HasReps ChooseRep where - chooseRep = id - -instance HasReps () where - chooseRep = defChooseRep [(typePlain, const $ return $ toContent "")] - -instance HasReps (ContentType, Content) where - chooseRep = const . return - -instance HasReps [(ContentType, Content)] where - chooseRep a cts = return $ - case filter (\(ct, _) -> go ct `elem` map go cts) a of - ((ct, c):_) -> (ct, c) - _ -> case a of - (x:_) -> x - _ -> error "chooseRep [(ContentType, Content)] of empty" - where - go = simpleContentType - -newtype RepHtml = RepHtml Content -instance HasReps RepHtml where - chooseRep (RepHtml c) _ = return (typeHtml, c) -newtype RepJson = RepJson Content -instance HasReps RepJson where - chooseRep (RepJson c) _ = return (typeJson, c) -data RepHtmlJson = RepHtmlJson Content Content -instance HasReps RepHtmlJson where - chooseRep (RepHtmlJson html json) = chooseRep - [ (typeHtml, html) - , (typeJson, json) - ] -newtype RepPlain = RepPlain Content -instance HasReps RepPlain where - chooseRep (RepPlain c) _ = return (typePlain, c) -newtype RepXml = RepXml Content -instance HasReps RepXml where - chooseRep (RepXml c) _ = return (typeXml, c) - -type ContentType = String - -typeHtml :: ContentType -typeHtml = "text/html; charset=utf-8" - -typePlain :: ContentType -typePlain = "text/plain; charset=utf-8" - -typeJson :: ContentType -typeJson = "application/json; charset=utf-8" - -typeXml :: ContentType -typeXml = "text/xml" - -typeAtom :: ContentType -typeAtom = "application/atom+xml" - -typeJpeg :: ContentType -typeJpeg = "image/jpeg" - -typePng :: ContentType -typePng = "image/png" - -typeGif :: ContentType -typeGif = "image/gif" - -typeJavascript :: ContentType -typeJavascript = "text/javascript; charset=utf-8" - -typeCss :: ContentType -typeCss = "text/css; charset=utf-8" - -typeFlv :: ContentType -typeFlv = "video/x-flv" - -typeOgv :: ContentType -typeOgv = "video/ogg" - -typeOctet :: ContentType -typeOctet = "application/octet-stream" - --- | Removes \"extra\" information at the end of a content type string. In --- particular, removes everything after the semicolon, if present. --- --- For example, \"text/html; charset=utf-8\" is commonly used to specify the --- character encoding for HTML data. This function would return \"text/html\". -simpleContentType :: String -> String -simpleContentType = fst . span (/= ';') - --- | A default extension to mime-type dictionary. -typeByExt :: [(String, ContentType)] -typeByExt = - [ ("jpg", typeJpeg) - , ("jpeg", typeJpeg) - , ("js", typeJavascript) - , ("css", typeCss) - , ("html", typeHtml) - , ("png", typePng) - , ("gif", typeGif) - , ("txt", typePlain) - , ("flv", typeFlv) - , ("ogv", typeOgv) - ] - --- | Get a file extension (everything after last period). -ext :: String -> String -ext = reverse . fst . break (== '.') . reverse - -#if TEST ----- Testing -testSuite :: Test -testSuite = testGroup "Yesod.Resource" - [ testProperty "ext" propExt - , testCase "typeByExt" caseTypeByExt - ] - -propExt :: String -> Bool -propExt s = - let s' = filter (/= '.') s - in s' == ext ("foobarbaz." ++ s') - -caseTypeByExt :: Assertion -caseTypeByExt = do - Just typeJavascript @=? lookup (ext "foo.js") typeByExt - Just typeHtml @=? lookup (ext "foo.html") typeByExt -#endif - --- | Format a 'UTCTime' in W3 format. -formatW3 :: UTCTime -> String -formatW3 = formatTime defaultTimeLocale "%FT%X-00:00" - --- | Format as per RFC 1123. -formatRFC1123 :: UTCTime -> String -formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" - --- | Format a 'UTCTime' for a cookie. -formatCookieExpires :: UTCTime -> String -formatCookieExpires = formatTime defaultTimeLocale "%a, %d-%b-%Y %X GMT" diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs deleted file mode 100644 --- a/Yesod/Dispatch.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Dispatch - ( -- * Quasi-quoted routing - parseRoutes - , mkYesod - , mkYesodSub - -- ** More fine-grained - , mkYesodData - , mkYesodSubData - , mkYesodDispatch - , mkYesodSubDispatch - -- ** Path pieces - , SinglePiece (..) - , MultiPiece (..) - , Strings - -- * Convert to WAI - , toWaiApp - , basicHandler - , basicHandler' -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Yesod hiding (testSuite) -import Yesod.Handler hiding (testSuite) -#else -import Yesod.Yesod -import Yesod.Handler -#endif - -import Yesod.Request -import Yesod.Internal - -import Web.Routes.Quasi -import Web.Routes.Quasi.Parse -import Web.Routes.Quasi.TH -import Language.Haskell.TH.Syntax - -import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPathFunc) -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 Control.Concurrent.MVar -import Control.Arrow ((***)) - -import Data.Time - -import Control.Monad -import Data.Maybe -import Web.ClientSession -import qualified Web.ClientSession as CS -import Data.Char (isUpper) - -import Data.Serialize -import qualified Data.Serialize as Ser -import Network.Wai.Parse hiding (FileInfo) -import qualified Network.Wai.Parse as NWP -import Data.String (fromString) -import Web.Routes -import Control.Arrow (first) -import System.Random (randomR, newStdGen) - -import qualified Data.Map as Map - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck -import System.IO.Unsafe -import Yesod.Content hiding (testSuite) -import Data.Serialize.Get -import Data.Serialize.Put -#else -import Yesod.Content -#endif - --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. --- Use 'parseRoutes' to create the 'Resource's. -mkYesod :: String -- ^ name of the argument datatype - -> [Resource] - -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False - --- | Generates URL datatype and site function for the given 'Resource's. This --- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter. --- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not --- executable by itself, but instead provides functionality to --- be embedded in other sites. -mkYesodSub :: String -- ^ name of the argument datatype - -> Cxt - -> [Resource] - -> Q [Dec] -mkYesodSub name clazzes = - fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True - where - (name':rest) = words name - --- | Sometimes, you will want to declare your routes in one file and define --- your handlers elsewhere. For example, this is the only way to break up a --- monolithic file into smaller parts. Use this function, paired with --- 'mkYesodDispatch', to do just that. -mkYesodData :: String -> [Resource] -> Q [Dec] -mkYesodData name res = mkYesodDataGeneral name [] False res - -mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec] -mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res - -mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec] -mkYesodDataGeneral name clazzes isSub res = do - let (name':rest) = words name - (x, _) <- mkYesodGeneral name' rest clazzes isSub res - let rname = mkName $ "resources" ++ name - eres <- lift res - let y = [ SigD rname $ ListT `AppT` ConT ''Resource - , FunD rname [Clause [] (NormalB eres) []] - ] - return $ x ++ y - --- | See 'mkYesodData'. -mkYesodDispatch :: String -> [Resource] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False - -mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec] -mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True - where (name':rest) = words name - -mkYesodGeneral :: String -- ^ argument name - -> [String] -- ^ parameters for site argument - -> Cxt -- ^ classes - -> Bool -- ^ is subsite? - -> [Resource] - -> Q ([Dec], [Dec]) -mkYesodGeneral name args clazzes isSub res = do - let name' = mkName name - args' = map mkName args - arg = foldl AppT (ConT name') $ map VarT args' - th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites - w' <- createRoutes th - let routesName = mkName $ name ++ "Route" - let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] - let x = TySynInstD ''Route [arg] $ ConT routesName - - parse' <- createParse th - parse'' <- newName "parse" - let parse = LetE [FunD parse'' parse'] $ VarE parse'' - - render' <- createRender th - render'' <- newName "render" - let render = LetE [FunD render'' render'] $ VarE render'' - - tmh <- [|toMasterHandlerDyn|] - modMaster <- [|fmap chooseRep|] - dispatch' <- createDispatch modMaster tmh th - dispatch'' <- newName "dispatch" - let dispatch = LetE [FunD dispatch'' dispatch'] $ LamE [WildP] $ VarE dispatch'' - - site <- [|Site|] - let site' = site `AppE` dispatch `AppE` render `AppE` parse - let (ctx, ytyp, yfunc) = - if isSub - then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") - else ([], ConT ''YesodSite `AppT` arg, "getSite") - let y = InstanceD ctx ytyp - [ FunD (mkName yfunc) [Clause [] (NormalB site') []] - ] - return ([w, x], [y]) - -isStatic :: Piece -> Bool -isStatic StaticPiece{} = True -isStatic _ = False - -thResourceFromResource :: Type -> Resource -> Q THResource -thResourceFromResource _ (Resource n ps atts) - | all (all isUpper) atts = return (n, Simple ps atts) -thResourceFromResource master (Resource n ps [stype, toSubArg]) - -- static route to subsite - = do - let stype' = ConT $ mkName stype - gss <- [|getSubSite|] - let inside = ConT ''Maybe `AppT` - (ConT ''GHandler `AppT` stype' `AppT` master `AppT` - ConT ''ChooseRep) - let typ = ConT ''Site `AppT` - (ConT ''Route `AppT` stype') `AppT` - (ArrowT `AppT` ConT ''String `AppT` inside) - let gss' = gss `SigE` typ - parse' <- [|parsePathSegments|] - let parse = parse' `AppE` gss' - render' <- [|formatPathSegments|] - let render = render' `AppE` gss' - dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] - let dispatch = dispatch' `AppE` gss' - tmg <- mkToMasterArg ps toSubArg - return (n, SubSite - { ssType = ConT ''Route `AppT` stype' - , ssParse = parse - , ssRender = render - , ssDispatch = dispatch - , ssToMasterArg = tmg - , ssPieces = ps - }) - - -thResourceFromResource _ (Resource n _ _) = - error $ "Invalid attributes for resource: " ++ n - -mkToMasterArg :: [Piece] -> String -> Q Exp -mkToMasterArg ps fname = do - let nargs = length $ filter (not.isStatic) ps - f = VarE $ mkName fname - args <- sequence $ take nargs $ repeat $ newName "x" - rsg <- [| runSubsiteGetter|] - let xps = map VarP args - xes = map VarE args - e' = foldl (\x y -> x `AppE` y) f xes - e = rsg `AppE` e' - return $ LamE xps e - -sessionName :: String -sessionName = "_SESSION" - --- | Convert the given argument into a WAI application, executable with any WAI --- handler. You can use 'basicHandler' if you wish. -toWaiApp :: (Yesod y, YesodSite y) => y -> IO W.Application -toWaiApp a = - return $ gzip - $ jsonp - $ cleanPathFunc (splitPath a) (B.pack $ approot a) - $ 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 = if sessionIpAddress y then W.remoteHost env else "" - let session' = fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders env - val <- lookup (B.pack sessionName) $ parseCookies raw - decodeSession key' now host val - let site = getSite - method = B.unpack $ W.requestMethod env - types = httpAccept env - pathSegments = filter (not . null) segments - eurl = parsePathSegments site pathSegments - render u qs = - let (ps, qs') = formatPathSegments site u - in fromMaybe - (joinPath y (approot y) ps $ qs ++ qs') - (urlRenderOverride y u) - let errorHandler' = localNoCurrent . errorHandler - rr <- parseWaiRequest env session' - let h = do - onRequest - case eurl of - Left _ -> errorHandler' NotFound - Right url -> do - isWrite <- isWriteRequest url - ar <- isAuthorized url isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute y of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDest' - redirect RedirectTemporary url' - Unauthorized s -> permissionDenied s - case handleSite site render url method of - Nothing -> errorHandler' $ BadMethod method - Just h' -> h' - let eurl' = either (const Nothing) Just eurl - let eh er = runHandler (errorHandler' er) render eurl' id y id - let ya = runHandler h render eurl' id y id - let sessionMap = Map.fromList - $ filter (\(x, _) -> x /= nonceKey) session' - (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types sessionMap - let sessionVal = encodeSession key' exp' host - $ Map.toList - $ Map.insert nonceKey (reqNonce rr) sessionFinal - let hs' = AddCookie (clientSessionDuration y) sessionName - (bsToChars sessionVal) - : hs - hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", charsToBs ct) : hs'' - return $ W.Response s hs''' c - -httpAccept :: W.Request -> [ContentType] -httpAccept = map B.unpack - . parseHttpAccept - . fromMaybe B.empty - . lookup "Accept" - . W.requestHeaders - --- | Runs an application with CGI if CGI variables are present (namely --- PATH_INFO); otherwise uses SimpleServer. -basicHandler :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> y - -> IO () -basicHandler port y = basicHandler' port (Just "localhost") y - - --- | Same as 'basicHandler', but allows you to specify the hostname to display --- to the user. If 'Nothing' is provided, then no output is produced. -basicHandler' :: (Yesod y, YesodSite y) - => Int -- ^ port number - -> Maybe String -- ^ host name, 'Nothing' to show nothing - -> y - -> IO () -basicHandler' port mhost y = do - app <- toWaiApp y - vars <- getEnvironment - case lookup "PATH_INFO" vars of - Nothing -> do - case mhost of - Nothing -> return () - Just h -> putStrLn $ concat - ["http://", h, ":", show port, "/"] - SS.run port app - Just _ -> CGI.run app - -parseWaiRequest :: W.Request - -> [(String, String)] -- ^ session - -> IO Request -parseWaiRequest env session' = do - let gets' = map (bsToChars *** bsToChars) - $ parseQueryString $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup "Cookie" - $ W.requestHeaders env - cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie - acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map bsToChars $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey session' of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey cookies' of - Nothing -> langs' - Just x -> x : langs' - langs''' = case lookup langKey gets' of - Nothing -> langs'' - Just x -> x : langs'' - rbthunk <- iothunk $ rbHelper env - nonce <- case lookup nonceKey session' of - Just x -> return x - Nothing -> do - g <- newStdGen - return $ fst $ randomString 10 g - return $ Request gets' cookies' rbthunk env langs''' nonce - where - randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - -nonceKey :: String -nonceKey = "_NONCE" - -rbHelper :: W.Request -> IO RequestBodyContents -rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (bsToChars *** bsToChars) - fix2 (x, NWP.FileInfo a b c) = - (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) - --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. -iothunk :: IO a -> IO (IO a) -iothunk = fmap go . newMVar . Left where - go :: MVar (Either (IO a) a) -> IO a - go mvar = modifyMVar mvar go' - go' :: Either (IO a) a -> IO (Either (IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - --- | Convert Header to a key/value pair. -headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time - -> Header - -> (W.ResponseHeader, B.ByteString) -headerToPair getExpires (AddCookie minutes key value) = - let expires = getExpires minutes - in ("Set-Cookie", charsToBs - $ key ++ "=" ++ value ++"; path=/; expires=" - ++ formatCookieExpires expires) -headerToPair _ (DeleteCookie key) = - ("Set-Cookie", charsToBs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair _ (Header key value) = - (fromString key, charsToBs value) - -encodeSession :: CS.Key - -> UTCTime -- ^ expire time - -> B.ByteString -- ^ remote host - -> [(String, String)] -- ^ session - -> B.ByteString -- ^ cookie value -encodeSession key expire rhost session' = - encrypt key $ encode $ SessionCookie expire rhost session' - -decodeSession :: CS.Key - -> UTCTime -- ^ current time - -> B.ByteString -- ^ remote host field - -> B.ByteString -- ^ cookie value - -> Maybe [(String, String)] -decodeSession key now rhost encrypted = do - decrypted <- decrypt key encrypted - SessionCookie expire rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' - -data SessionCookie = SessionCookie UTCTime B.ByteString [(String, String)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = putTime a >> put b >> put c - get = do - a <- getTime - b <- Ser.get - c <- Ser.get - return $ SessionCookie a b c - -putTime :: Putter UTCTime -putTime t@(UTCTime d _) = do - put $ toModifiedJulianDay d - let ndt = diffUTCTime t $ UTCTime d 0 - put $ toRational ndt - -getTime :: Get UTCTime -getTime = do - d <- Ser.get - ndt <- Ser.get - return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0 - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Dispatch" - [ testProperty "encode/decode session" propEncDecSession - , testProperty "get/put time" propGetPutTime - ] - -propEncDecSession :: [(String, String)] -> Bool -propEncDecSession session' = unsafePerformIO $ do - key <- getDefaultKey - now <- getCurrentTime - let expire = addUTCTime 1 now - let rhost = B.pack "some host" - let val = encodeSession key expire rhost session' - return $ Just session' == decodeSession key now rhost val - -propGetPutTime :: UTCTime -> Bool -propGetPutTime t = Right t == runGet getTime (runPut $ putTime t) - -instance Arbitrary UTCTime where - arbitrary = do - a <- arbitrary - b <- arbitrary - return $ addUTCTime (fromRational b) - $ UTCTime (ModifiedJulianDay a) 0 - -#endif diff --git a/Yesod/Form.hs b/Yesod/Form.hs deleted file mode 100644 --- a/Yesod/Form.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Parse forms (and query strings). -module Yesod.Form - ( -- * Data types - GForm - , FormResult (..) - , Enctype (..) - , FormFieldSettings (..) - , Textarea (..) - , FieldInfo (..) - -- ** Utilities - , formFailures - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Unwrapping functions - , generateForm - , runFormGet - , runFormMonadGet - , runFormPost - , runFormPostNoNonce - , runFormMonadPost - , runFormGet' - , runFormPost' - -- ** High-level form post unwrappers - , runFormTable - , runFormDivs - -- * Field/form helpers - , fieldsToTable - , fieldsToDivs - , fieldsToPlain - , checkForm - -- * Type classes - , module Yesod.Form.Class - -- * Template Haskell - , mkToForm - , module Yesod.Form.Fields - ) where - -import Yesod.Form.Core -import Yesod.Form.Fields -import Yesod.Form.Class -import Yesod.Form.Profiles (Textarea (..)) -import Yesod.Widget (GWidget) - -import Text.Hamlet -import Yesod.Request -import Yesod.Handler -import Control.Applicative hiding (optional) -import Data.Maybe (fromMaybe, mapMaybe) -import "transformers" Control.Monad.IO.Class -import Control.Monad ((<=<)) -import Language.Haskell.TH.Syntax -import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) -import Data.Char (toUpper, isUpper) -import Control.Arrow ((&&&)) -import Data.List (group, sort) - --- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: FormField sub y a -> Form sub y a -fieldsToPlain = mapFormXml $ mapM_ fiInput - --- | Display the label, tooltip, input code and errors in a single row of a --- table. -fieldsToTable :: FormField sub y a -> Form sub y a -fieldsToTable = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%tr.$clazz.fi$ - %td - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - %td - ^fiInput.fi^ - $maybe fiErrors.fi err - %td.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Display the label, tooltip, input code and errors in a single div. -fieldsToDivs :: FormField sub y a -> Form sub y a -fieldsToDivs = mapFormXml $ mapM_ go - where - go fi = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -.$clazz.fi$ - %label!for=$fiIdent.fi$ $fiLabel.fi$ - .tooltip $fiTooltip.fi$ - ^fiInput.fi^ - $maybe fiErrors.fi err - %div.errors $err$ -|] - clazz fi = if fiRequired fi then "required" else "optional" - --- | Run a form against POST parameters, without CSRF protection. -runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormPostNoNonce f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters. --- --- This function includes CSRF protection by checking a nonce value. You must --- therefore embed this nonce in the form as a hidden field; that is the --- meaning of the fourth element in the tuple. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) -runFormPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - nonce <- fmap reqNonce getRequest - (res, xml, enctype) <- runFormGeneric pp files f - let res' = - case res of - FormSuccess x -> - if lookup nonceName pp == Just nonce - then FormSuccess x - else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] - _ -> res - return (res', xml, enctype, hidden nonce) - where - hidden nonce = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|] - -nonceName :: String -nonceName = "_nonce" - --- | Run a form against POST parameters. Please note that this does not provide --- CSRF protection. -runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadPost f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - runFormGeneric pp files f - --- | Run a form against POST parameters, disregarding the resulting HTML and --- returning an error response on invalid input. Note: this does /not/ perform --- CSRF protection. -runFormPost' :: GForm sub y xml a -> GHandler sub y a -runFormPost' f = do - rr <- getRequest - (pp, files) <- liftIO $ reqRequestBody rr - x <- runFormGeneric pp files f - helper x - --- | Create a table-styled form. --- --- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of --- some of the boiler-plate in creating forms. In particular, is automatically --- creates the form element, sets the method, action and enctype attributes, --- adds the CSRF-protection nonce hidden field and inserts a submit button. -runFormTable :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormTable dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - %table - ^widget^ - %tr - %td!colspan=2 - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. -runFormDivs :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormDivs dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form - let widget' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@dest@!enctype=$enctype$ - ^widget^ - %div - $nonce$ - %input!type=submit!value=$inputLabel$ -|] - return (res, widget') - --- | Run a form against GET parameters, disregarding the resulting HTML and --- returning an error response on invalid input. -runFormGet' :: GForm sub y xml a -> GHandler sub y a -runFormGet' = helper <=< runFormGet - -helper :: (FormResult a, b, c) -> GHandler sub y a -helper (FormSuccess a, _, _) = return a -helper (FormFailure e, _, _) = invalidArgs e -helper (FormMissing, _, _) = invalidArgs ["No input found"] - --- | Generate a form, feeding it no data. The third element in the result tuple --- is a nonce hidden field. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) -generateForm f = do - (_, b, c) <- runFormGeneric [] [] f - nonce <- fmap reqNonce getRequest - return (b, c, -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input!type=hidden!name=$nonceName$!value=$nonce$ -|]) - --- | Run a form against GET parameters. -runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - -runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - --- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: PersistEntity v => v -> Q [Dec] -mkToForm = - fmap return . derive . entityDef - where - afterPeriod s = - case dropWhile (/= '.') s of - ('.':t) -> t - _ -> s - beforePeriod s = - case break (== '.') s of - (t, '.':_) -> Just t - _ -> Nothing - getSuperclass (_, _, z) = getTFF' z >>= beforePeriod - getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z - getTFF' [] = Nothing - getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x - getTFF' (_:x) = getTFF' x - getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z - getLabel' [] = Nothing - getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x - getLabel' (_:x) = getLabel' x - getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z - getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x - getTooltip' (_:x) = getTooltip' x - getTooltip' [] = Nothing - getId (_, _, z) = fromMaybe "" $ getId' z - getId' (('i':'d':'=':x):_) = Just x - getId' (_:x) = getId' x - getId' [] = Nothing - getName (_, _, z) = fromMaybe "" $ getName' z - getName' (('n':'a':'m':'e':'=':x):_) = Just x - getName' (_:x) = getName' x - getName' [] = Nothing - derive :: EntityDef -> Q Dec - derive t = do - let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t - ap <- [|(<*>)|] - just <- [|pure|] - nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ entityName t) - string' <- [|string|] - ftt <- [|fieldsToTable|] - ffs' <- [|FormFieldSettings|] - let stm "" = nothing - stm x = just `AppE` LitE (StringL x) - let go_ = go ap just' ffs' stm string' ftt - let c1 = Clause [ ConP (mkName "Nothing") [] - ] - (NormalB $ go_ $ zip cols $ map (const nothing) cols) - [] - xs <- mapM (const $ newName "x") cols - let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) - $ map VarP xs]] - (NormalB $ go_ $ zip cols xs') - [] - let y = mkName "y" - let ctx = map (\x -> ClassP (mkName x) [VarT y]) - $ map head $ group $ sort - $ mapMaybe getSuperclass - $ entityColumns t - return $ InstanceD ctx ( ConT ''ToForm - `AppT` ConT (mkName $ entityName t) - `AppT` VarT y) - [FunD (mkName "toForm") [c1, c2]] - go ap just' ffs' stm string' ftt a = - let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a - in ftt `AppE` x - go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = - let label' = LitE $ StringL label - tooltip' = string' `AppE` LitE (StringL tooltip) - ffs = ffs' `AppE` - label' `AppE` - tooltip' `AppE` - (stm theId) `AppE` - (stm name) - in VarE (mkName tff) `AppE` ffs `AppE` ex - ap' ap x y = InfixE (Just x) ap (Just y) - -toLabel :: String -> String -toLabel "" = "" -toLabel (x:rest) = toUpper x : go rest - where - go "" = "" - go (c:cs) - | isUpper c = ' ' : c : go cs - | otherwise = c : go cs - -formFailures :: FormResult a -> Maybe [String] -formFailures (FormFailure x) = Just x -formFailures _ = Nothing diff --git a/Yesod/Form/Class.hs b/Yesod/Form/Class.hs deleted file mode 100644 --- a/Yesod/Form/Class.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Form.Class - ( ToForm (..) - , ToFormField (..) - ) where - -import Text.Hamlet -import Yesod.Form.Fields -import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea) -import Data.Int (Int64) -import Data.Time (Day, TimeOfDay) - -class ToForm a y where - toForm :: Formlet sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> FormletField sub y a - -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField - -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -instance ToFormField Bool y where - toFormField = boolField - -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -instance ToFormField Textarea y where - toFormField = textareaField -instance ToFormField (Maybe Textarea) y where - toFormField = maybeTextareaField diff --git a/Yesod/Form/Core.hs b/Yesod/Form/Core.hs deleted file mode 100644 --- a/Yesod/Form/Core.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | Users of the forms library should not need to use this module in general. --- It is intended only for writing custom forms and form fields. -module Yesod.Form.Core - ( FormResult (..) - , GForm (..) - , newFormIdent - , deeperFormIdent - , shallowerFormIdent - , Env - , FileEnv - , Enctype (..) - , Ints (..) - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml - , checkForm - , checkField - , askParams - , askFiles - , liftForm - , IsForm (..) - , RunForm (..) - , GFormMonad - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - , FieldProfile (..) - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - ) where - -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Class (lift) -import Yesod.Handler -import Yesod.Widget -import Data.Monoid (Monoid (..)) -import Control.Applicative -import Yesod.Request -import Control.Monad (liftM) -import Text.Hamlet -import Data.String -import Control.Monad (join) - --- | A form can produce three different results: there was no data available, --- the data was invalid, or there was a successful parse. --- --- The 'Applicative' instance will concatenate the failure messages in two --- 'FormResult's. -data FormResult a = FormMissing - | FormFailure [String] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart - deriving (Eq, Enum, Bounded) -instance ToHtml Enctype where - toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" - toHtml Multipart = unsafeByteString "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ '-' : show is - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm s m xml a = GForm - { deform :: FormInner s m (FormResult a, xml, Enctype) - } - -type GFormMonad s m a = WriterT Enctype (FormInner s m) a - -type FormInner s m = - StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - GHandler s m - ))) - -type Env = [(String, String)] -type FileEnv = [(String, FileInfo)] - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ liftM (first3 $ fmap f) g - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ do - (f1, f2, f3) <- f - (g1, g2, g3) <- g - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper - :: IsForm f - => FieldProfile (FormSub f) (FormMaster f) (FormType f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -class IsForm f where - type FormSub f - type FormMaster f - type FormType f - toForm :: FormInner - (FormSub f) - (FormMaster f) - (FormResult (FormType f), - FieldInfo (FormSub f) (FormMaster f), - Enctype) -> f -instance IsForm (FormField s m a) where - type FormSub (FormField s m a) = s - type FormMaster (FormField s m a) = m - type FormType (FormField s m a) = a - toForm x = GForm $ do - (a, b, c) <- x - return (a, [b], c) -instance IsForm (GFormMonad s m (FormResult a, FieldInfo s m)) where - type FormSub (GFormMonad s m (FormResult a, FieldInfo s m)) = s - type FormMaster (GFormMonad s m (FormResult a, FieldInfo s m)) = m - type FormType (GFormMonad s m (FormResult a, FieldInfo s m)) = a - toForm x = do - (res, fi, enctype) <- lift x - tell enctype - return (res, fi) - -class RunForm f where - type RunFormSub f - type RunFormMaster f - type RunFormType f - runFormGeneric :: Env -> FileEnv -> f - -> GHandler (RunFormSub f) - (RunFormMaster f) - (RunFormType f) - -instance RunForm (GForm s m xml a) where - type RunFormSub (GForm s m xml a) = s - type RunFormMaster (GForm s m xml a) = m - type RunFormType (GForm s m xml a) = - (FormResult a, xml, Enctype) - runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe - -instance RunForm (GFormMonad s m a) where - type RunFormSub (GFormMonad s m a) = s - type RunFormMaster (GFormMonad s m a) = m - type RunFormType (GFormMonad s m a) = (a, Enctype) - runFormGeneric e fe f = - runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper - :: (IsForm f, Maybe b ~ FormType f) - => FieldProfile (FormSub f) (FormMaster f) b - -> FormFieldSettings - -> Maybe (Maybe b) - -> f -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val False - , fiErrors = case res of - FormFailure x -> Just $ string $ unlines x - _ -> Nothing - , fiRequired = False - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ do - (res, xml, enc) <- g - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - , fiRequired :: Bool - } - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: String - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings s mempty Nothing Nothing - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: String -> Either String a - , fpRender :: a -> String - -- | ID, name, value, required - , fpWidget :: String -> String -> String -> Bool -> GWidget sub y () - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Add a validation check to a form. --- --- Note that if there is a validation error, this message will /not/ --- automatically appear on the form; for that, you need to use 'checkField'. -checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b -checkForm f (GForm form) = GForm $ do - (res, xml, enc) <- form - let res' = case res of - FormSuccess a -> f a - FormFailure e -> FormFailure e - FormMissing -> FormMissing - return (res', xml, enc) - --- | Add a validation check to a 'FormField'. --- --- Unlike 'checkForm', the validation error will appear in the generated HTML --- of the form. -checkField :: (a -> Either String b) -> FormField s m a -> FormField s m b -checkField f (GForm form) = GForm $ do - (res, xml, enc) <- form - let (res', merr) = - case res of - FormSuccess a -> - case f a of - Left e -> (FormFailure [e], Just e) - Right x -> (FormSuccess x, Nothing) - FormFailure e -> (FormFailure e, Nothing) - FormMissing -> (FormMissing, Nothing) - let xml' = - case merr of - Nothing -> xml - Just err -> flip map xml $ \fi -> fi - { fiErrors = Just $ - case fiErrors fi of - Nothing -> string err - Just x -> x - } - return (res', xml', enc) - -askParams :: Monad m => StateT Ints (ReaderT Env m) Env -askParams = lift ask - -askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv -askFiles = lift $ lift ask - -liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a -liftForm = lift . lift . lift diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs deleted file mode 100644 --- a/Yesod/Form/Fields.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Fields - ( -- * Fields - -- ** Required - stringField - , passwordField - , textareaField - , hiddenField - , intField - , doubleField - , dayField - , timeField - , htmlField - , selectField - , boolField - , emailField - , searchField - , urlField - , fileField - -- ** Optional - , maybeStringField - , maybePasswordField - , maybeTextareaField - , maybeHiddenField - , maybeIntField - , maybeDoubleField - , maybeDayField - , maybeTimeField - , maybeHtmlField - , maybeSelectField - , maybeEmailField - , maybeSearchField - , maybeUrlField - , maybeFileField - -- * Inputs - -- ** Required - , stringInput - , intInput - , boolInput - , dayInput - , emailInput - , urlInput - -- ** Optional - , maybeStringInput - , maybeDayInput - , maybeIntInput - ) where - -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Request (FileInfo) -import Yesod.Widget (GWidget) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Time (Day, TimeOfDay) -import Text.Hamlet -import Data.Monoid -import Control.Monad (join) -import Data.Maybe (fromMaybe) - -stringField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybePasswordField = optionalFieldHelper passwordFieldProfile - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput :: Integral i => String -> FormInput sub master (Maybe i) -maybeIntInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: (Integral (FormType f), IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeIntField = optionalFieldHelper intFieldProfile - -doubleField :: (IsForm f, FormType f ~ Double) - => FormFieldSettings -> Maybe Double -> f -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) - => FormFieldSettings -> Maybe (Maybe Double) -> f -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -dayField :: (IsForm f, FormType f ~ Day) - => FormFieldSettings -> Maybe Day -> f -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: (IsForm f, FormType f ~ Maybe Day) - => FormFieldSettings -> Maybe (Maybe Day) -> f -maybeDayField = optionalFieldHelper dayFieldProfile - -timeField :: (IsForm f, FormType f ~ TimeOfDay) - => FormFieldSettings -> Maybe TimeOfDay -> f -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) - => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f -maybeTimeField = optionalFieldHelper timeFieldProfile - -boolField :: (IsForm f, FormType f ~ Bool) - => FormFieldSettings -> Maybe Bool -> f -boolField ffs orig = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just "" -> (FormSuccess False, False) - Just "false" -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=checkbox!name=$name$!:val:checked -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -htmlField :: (IsForm f, FormType f ~ Html) - => FormFieldSettings -> Maybe Html -> f -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) - => FormFieldSettings -> Maybe (Maybe Html) -> f -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -selectField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, String)] - -> FormFieldSettings - -> Maybe x - -> f -selectField pairs ffs initial = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, String)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeSelectField pairs ffs initial' = toForm $ do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%select#$theId$!name=$name$ - %option!value=none - $forall pairs' pair - %option!value=$show.fst.pair$!:isSelected.fst.snd.pair:selected $snd.snd.pair$ -|] - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> FormInput sub master Bool -boolInput n = GForm $ do - env <- askParams - let res = case lookup n env of - Nothing -> FormSuccess False - Just "" -> FormSuccess False - Just "false" -> FormSuccess False - Just _ -> FormSuccess True - let xml = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %input#$n$!type=checkbox!name=$n$ -|] - return (res, [xml], UrlEncoded) - -dayInput :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -searchField :: (IsForm f, FormType f ~ String) - => AutoFocus -> FormFieldSettings -> Maybe String -> f -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField :: (IsForm f, FormType f ~ Maybe String) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> f -maybeSearchField = optionalFieldHelper . searchFieldProfile - -textareaField :: (IsForm f, FormType f ~ Textarea) - => FormFieldSettings -> Maybe Textarea -> f -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeHiddenField = optionalFieldHelper hiddenFieldProfile - -fileField :: (IsForm f, FormType f ~ FileInfo) - => FormFieldSettings -> f -fileField ffs = toForm $ do - env <- lift ask - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = - if null env && null fenv - then FormMissing - else case lookup name fenv of - Nothing -> FormFailure ["File is required"] - Just x -> FormSuccess x - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, Multipart) - -maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) - => FormFieldSettings -> f -maybeFileField ffs = toForm $ do - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = FormSuccess $ lookup name fenv - let fi = FieldInfo - { fiLabel = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: String -> String -> Bool -> GWidget s m () -fileWidget theId name isReq = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%input#$theId$!type=file!name=$name$!:isReq:required -|] diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs deleted file mode 100644 --- a/Yesod/Form/Jquery.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Some fields spiced up with jQuery UI. -module Yesod.Form.Jquery - ( YesodJquery (..) - , jqueryDayField - , maybeJqueryDayField - , jqueryDayTimeField - , jqueryDayTimeFieldProfile - , jqueryAutocompleteField - , maybeJqueryAutocompleteField - , jqueryDayFieldProfile - , googleHostedJqueryUiCss - , JqueryDaySettings (..) - , Default (..) - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Widget -import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, - timeToTimeOfDay) -import Yesod.Hamlet -import Data.Char (isSpace) -import Data.Default - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - --- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. -googleHostedJqueryUiCss :: String -> String -googleHostedJqueryUiCss theme = concat - [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" - , theme - , "/jquery-ui.css" - ] - -class YesodJquery a where - -- | The jQuery 1.4 Javascript file. - urlJqueryJs :: a -> Either (Route a) String - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js" - - -- | The jQuery UI 1.8 Javascript file. - urlJqueryUiJs :: a -> Either (Route a) String - urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" - - -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. - urlJqueryUiCss :: a -> Either (Route a) String - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) String - urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" - -jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile - -maybeJqueryDayField - :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile - -jqueryDayFieldProfile :: YesodJquery y - => JqueryDaySettings -> FieldProfile sub y Day -jqueryDayFieldProfile jds = FieldProfile - { fpParse = maybe - (Left "Invalid day, must be in YYYY-MM-DD format") - Right - . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datepicker({ - dateFormat:'yy-mm-dd', - changeMonth:%jsBool.jdsChangeMonth.jds%, - changeYear:%jsBool.jdsChangeYear.jds%, - numberOfMonths:%mos.jdsNumberOfMonths.jds%, - yearRange:"%jdsYearRange.jds%" -})}); -|] - } - where - jsBool True = "true" - jsBool False = "false" - mos (Left i) = show i - mos (Right (x, y)) = concat - [ "[" - , show x - , "," - , show y - , "]" - ] - -ifRight :: Either a b -> (b -> c) -> Either a c -ifRight e f = case e of - Left l -> Left l - Right r -> Right $ f r - -showLeadingZero :: (Show a) => a -> String -showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t - -jqueryDayTimeField - :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) - => FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile - --- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) -jqueryDayTimeUTCTime :: UTCTime -> String -jqueryDayTimeUTCTime (UTCTime day utcTime) = - let timeOfDay = timeToTimeOfDay utcTime - in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay - where - showTimeOfDay (TimeOfDay hour minute _) = - let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") - in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm - -jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime -jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime - , fpRender = jqueryDayTimeUTCTime - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addScript' urlJqueryUiDateTimePicker - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); -|] - } - -parseUTCTime :: String -> Either String UTCTime -parseUTCTime s = - let (dateS, timeS) = break isSpace (dropWhile isSpace s) - dateE = parseDate dateS - in case dateE of - Left l -> Left l - Right date -> - ifRight (parseTime timeS) - (UTCTime date . timeOfDayToTime) - -jqueryAutocompleteField - :: (IsForm f, FormType f ~ String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String -jqueryAutocompleteFieldProfile src = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input.autocomplete#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("#%theId%").autocomplete({source:"@src@",minLength:2})}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) String) -> GWidget sub y () -addStylesheet' f = do - y <- liftHandler getYesod - addStylesheetEither $ f y - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -data JqueryDaySettings = JqueryDaySettings - { jdsChangeMonth :: Bool - , jdsChangeYear :: Bool - , jdsYearRange :: String - , jdsNumberOfMonths :: Either Int (Int, Int) - } - -instance Default JqueryDaySettings where - def = JqueryDaySettings - { jdsChangeMonth = False - , jdsChangeYear = False - , jdsYearRange = "c-10:c+10" - , jdsNumberOfMonths = Left 1 - } diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs deleted file mode 100644 --- a/Yesod/Form/Nic.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Provide the user with a rich text editor. -module Yesod.Form.Nic - ( YesodNic (..) - , nicHtmlField - , maybeNicHtmlField - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Hamlet -import Yesod.Widget -import Text.HTML.SanitizeXSS (sanitizeBalance) - -import Yesod.Internal (lbsToChars) - -class YesodNic a where - -- | NIC Editor Javascript file. - urlNicEdit :: a -> Either (Route a) String - urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" - -nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe Html -> f -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile - -maybeNicHtmlField - :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile - -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html -nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> do - addHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif - %textarea.html#$theId$!name=$name$ $val$ -|] - addScript' urlNicEdit - addJulius -#if GHC7 - [julius| -#else - [$julius| -#endif -bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("%theId%")}); -|] - } - -addScript' :: (y -> Either (Route y) String) -> GWidget sub y () -addScript' f = do - y <- liftHandler getYesod - addScriptEither $ f y diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs deleted file mode 100644 --- a/Yesod/Form/Profiles.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Profiles - ( stringFieldProfile - , passwordFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , searchFieldProfile - , AutoFocus - , urlFieldProfile - , doubleFieldProfile - , parseDate - , parseTime - , Textarea (..) - ) where - -import Yesod.Form.Core -import Yesod.Widget -import Text.Hamlet -import Text.Cassius -import Data.Time (Day, TimeOfDay(..)) -import qualified Text.Email.Validate as Email -import Network.URI (parseURI) -import Database.Persist (PersistField) -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Control.Monad (when) - -import qualified Blaze.ByteString.Builder.Html.Utf8 as B -import Blaze.ByteString.Builder (writeByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -import Yesod.Internal (lbsToChars) - -#if GHC7 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI - , fpRender = showI - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$ -|] - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$ -|] - } - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime - , fpRender = show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!:isReq:required!value=$val$ -|] - } - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance - , fpRender = lbsToChars . renderHtml - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea.html#$theId$!name=$name$ $val$ -|] - } - --- | A newtype wrapper around a 'String' that converts newlines to HTML --- br-tags. -newtype Textarea = Textarea { unTextarea :: String } - deriving (Show, Read, Eq, PersistField) -instance ToHtml Textarea where - toHtml = - Html . fromWriteList writeHtmlEscapedChar . unTextarea - where - -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '\n' = writeByteString "
" - writeHtmlEscapedChar c = B.writeHtmlEscapedChar c - -textareaFieldProfile :: FieldProfile sub y Textarea -textareaFieldProfile = FieldProfile - { fpParse = Right . Textarea - , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%textarea#$theId$!name=$name$ $val$ -|] - } - -hiddenFieldProfile :: FieldProfile sub y String -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET| -%input!type=hidden#$theId$!name=$name$!value=$val$ -|] - } - -stringFieldProfile :: FieldProfile sub y String -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$ -|] - } - -passwordFieldProfile :: FieldProfile s m String -passwordFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=password!:isReq:required!value=$val$ -|] - } - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -parseDate :: String -> Either String Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either String TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = - parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = - let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 - in parseTimeHelper (h1', h2', m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper (h1, h2, m1, m2, s1, s2) -parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -emailFieldProfile :: FieldProfile s y String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid s - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$ -|] - } - -type AutoFocus = Bool -searchFieldProfile :: AutoFocus -> FieldProfile s y String -searchFieldProfile autoFocus = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET| -%input#$theId$!name=$name$!type=search!:isReq:required!:autoFocus:autofocus!value=$val$ -|] - when autoFocus $ do - addHtml $ [HAMLET| |] - addCassius [CASSIUS| - #$theId$ - -webkit-appearance: textfield - |] - } - -urlFieldProfile :: FieldProfile s y String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET| -%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$ -|] - } diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs deleted file mode 100644 --- a/Yesod/Hamlet.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Hamlet - ( -- * Hamlet library - -- ** Hamlet - hamlet - , xhamlet - , Hamlet - , Html - , renderHamlet - , renderHtml - , string - , preEscapedString - , cdata - -- ** Julius - , julius - , Julius - , renderJulius - -- ** Cassius - , cassius - , Cassius - , renderCassius - -- * Convert to something displayable - , hamletToContent - , hamletToRepHtml - -- * Page templates - , PageContent (..) - ) - where - -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Content -import Yesod.Handler - --- | Content for a web page. By providing this datatype, we can easily create --- generic site templates, which would have the type signature: --- --- > PageContent url -> Hamlet url -data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: Hamlet url - , pageBody :: Hamlet url - } - --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: Hamlet (Route master) -> GHandler sub master Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ renderHamlet render h - --- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml -hamletToRepHtml = fmap RepHtml . hamletToContent diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs deleted file mode 100644 --- a/Yesod/Handler.hs +++ /dev/null @@ -1,571 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} ---------------------------------------------------------- --- --- Module : Yesod.Handler --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : unstable --- Portability : portable --- --- Define Handler stuff. --- ---------------------------------------------------------- -module Yesod.Handler - ( -- * Type families - Route - , YesodSubRoute (..) - -- * Handler monad - , GHandler - -- ** Read information from handler - , getYesod - , getYesodSub - , getUrlRender - , getUrlRenderParams - , getCurrentRoute - , getRouteToMaster - -- * Special responses - -- ** Redirecting - , RedirectType (..) - , redirect - , redirectParams - , redirectString - -- ** Errors - , notFound - , badMethod - , permissionDenied - , invalidArgs - -- ** Short-circuit responses. - , sendFile - , sendResponse - , sendResponseStatus - , sendResponseCreated - -- * Setting headers - , setCookie - , deleteCookie - , setHeader - , setLanguage - -- ** Content caching and expiration - , cacheSeconds - , neverExpires - , alreadyExpired - , expiresAt - -- * Session - , SessionMap - , lookupSession - , getSession - , setSession - , deleteSession - -- ** Ultimate destination - , setUltDest - , setUltDestString - , setUltDest' - , redirectUltDest - -- ** Messages - , setMessage - , getMessage - -- * Internal Yesod - , runHandler - , YesodApp (..) - , runSubsiteGetter - , toMasterHandler - , toMasterHandlerDyn - , toMasterHandlerMaybe - , localNoCurrent - , HandlerData - , ErrorResponse (..) -#if TEST - , testSuite -#endif - ) where - -import Prelude hiding (catch) -import Yesod.Request -import Yesod.Internal -import Data.Neither -import Data.Time (UTCTime) - -import Control.Exception hiding (Handler, catch, finally) -import qualified Control.Exception as E -import Control.Applicative - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State - -import System.IO -import qualified Network.Wai as W -import Control.Failure (Failure (failure)) - -import Text.Hamlet - -import Control.Monad.Invert (MonadInvertIO (..)) -import Control.Monad (liftM) -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as S8 - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit hiding (Test) -import Yesod.Content hiding (testSuite) -import Data.IORef -#else -import Yesod.Content -#endif - --- | The type-safe URLs associated with a site argument. -type family Route a - -class YesodSubRoute s y where - fromSubRoute :: s -> y -> Route s -> Route y - -data HandlerData sub master = HandlerData - { handlerRequest :: Request - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> [(String, String)] -> String) - , handlerToMaster :: Route sub -> Route master - } - -handlerSubData :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubData tm ts = handlerSubDataMaybe tm ts . Just - -handlerSubDataMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route - } - --- | Used internally for promoting subsite handler functions to master site --- handler functions. Should not be needed by users. -toMasterHandler :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandler tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubData tm ts route) h - -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerDyn tm getSub route (GHandler h) = do - sub <- getSub - GHandler $ withReaderT (handlerSubData tm (const sub) route) h - -class SubsiteGetter g m s | g -> s where - runSubsiteGetter :: g -> m s - -instance (master ~ master' - ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where - runSubsiteGetter getter = do - y <- getYesod - return $ getter y - -instance (anySub ~ anySub' - ,master ~ master' - ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where - runSubsiteGetter = id - -toMasterHandlerMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerMaybe tm ts route (GHandler h) = - GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h - --- | A generic handler monad, which can have a different subsite and master --- site. This monad is a combination of 'ReaderT' for basic arguments, a --- 'WriterT' for headers and session, and an 'MEitherT' monad for handling --- special responses. It is declared as a newtype to make compiler errors more --- readable. -newtype GHandler sub master a = - GHandler - { unGHandler :: GHInner sub master a - } - deriving (Functor, Applicative, Monad, MonadIO) - -type GHInner s m = - ReaderT (HandlerData s m) ( - MEitherT HandlerContents ( - WriterT (Endo [Header]) ( - StateT SessionMap ( -- session - IO - )))) - -type SessionMap = Map.Map String String - -instance MonadInvertIO (GHandler s m) where - newtype InvertedIO (GHandler s m) a = - InvGHandlerIO - { runInvGHandlerIO :: InvertedIO (GHInner s m) a - } - type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ())) - invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler - revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f - -type Endo a = a -> a - --- | An extension of the basic WAI 'W.Application' datatype to provide extra --- features needed by Yesod. Users should never need to use this directly, as --- the 'GHandler' monad and template haskell code should hide it away. -newtype YesodApp = YesodApp - { unYesodApp - :: (ErrorResponse -> YesodApp) - -> Request - -> [ContentType] - -> SessionMap - -> IO (W.Status, [Header], ContentType, Content, SessionMap) - } - -data HandlerContents = - HCContent W.Status ChooseRep - | HCError ErrorResponse - | HCSendFile ContentType FilePath - | HCRedirect RedirectType String - | HCCreated String - -instance Failure ErrorResponse (GHandler sub master) where - failure = GHandler . lift . throwMEither . HCError -instance RequestReader (GHandler sub master) where - getRequest = handlerRequest <$> GHandler ask - --- | Get the sub application argument. -getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub <$> GHandler ask - --- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = handlerMaster <$> GHandler ask - --- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> String) -getUrlRender = do - x <- handlerRender <$> GHandler ask - return $ flip x [] - --- | The URL rendering function with query-string parameters. -getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) -getUrlRenderParams = handlerRender <$> GHandler ask - --- | Get the route requested by the user. If this is a 404 response- where the --- user requested an invalid route- this function will return 'Nothing'. -getCurrentRoute :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute <$> GHandler ask - --- | Get the function to promote a route for a subsite to a route for the --- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster <$> GHandler ask - --- | Function used internally by Yesod in the process of converting a --- 'GHandler' into an 'W.Application'. Should not be needed by users. -runHandler :: HasReps c - => GHandler sub master c - -> (Route master -> [(String, String)] -> String) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> (master -> sub) - -> YesodApp -runHandler handler mrender sroute tomr ma tosa = - YesodApp $ \eh rr cts initSession -> do - let toErrorHandler = - InternalError - . (show :: Control.Exception.SomeException -> String) - let hd = HandlerData - { handlerRequest = rr - , handlerSub = tosa ma - , handlerMaster = ma - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr - } - ((contents', headers), finalSession) <- E.catch ( - flip runStateT initSession - $ runWriterT - $ runMEitherT - $ flip runReaderT hd - $ unGHandler handler - ) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession)) - let contents = meither id (HCContent W.status200 . chooseRep) contents' - let handleError e = do - (_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession - let hs' = headers hs - return (getStatus e, hs', ct, c, sess) - let sendFile' ct fp = - return (W.status200, headers [], ct, W.ResponseFile fp, finalSession) - case contents of - HCContent status a -> do - (ct, c) <- chooseRep a cts - return (status, headers [], ct, c, finalSession) - HCError e -> handleError e - HCRedirect rt loc -> do - let hs = Header "Location" loc : headers [] - return (getRedirectStatus rt, hs, typePlain, emptyContent, - finalSession) - HCSendFile ct fp -> E.catch - (sendFile' ct fp) - (handleError . toErrorHandler) - HCCreated loc -> do - let hs = Header "Location" loc : headers [] - return (W.Status 201 (S8.pack "Created"), hs, typePlain, - emptyContent, - finalSession) - -safeEh :: ErrorResponse -> YesodApp -safeEh er = YesodApp $ \_ _ _ session -> do - liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return (W.status500, [], typePlain, toContent "Internal Server Error", - session) - --- | Redirect to the given route. -redirect :: RedirectType -> Route master -> GHandler sub master a -redirect rt url = redirectParams rt url [] - --- | Redirects to the given route with the associated query-string parameters. -redirectParams :: RedirectType -> Route master -> [(String, String)] - -> GHandler sub master a -redirectParams rt url params = do - r <- getUrlRenderParams - redirectString rt $ r url params - --- | Redirect to the given URL. -redirectString :: RedirectType -> String -> GHandler sub master a -redirectString rt = GHandler . lift . throwMEither . HCRedirect rt - -ultDestKey :: String -ultDestKey = "_ULT" - --- | Sets the ultimate destination variable to the given route. --- --- An ultimate destination is stored in the user session and can be loaded --- later by 'redirectUltDest'. -setUltDest :: Route master -> GHandler sub master () -setUltDest dest = do - render <- getUrlRender - setUltDestString $ render dest - --- | Same as 'setUltDest', but use the given string. -setUltDestString :: String -> GHandler sub master () -setUltDestString = setSession ultDestKey - --- | Same as 'setUltDest', but uses the current page. --- --- If this is a 404 handler, there is no current page, and then this call does --- nothing. -setUltDest' :: GHandler sub master () -setUltDest' = do - route <- getCurrentRoute - case route of - Nothing -> return () - Just r -> do - tm <- getRouteToMaster - gets' <- reqGetParams <$> getRequest - render <- getUrlRenderParams - setUltDestString $ render (tm r) gets' - --- | Redirect to the ultimate destination in the user's session. Clear the --- value from the session. --- --- The ultimate destination is set with 'setUltDest'. -redirectUltDest :: RedirectType - -> Route master -- ^ default destination if nothing in session - -> GHandler sub master () -redirectUltDest rt def = do - mdest <- lookupSession ultDestKey - deleteSession ultDestKey - maybe (redirect rt def) (redirectString rt) mdest - -msgKey :: String -msgKey = "_MSG" - --- | Sets a message in the user's session. --- --- See 'getMessage'. -setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . lbsToChars . renderHtml - --- | Gets the message in the user's session, if available, and then clears the --- variable. --- --- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) -getMessage = do - mmsg <- fmap (fmap preEscapedString) $ lookupSession msgKey - deleteSession msgKey - return mmsg - --- | Bypass remaining handler code and output the given file. --- --- For some backends, this is more efficient than reading in the file to --- memory, since they can optimize file sending via a system call to sendfile. -sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = GHandler . lift . throwMEither . HCSendFile ct - --- | Bypass remaining handler code and output the given content with a 200 --- status code. -sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = GHandler . lift . throwMEither . HCContent W.status200 - . chooseRep - --- | Bypass remaining handler code and output the given content with the given --- status code. -sendResponseStatus :: HasReps c => W.Status -> c -> GHandler s m a -sendResponseStatus s = GHandler . lift . throwMEither . HCContent s - . chooseRep - --- | Send a 201 "Created" response with the given route as the Location --- response header. -sendResponseCreated :: Route m -> GHandler s m a -sendResponseCreated url = do - r <- getUrlRender - GHandler $ lift $ throwMEither $ HCCreated $ r url - --- | Return a 404 not found page. Also denotes no handler available. -notFound :: Failure ErrorResponse m => m a -notFound = failure NotFound - --- | Return a 405 method not supported page. -badMethod :: (RequestReader m, Failure ErrorResponse m) => m a -badMethod = do - w <- waiRequest - failure $ BadMethod $ bsToChars $ W.requestMethod w - --- | Return a 403 permission denied page. -permissionDenied :: Failure ErrorResponse m => String -> m a -permissionDenied = failure . PermissionDenied - --- | Return a 400 invalid arguments page. -invalidArgs :: Failure ErrorResponse m => [String] -> m a -invalidArgs = failure . InvalidArgs - -------- Headers --- | Set the cookie on the client. -setCookie :: Int -- ^ minutes to timeout - -> String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setCookie a b = addHeader . AddCookie a b - --- | Unset the cookie on the client. -deleteCookie :: String -> GHandler sub master () -deleteCookie = addHeader . DeleteCookie - --- | Set the language in the user session. Will show up in 'languages' on the --- next request. -setLanguage :: String -> GHandler sub master () -setLanguage = setSession langKey - --- | Set an arbitrary response header. -setHeader :: String -> String -> GHandler sub master () -setHeader a = addHeader . Header a - --- | Set the Cache-Control header to indicate this response should be cached --- for the given number of seconds. -cacheSeconds :: Int -> GHandler s m () -cacheSeconds i = setHeader "Cache-Control" $ concat - [ "max-age=" - , show i - , ", public" - ] - --- | Set the Expires header to some date in 2037. In other words, this content --- is never (realistically) expired. -neverExpires :: GHandler s m () -neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" - --- | Set an Expires header in the past, meaning this content should not be --- cached. -alreadyExpired :: GHandler s m () -alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" - --- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () -expiresAt = setHeader "Expires" . formatRFC1123 - --- | Set a variable in the user's session. --- --- The session is handled by the clientsession package: it sets an encrypted --- and hashed cookie on the client. This ensures that all data is secure and --- not tampered with. -setSession :: String -- ^ key - -> String -- ^ value - -> GHandler sub master () -setSession k = GHandler . lift . lift . lift . modify . Map.insert k - --- | Unsets a session variable. See 'setSession'. -deleteSession :: String -> GHandler sub master () -deleteSession = GHandler . lift . lift . lift . modify . Map.delete - --- | Internal use only, not to be confused with 'setHeader'. -addHeader :: Header -> GHandler sub master () -addHeader = GHandler . lift . lift . tell . (:) - -getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.status404 -getStatus (InternalError _) = W.status500 -getStatus (InvalidArgs _) = W.status400 -getStatus (PermissionDenied _) = W.status403 -getStatus (BadMethod _) = W.status405 - -getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.status301 -getRedirectStatus RedirectTemporary = W.status302 -getRedirectStatus RedirectSeeOther = W.status303 - --- | Different types of redirects. -data RedirectType = RedirectPermanent - | RedirectTemporary - | RedirectSeeOther - deriving (Show, Eq) - -localNoCurrent :: GHandler s m a -> GHandler s m a -localNoCurrent = - GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler - --- | Lookup for session data. -lookupSession :: ParamName -> GHandler s m (Maybe ParamValue) -lookupSession n = GHandler $ do - m <- lift $ lift $ lift get - return $ Map.lookup n m - --- | Get all session variables. -getSession :: GHandler s m SessionMap -getSession = GHandler $ lift $ lift $ lift get - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Handler" - [ - ] - -#endif diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs deleted file mode 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.AtomFeed --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating atom news feeds. --- ---------------------------------------------------------- - --- | Generation of Atom newsfeeds. See --- . -module Yesod.Helpers.AtomFeed - ( AtomFeed (..) - , AtomFeedEntry (..) - , atomFeed - , atomLink - , RepAtom (..) - ) where - -import Yesod -import Data.Time.Clock (UTCTime) - -newtype RepAtom = RepAtom Content -instance HasReps RepAtom where - chooseRep (RepAtom c) _ = return (typeAtom, c) - -atomFeed :: AtomFeed (Route master) -> GHandler sub master RepAtom -atomFeed = fmap RepAtom . hamletToContent . template - -data AtomFeed url = AtomFeed - { atomTitle :: String - , atomLinkSelf :: url - , atomLinkHome :: url - , atomUpdated :: UTCTime - , atomEntries :: [AtomFeedEntry url] - } - -data AtomFeedEntry url = AtomFeedEntry - { atomEntryLink :: url - , atomEntryUpdated :: UTCTime - , atomEntryTitle :: String - , atomEntryContent :: Html - } - -template :: AtomFeed url -> Hamlet url -template arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif - -%feed!xmlns="http://www.w3.org/2005/Atom" - %title $atomTitle.arg$ - %link!rel=self!href=@atomLinkSelf.arg@ - %link!href=@atomLinkHome.arg@ - %updated $formatW3.atomUpdated.arg$ - %id @atomLinkHome.arg@ - $forall atomEntries.arg entry - ^entryTemplate.entry^ -|] - -entryTemplate :: AtomFeedEntry url -> Hamlet url -entryTemplate arg = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%entry - %id @atomEntryLink.arg@ - %link!href=@atomEntryLink.arg@ - %updated $formatW3.atomEntryUpdated.arg$ - %title $atomEntryTitle.arg$ - %content!type=html $cdata.atomEntryContent.arg$ -|] - --- | Generates a link tag in the head of a widget. -atomLink :: Route m - -> String -- ^ title - -> GWidget s m () -atomLink u title = addHamletHead -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%link!href=@u@!type="application/atom+xml"!rel="alternate"!title=$title$ -|] diff --git a/Yesod/Helpers/Crud.hs b/Yesod/Helpers/Crud.hs deleted file mode 100644 --- a/Yesod/Helpers/Crud.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Yesod.Helpers.Crud - ( Item (..) - , Crud (..) - , CrudRoute (..) - , defaultCrud - ) where - -import Yesod.Yesod -import Yesod.Widget -import Yesod.Dispatch -import Yesod.Content -import Yesod.Handler -import Text.Hamlet -import Yesod.Form -import Language.Haskell.TH.Syntax - --- | An entity which can be displayed by the Crud subsite. -class Item a where - -- | The title of an entity, to be displayed in the list of all entities. - itemTitle :: a -> String - --- | Defines all of the CRUD operations (Create, Read, Update, Delete) --- necessary to implement this subsite. When using the "Yesod.Form" module and --- 'ToForm' typeclass, you can probably just use 'defaultCrud'. -data Crud master item = Crud - { crudSelect :: GHandler (Crud master item) master [(Key item, item)] - , crudReplace :: Key item -> item -> GHandler (Crud master item) master () - , crudInsert :: item -> GHandler (Crud master item) master (Key item) - , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) - , crudDelete :: Key item -> GHandler (Crud master item) master () - } - -mkYesodSub "Crud master item" - [ ClassP ''Yesod [VarT $ mkName "master"] - , ClassP ''Item [VarT $ mkName "item"] - , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] - , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] - ] -#if GHC7 - [parseRoutes| -#else - [$parseRoutes| -#endif -/ CrudListR GET -/add CrudAddR GET POST -/edit/#String CrudEditR GET POST -/delete/#String CrudDeleteR GET POST -|] - -getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) - => GHandler (Crud master item) master RepHtml -getCrudListR = do - items <- getYesodSub >>= crudSelect - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Items" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Items -%ul - $forall items item - %li - %a!href=@toMaster.CrudEditR.toSinglePiece.fst.item@ - $itemTitle.snd.item$ -%p - %a!href=@toMaster.CrudAddR@ Add new item -|] - -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -getCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - False - -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -postCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - True - -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -getCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - False - -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => String -> GHandler (Crud master item) master RepHtml -postCrudEditR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - True - -getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -getCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Confirm delete" - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%form!method=post!action=@toMaster.CrudDeleteR.s@ - %h1 Really delete? - %p Do you really want to delete $itemTitle.item$? - %p - %input!type=submit!value=Yes - \ $ - %a!href=@toMaster.CrudListR@ No -|] - -postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => String -> GHandler (Crud master item) master RepHtml -postCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - toMaster <- getRouteToMaster - crudDelete crud itemId - redirect RedirectTemporary $ toMaster CrudListR - -itemReadId :: SinglePiece x => String -> Maybe x -itemReadId = either (const Nothing) Just . fromSinglePiece - -crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) - => String -> Maybe (Key a, a) -> Bool - -> GHandler (Crud master a) master RepHtml -crudHelper title me isPost = do - crud <- getYesodSub - (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me - toMaster <- getRouteToMaster - case (isPost, errs) of - (True, FormSuccess a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - _ -> return () - defaultLayout $ do - setTitle $ string title - addWidget -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%p - %a!href=@toMaster.CrudListR@ Return to list -%h1 $title$ -%form!method=post!enctype=$enctype$ - %table - ^form^ - %tr - %td!colspan=2 - $hidden$ - %input!type=submit - $maybe me e - \ $ - %a!href=@toMaster.CrudDeleteR.toSinglePiece.fst.e@ Delete -|] - --- | A default 'Crud' value which relies about persistent and "Yesod.Form". -defaultCrud - :: (PersistEntity i, PersistBackend (YesodDB a (GHandler (Crud a i) a)), - YesodPersist a) - => a -> Crud a i -defaultCrud = const Crud - { crudSelect = runDB $ selectList [] [] 0 0 - , crudReplace = \a -> runDB . replace a - , crudInsert = runDB . insert - , crudGet = runDB . get - , crudDelete = runDB . delete - } diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs deleted file mode 100644 --- a/Yesod/Helpers/Sitemap.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Sitemap --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating Google sitemap files. --- ---------------------------------------------------------- - --- | Generates XML sitemap files. --- --- See . -module Yesod.Helpers.Sitemap - ( sitemap - , robots - , SitemapUrl (..) - , SitemapChangeFreq (..) - ) where - -import Yesod -import Data.Time (UTCTime) - -data SitemapChangeFreq = Always - | Hourly - | Daily - | Weekly - | Monthly - | Yearly - | Never - -showFreq :: SitemapChangeFreq -> String -showFreq Always = "always" -showFreq Hourly = "hourly" -showFreq Daily = "daily" -showFreq Weekly = "weekly" -showFreq Monthly = "monthly" -showFreq Yearly = "yearly" -showFreq Never = "never" - -data SitemapUrl url = SitemapUrl - { sitemapLoc :: url - , sitemapLastMod :: UTCTime - , sitemapChangeFreq :: SitemapChangeFreq - , priority :: Double - } - -template :: [SitemapUrl url] -> Hamlet url -template urls = -#if GHC7 - [xhamlet| -#else - [$xhamlet| -#endif -%urlset!xmlns="http://www.sitemaps.org/schemas/sitemap/0.9" - $forall urls url - %url - %loc @sitemapLoc.url@ - %lastmod $formatW3.sitemapLastMod.url$ - %changefreq $showFreq.sitemapChangeFreq.url$ - %priority $show.priority.url$ -|] - -sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml -sitemap = fmap RepXml . hamletToContent . template - --- | A basic robots file which just lists the "Sitemap: " line. -robots :: Route sub -- ^ sitemap url - -> GHandler sub master RepPlain -robots smurl = do - tm <- getRouteToMaster - render <- getUrlRender - return $ RepPlain $ toContent $ "Sitemap: " ++ render (tm smurl) diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs deleted file mode 100644 --- a/Yesod/Helpers/Static.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} ---------------------------------------------------------- --- --- Module : Yesod.Helpers.Static --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- - --- | Serve static files from a Yesod app. --- --- This is most useful for standalone testing. When running on a production --- server (like Apache), just let the server do the static serving. --- --- In fact, in an ideal setup you'll serve your static files from a separate --- domain name to save time on transmitting cookies. In that case, you may wish --- to use 'urlRenderOverride' to redirect requests to this subsite to a --- separate domain name. -module Yesod.Helpers.Static - ( -- * Subsite - Static (..) - , StaticRoute (..) - -- * Lookup files in filesystem - , fileLookupDir - , staticFiles - -- * Embed files - , mkEmbedFiles - , getStaticHandler - -- * Hashing - , base64md5 -#if TEST - , testSuite -#endif - ) where - -import System.Directory -import Control.Monad -import Data.Maybe (fromMaybe) - -import Yesod hiding (lift) -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Web.Routes - -import qualified Data.ByteString.Lazy as L -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Base64 -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Serialize - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -#endif - --- | A function for looking up file contents. For serving from the file system, --- see 'fileLookupDir'. -data Static = Static - { staticLookup :: FilePath -> IO (Maybe (Either FilePath Content)) - -- | Mapping from file extension to content type. See 'typeByExt'. - , staticTypes :: [(String, ContentType)] - } - --- | Manually construct a static route. --- The first argument is a sub-path to the file being served whereas the second argument is the key value pairs in the query string. --- For example, --- > StaticRoute $ StaticR ["thumb001.jpg"] [("foo", "5"), ("bar", "choc")] --- would generate a url such as 'http://site.com/static/thumb001.jpg?foo=5&bar=choc' --- The StaticRoute constructor can be used when url's cannot be statically generated at compile-time. --- E.g. When generating image galleries. -data StaticRoute = StaticRoute [String] [(String, String)] - deriving (Eq, Show, Read) - -type instance Route Static = StaticRoute - -instance YesodSubSite Static master where - getSubSite = Site - { handleSite = \_ (StaticRoute ps _) m -> - case m of - "GET" -> Just $ fmap chooseRep $ getStaticRoute ps - _ -> Nothing - , formatPathSegments = \(StaticRoute x y) -> (x, y) - , parsePathSegments = \x -> Right $ StaticRoute x [] - } - --- | Lookup files in a specific directory. --- --- If you are just using this in combination with the static subsite (you --- probably are), the handler itself checks that no unsafe paths are being --- requested. In particular, no path segments may begin with a single period, --- so hidden files and parent directories are safe. --- --- For the second argument to this function, you can just use 'typeByExt'. -fileLookupDir :: FilePath -> [(String, ContentType)] -> Static -fileLookupDir dir = Static $ \fp -> do - let fp' = dir ++ '/' : fp - exists <- doesFileExist fp' - if exists - then return $ Just $ Left fp' - else return Nothing - --- | Lookup files in a specific directory, and embed them into the haskell source. --- --- A variation of fileLookupDir which allows subsites distributed via cabal to include --- static content. You can still use staticFiles to generate route identifiers. See getStaticHandler --- for dispatching static content for a subsite. -mkEmbedFiles :: FilePath -> Q Exp -mkEmbedFiles d = do - fs <- qRunIO $ getFileList d - clauses <- mapM (mkClause . intercalate "/") fs - defC <- defaultClause - return $ static $ clauses ++ [defC] - where static clauses = LetE [fun clauses] $ ConE 'Static `AppE` VarE f - f = mkName "f" - fun clauses = FunD f clauses - defaultClause = do - b <- [| return Nothing |] - return $ Clause [WildP] (NormalB b) [] - - mkClause path = do - content <- qRunIO $ readFile $ d ++ '/':path - let pat = LitP $ StringL path - foldAppE = foldl1 AppE - content' = return $ LitE $ StringL $ content - body <- normalB [| return $ Just $ Right $ toContent ($content' :: [Char]) |] - return $ Clause [pat] body [] - --- | Dispatch static route for a subsite --- --- Subsites with static routes can't (yet) define Static routes the same way "master" sites can. --- Instead of a subsite route: --- /static StaticR Static getStatic --- Use a normal route: --- /static/*Strings StaticR GET --- --- Then, define getStaticR something like: --- getStaticR = getStaticHandler ($(mkEmbedFiles "static") typeByExt) StaticR --- */ end CPP comment -getStaticHandler :: Static -> (StaticRoute -> Route sub) -> [String] -> GHandler sub y ChooseRep -getStaticHandler static toSubR pieces = do - toMasterR <- getRouteToMaster - toMasterHandler (toMasterR . toSubR) toSub route handler - where route = StaticRoute pieces [] - toSub _ = static - staticSite = getSubSite :: Site (Route Static) (String -> Maybe (GHandler Static y ChooseRep)) - handler = fromMaybe notFound $ handleSite staticSite undefined route "GET" - -getStaticRoute :: [String] - -> GHandler Static master (ContentType, Content) -getStaticRoute fp' = do - Static fl ctypes <- getYesodSub - when (any isUnsafe fp') notFound - let fp = intercalate "/" fp' - content <- liftIO $ fl fp - case content of - Nothing -> notFound - Just (Left fp'') -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp'') ctypes - sendFile ctype fp'' - Just (Right bs) -> do - let ctype = fromMaybe typeOctet $ lookup (ext fp) ctypes - return (ctype, bs) - where - isUnsafe [] = True - isUnsafe ('.':_) = True - isUnsafe _ = False - -notHidden :: FilePath -> Bool -notHidden ('.':_) = False -notHidden "tmp" = False -notHidden _ = True - -getFileList :: FilePath -> IO [[String]] -getFileList = flip go id - where - go :: String -> ([String] -> [String]) -> IO [[String]] - go fp front = do - allContents <- filter notHidden `fmap` getDirectoryContents fp - let fullPath :: String -> String - fullPath f = fp ++ '/' : f - files <- filterM (doesFileExist . fullPath) allContents - let files' = map (front . return) files - dirs <- filterM (doesDirectoryExist . fullPath) allContents - dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs - return $ concat $ files' : dirs' - --- | This piece of Template Haskell will find all of the files in the given directory and create Haskell identifiers for them. For example, if you have the files \"static\/style.css\" and \"static\/js\/script.js\", it will essentailly create: --- --- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] -staticFiles :: FilePath -> Q [Dec] -staticFiles fp = do - fs <- qRunIO $ getFileList fp - concat `fmap` mapM go fs - where - replace' c - | 'A' <= c && c <= 'Z' = c - | 'a' <= c && c <= 'z' = c - | '0' <= c && c <= '9' = c - | otherwise = '_' - go f = do - let name = mkName $ intercalate "_" $ map (map replace') f - f' <- lift f - let sr = ConE $ mkName "StaticRoute" - hash <- qRunIO $ fmap base64md5 $ L.readFile $ fp ++ '/' : intercalate "/" f - let qs = ListE [TupE [LitE $ StringL hash, ListE []]] - return - [ SigD name $ ConT ''Route `AppT` ConT ''Static - , FunD name - [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] - ] - ] - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Helpers.Static" - [ testCase "get file list" caseGetFileList - ] - -caseGetFileList :: Assertion -caseGetFileList = do - x <- getFileList "test" - x @?= [["foo"], ["bar", "baz"]] - -#endif - --- | md5-hashes the given lazy bytestring and returns the hash as --- base64url-encoded string. --- --- This function returns the first 8 characters of the hash. -base64md5 :: L.ByteString -> String -base64md5 = map go - . take 8 - . S8.unpack - . Data.ByteString.Base64.encode - . Data.Serialize.encode - . md5 - where - go '+' = '-' - go '/' = '_' - go c = c diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs deleted file mode 100644 --- a/Yesod/Internal.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | Normal users should never need access to these. -module Yesod.Internal - ( -- * Error responses - ErrorResponse (..) - -- * Header - , Header (..) - -- * Cookie names - , langKey - -- * Widgets - , Location (..) - , UniqueList (..) - , Script (..) - , Stylesheet (..) - , Title (..) - , Head (..) - , Body (..) - , locationToHamlet - , runUniqueList - , toUnique - -- * UTF8 helpers - , bsToChars - , lbsToChars - , charsToBs - ) where - -import Text.Hamlet (Hamlet, hamlet, Html) -import Data.Monoid (Monoid (..)) -import Data.List (nub) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | Responses to indicate some form of an error occurred. These are different --- from 'SpecialResponse' in that they allow for custom error pages. -data ErrorResponse = - NotFound - | InternalError String - | InvalidArgs [String] - | PermissionDenied String - | BadMethod String - deriving (Show, Eq) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - deriving (Eq, Show) - -langKey :: String -langKey = "_LANG" - -data Location url = Local url | Remote String - deriving (Show, Eq) -locationToHamlet :: Location url -> Hamlet url -locationToHamlet (Local url) = [HAMLET|@url@|] -locationToHamlet (Remote s) = [HAMLET|$s$|] - -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -newtype Script url = Script { unScript :: Location url } - deriving (Show, Eq) -newtype Stylesheet url = Stylesheet { unStylesheet :: Location url } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } - -newtype Head url = Head (Hamlet url) - deriving Monoid -newtype Body url = Body (Hamlet url) - deriving Monoid - -lbsToChars :: L.ByteString -> String -lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode - -bsToChars :: S.ByteString -> String -bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode - -charsToBs :: String -> S.ByteString -charsToBs = T.encodeUtf8 . T.pack diff --git a/Yesod/Json.hs b/Yesod/Json.hs deleted file mode 100644 --- a/Yesod/Json.hs +++ /dev/null @@ -1,140 +0,0 @@ --- | Efficient generation of JSON documents. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Json - ( -- * Monad - Json - , jsonToContent - , jsonToRepJson - -- * Generate Json output - , jsonScalar - , jsonList - , jsonMap - , jsonRaw -#if TEST - , testSuite -#endif - ) - where - -import qualified Data.ByteString.Char8 as S -import Data.Char (isControl) -import Yesod.Handler (GHandler) -import Numeric (showHex) -import Data.Monoid (Monoid (..)) -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char.Utf8 (writeChar) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) -import Data.ByteString.Lazy.Char8 (unpack) -import Yesod.Content hiding (testSuite) -#else -import Yesod.Content -#endif - --- | A monad for generating Json output. It wraps the Builder monoid from the --- blaze-builder package. --- --- 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 = Json { unJson :: Builder } - deriving Monoid - --- | Extract the final result from the given 'Json' value. --- --- See also: applyLayoutJson in "Yesod.Yesod". -jsonToContent :: Json -> GHandler sub master Content -jsonToContent = return . toContent . toLazyByteString . unJson - --- | Wraps the 'Content' generated by 'jsonToContent' in a 'RepJson'. -jsonToRepJson :: Json -> GHandler sub master RepJson -jsonToRepJson = fmap RepJson . jsonToContent - --- | Outputs a single scalar. This function essentially: --- --- * Performs JSON encoding. --- --- * Wraps the resulting string in quotes. -jsonScalar :: String -> Json -jsonScalar s = Json $ mconcat - [ fromByteString "\"" - , fromWriteList writeJsonChar s - , fromByteString "\"" - ] - where - writeJsonChar '\b' = writeByteString "\\b" - writeJsonChar '\f' = writeByteString "\\f" - writeJsonChar '\n' = writeByteString "\\n" - writeJsonChar '\r' = writeByteString "\\r" - writeJsonChar '\t' = writeByteString "\\t" - writeJsonChar '"' = writeByteString "\\\"" - writeJsonChar '\\' = writeByteString "\\\\" - writeJsonChar c - | not $ isControl c = writeChar c - | c < '\x10' = writeString $ '\\' : 'u' : '0' : '0' : '0' : hexxs - | c < '\x100' = writeString $ '\\' : 'u' : '0' : '0' : hexxs - | c < '\x1000' = writeString $ '\\' : 'u' : '0' : hexxs - where hexxs = showHex (fromEnum c) "" - writeJsonChar c = writeChar c - writeString = writeByteString . S.pack - --- | Outputs a JSON list, eg [\"foo\",\"bar\",\"baz\"]. -jsonList :: [Json] -> Json -jsonList [] = Json $ fromByteString "[]" -jsonList (x:xs) = mconcat - [ Json $ fromByteString "[" - , x - , mconcat $ map go xs - , Json $ fromByteString "]" - ] - where - go = mappend (Json $ fromByteString ",") - --- | Outputs a JSON map, eg {\"foo\":\"bar\",\"baz\":\"bin\"}. -jsonMap :: [(String, Json)] -> Json -jsonMap [] = Json $ fromByteString "{}" -jsonMap (x:xs) = mconcat - [ Json $ fromByteString "{" - , go x - , mconcat $ map go' xs - , Json $ fromByteString "}" - ] - where - go' y = mappend (Json $ fromByteString ",") $ go y - go (k, v) = mconcat - [ jsonScalar k - , Json $ fromByteString ":" - , v - ] - --- | Outputs raw JSON data without performing any escaping. Use with caution: --- this is the only function in this module that allows you to create broken --- JSON documents. -jsonRaw :: S.ByteString -> Json -jsonRaw = Json . fromByteString - -#if TEST - -testSuite :: Test -testSuite = testGroup "Yesod.Json" - [ testCase "simple output" caseSimpleOutput - ] - -caseSimpleOutput :: Assertion -caseSimpleOutput = do - let j = do - jsonMap - [ ("foo" , jsonList - [ jsonScalar "bar" - , jsonScalar "baz" - ]) - ] - "{\"foo\":[\"bar\",\"baz\"]}" @=? unpack (toLazyByteString $ unJson j) - -#endif diff --git a/Yesod/Request.hs b/Yesod/Request.hs deleted file mode 100644 --- a/Yesod/Request.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod.Request --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- | Provides a parsed version of the raw 'W.Request' data. --- ---------------------------------------------------------- -module Yesod.Request - ( - -- * Request datatype - RequestBodyContents - , Request (..) - , RequestReader (..) - , FileInfo (..) - -- * Convenience functions - , waiRequest - , languages - -- * Lookup parameters - , lookupGetParam - , lookupPostParam - , lookupCookie - , lookupFile - -- ** Multi-lookup - , lookupGetParams - , lookupPostParams - , lookupCookies - , lookupFiles - -- * Parameter type synonyms - , ParamName - , ParamValue - , ParamError - ) where - -import qualified Network.Wai as W -import qualified Data.ByteString.Lazy as BL -import "transformers" Control.Monad.IO.Class -import Control.Monad (liftM) -import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r -import Data.Maybe (listToMaybe) - -type ParamName = String -type ParamValue = String -type ParamError = String - --- | The reader monad specialized for 'Request'. -class Monad m => RequestReader m where - getRequest :: m Request -instance RequestReader ((->) Request) where - getRequest = id - --- | Get the list of supported languages supplied by the user. --- --- Languages are determined based on the following three (in descending order --- of preference): --- --- * The _LANG get parameter. --- --- * The _LANG cookie. --- --- * The _LANG user session variable. --- --- * Accept-Language HTTP header. --- --- This is handled by the parseWaiRequest function in Yesod.Dispatch (not --- exposed). -languages :: RequestReader m => m [String] -languages = reqLangs `liftM` getRequest - --- | Get the request\'s 'W.Request' value. -waiRequest :: RequestReader m => m W.Request -waiRequest = reqWaiRequest `liftM` getRequest - --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(ParamName, ParamValue)] - , [(ParamName, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: String - , fileContentType :: String - , fileContent :: BL.ByteString - } - deriving (Eq, Show) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(ParamName, ParamValue)] - , reqCookies :: [(ParamName, ParamValue)] - -- | The POST parameters and submitted files. This is stored in an IO - -- thunk, which essentially means it will be computed once at most, but - -- only if requested. This allows avoidance of the potentially costly - -- parsing of POST bodies for pages which do not use them. - , reqRequestBody :: IO RequestBodyContents - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [String] - -- | A random, session-specific nonce used to prevent CSRF attacks. - , reqNonce :: String - } - -lookup' :: Eq a => a -> [(a, b)] -> [b] -lookup' a = map snd . filter (\x -> a == fst x) - --- | Lookup for GET parameters. -lookupGetParams :: RequestReader m => ParamName -> m [ParamValue] -lookupGetParams pn = do - rr <- getRequest - return $ lookup' pn $ reqGetParams rr - --- | Lookup for GET parameters. -lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupGetParam = liftM listToMaybe . lookupGetParams - --- | Lookup for POST parameters. -lookupPostParams :: (MonadIO m, RequestReader m) - => ParamName - -> m [ParamValue] -lookupPostParams pn = do - rr <- getRequest - (pp, _) <- liftIO $ reqRequestBody rr - return $ lookup' pn pp - -lookupPostParam :: (MonadIO m, RequestReader m) - => ParamName - -> m (Maybe ParamValue) -lookupPostParam = liftM listToMaybe . lookupPostParams - --- | Lookup for POSTed files. -lookupFile :: (MonadIO m, RequestReader m) - => ParamName - -> m (Maybe FileInfo) -lookupFile = liftM listToMaybe . lookupFiles - --- | Lookup for POSTed files. -lookupFiles :: (MonadIO m, RequestReader m) - => ParamName - -> m [FileInfo] -lookupFiles pn = do - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr - return $ lookup' pn files - --- | Lookup for cookie data. -lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue) -lookupCookie = liftM listToMaybe . lookupCookies - --- | Lookup for cookie data. -lookupCookies :: RequestReader m => ParamName -> m [ParamValue] -lookupCookies pn = do - rr <- getRequest - return $ lookup' pn $ reqCookies rr diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs deleted file mode 100644 --- a/Yesod/Widget.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} --- | Widgets combine HTML with JS and CSS dependencies with a unique identifier --- generator, allowing you to create truly modular HTML components. -module Yesod.Widget - ( -- * Datatype - GWidget (..) - , liftHandler - -- * Creating - -- ** Head of page - , setTitle - , addHamletHead - , addHtmlHead - -- ** Body - , addHamlet - , addHtml - , addWidget - , addSubWidget - -- ** CSS - , addCassius - , addStylesheet - , addStylesheetRemote - , addStylesheetEither - -- ** Javascript - , addJulius - , addScript - , addScriptRemote - , addScriptEither - -- * Utilities - , extractBody - , newIdent - ) where - -import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Yesod.Handler (Route, GHandler, HandlerData, YesodSubRoute(..), toMasterHandlerMaybe, getYesod) -import Control.Applicative (Applicative) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Class (lift) -import Yesod.Internal - -import Control.Monad.Invert (MonadInvertIO (..)) -import Control.Monad (liftM) -import qualified Data.Map as Map - --- | A generic widget, allowing specification of both the subsite and master --- site datatypes. This is basically a large 'WriterT' stack keeping track of --- dependencies along with a 'StateT' to track unique identifiers. -newtype GWidget s m a = GWidget { unGWidget :: GWInner s m a } - deriving (Functor, Applicative, Monad, MonadIO) -type GWInner sub master = - WriterT (Body (Route master)) ( - WriterT (Last Title) ( - WriterT (UniqueList (Script (Route master))) ( - WriterT (UniqueList (Stylesheet (Route master))) ( - WriterT (Maybe (Cassius (Route master))) ( - WriterT (Maybe (Julius (Route master))) ( - WriterT (Head (Route master)) ( - StateT Int ( - GHandler sub master - )))))))) -instance Monoid (GWidget sub master ()) where - mempty = return () - mappend x y = x >> y -instance MonadInvertIO (GWidget s m) where - newtype InvertedIO (GWidget s m) a = - InvGWidgetIO - { runInvGWidgetIO :: InvertedIO (GWInner s m) a - } - type InvertedArg (GWidget s m) = - (Int, (HandlerData s m, (Map.Map String String, ()))) - invertIO = liftM (fmap InvGWidgetIO) . invertIO . unGWidget - revertIO f = GWidget $ revertIO $ liftM runInvGWidgetIO . f - -instance HamletValue (GWidget s m ()) where - newtype HamletMonad (GWidget s m ()) a = - GWidget' { runGWidget' :: GWidget s m a } - type HamletUrl (GWidget s m ()) = Route m - toHamletValue = runGWidget' - htmlToHamletMonad = GWidget' . addHtml - urlToHamletMonad url params = GWidget' $ - addHamlet $ \r -> preEscapedString (r url params) - fromHamletValue = GWidget' -instance Monad (HamletMonad (GWidget s m ())) where - return = GWidget' . return - x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y - --- | Lift an action in the 'GHandler' monad into an action in the 'GWidget' --- monad. -liftHandler :: GHandler sub master a -> GWidget sub master a -liftHandler = GWidget . lift . lift . lift . lift . lift . lift . lift . lift - -addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub w = do master <- liftHandler getYesod - let sr = fromSubRoute sub master - i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get - w' <- liftHandler $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT - $ unGWidget w - let ((((((((a, - body), - title), - scripts), - stylesheets), - style), - jscript), - h), - i') = w' - GWidget $ do - tell body - lift $ tell title - lift $ lift $ tell scripts - lift $ lift $ lift $ tell stylesheets - lift $ lift $ lift $ lift $ tell style - lift $ lift $ lift $ lift $ lift $ tell jscript - lift $ lift $ lift $ lift $ lift $ lift $ tell h - lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i' - return a - --- | Set the page title. Calling 'setTitle' multiple times overrides previously --- set values. -setTitle :: Html -> GWidget sub master () -setTitle = GWidget . lift . tell . Last . Just . Title - --- | Add a 'Hamlet' to the head tag. -addHamletHead :: Hamlet (Route master) -> GWidget sub master () -addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head - --- | Add a 'Html' to the head tag. -addHtmlHead :: Html -> GWidget sub master () -addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const - --- | Add a 'Hamlet' to the body tag. -addHamlet :: Hamlet (Route master) -> GWidget sub master () -addHamlet = GWidget . tell . Body - --- | Add a 'Html' to the body tag. -addHtml :: Html -> GWidget sub master () -addHtml = GWidget . tell . Body . const - --- | Add another widget. This is defined as 'id', by can help with types, and --- makes widget blocks look more consistent. -addWidget :: GWidget s m () -> GWidget s m () -addWidget = id - --- | Get a unique identifier. -newIdent :: GWidget sub master String -newIdent = GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift $ do - i <- get - let i' = i + 1 - put i' - return $ "w" ++ show i' - --- | Add some raw CSS to the style tag. -addCassius :: Cassius (Route master) -> GWidget sub master () -addCassius = GWidget . lift . lift . lift . lift . tell . Just - --- | Link to the specified local stylesheet. -addStylesheet :: Route master -> GWidget sub master () -addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local - --- | Link to the specified remote stylesheet. -addStylesheetRemote :: String -> GWidget sub master () -addStylesheetRemote = - GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote - -addStylesheetEither :: Either (Route master) String -> GWidget sub master () -addStylesheetEither = either addStylesheet addStylesheetRemote - -addScriptEither :: Either (Route master) String -> GWidget sub master () -addScriptEither = either addScript addScriptRemote - --- | Link to the specified local script. -addScript :: Route master -> GWidget sub master () -addScript = GWidget . lift . lift . tell . toUnique . Script . Local - --- | Link to the specified remote script. -addScriptRemote :: String -> GWidget sub master () -addScriptRemote = - GWidget . lift . lift . tell . toUnique . Script . Remote - --- | Include raw Javascript in the page's script tag. -addJulius :: Julius (Route master) -> GWidget sub master () -addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just - --- | Pull out the HTML tag contents and return it. Useful for performing some --- manipulations. It can be easier to use this sometimes than 'wrapWidget'. -extractBody :: GWidget s m () -> GWidget s m (Hamlet (Route m)) -extractBody (GWidget w) = - GWidget $ mapWriterT (fmap go) w - where - go ((), Body h) = (h, Body mempty) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs deleted file mode 100644 --- a/Yesod/Yesod.hs +++ /dev/null @@ -1,542 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | The basic typeclass for a Yesod application. -module Yesod.Yesod - ( -- * Type classes - Yesod (..) - , YesodSite (..) - , YesodSubSite (..) - -- ** Persistence - , YesodPersist (..) - , module Database.Persist - , get404 - -- ** Breadcrumbs - , YesodBreadcrumbs (..) - , breadcrumbs - -- * Utitlities - , maybeAuthorized - , widgetToPageContent - , defaultLayoutJson - , redirectToPost - -- * Defaults - , defaultErrorHandler - -- * Data types - , AuthResult (..) -#if TEST - , testSuite -#endif - ) where - -#if TEST -import Yesod.Content hiding (testSuite) -import Yesod.Json hiding (testSuite) -import Yesod.Handler hiding (testSuite) -import qualified Data.ByteString.UTF8 as BSU -#else -import Yesod.Content -import Yesod.Json -import Yesod.Handler -#endif - -import Yesod.Widget -import Yesod.Request -import Yesod.Hamlet -import qualified Network.Wai as W -import Yesod.Internal -import Web.ClientSession (getKey, defaultKeyFile) -import qualified Web.ClientSession as CS -import Database.Persist -import Control.Monad.Trans.Class (MonadTrans (..)) -import Control.Failure (Failure) -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Monoid -import Control.Monad.Trans.Writer -import Control.Monad.Trans.State hiding (get) -import Text.Hamlet -import Text.Cassius -import Text.Julius -import Web.Routes - -#if TEST -import Test.Framework (testGroup, Test) -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit hiding (Test) -#endif - -#if GHC7 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class Eq (Route y) => YesodSite y where - getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) -type Method = String - --- | Same as 'YesodSite', but for subsites. Once again, users should not need --- to deal with it directly, as the mkYesodSub creates instances appropriately. -class Eq (Route s) => YesodSubSite s y where - getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite :: s -> Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) - getSiteFromSubSite _ = getSubSite - --- | Define settings for a Yesod applications. The only required setting is --- 'approot'; other than that, there are intelligent defaults. -class Eq (Route a) => Yesod a where - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - -- - -- If you want to be lazy, you can supply an empty string under the - -- following conditions: - -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - approot :: a -> String - - -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO CS.Key - encryptKey _ = getKey defaultKeyFile - - -- | Number of minutes before a client session times out. Defaults to - -- 120 (2 hours). - clientSessionDuration :: a -> Int - clientSessionDuration = const 120 - - -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a ChooseRep - errorHandler = defaultErrorHandler - - -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [HAMLET| -!!! -%html - %head - %title $pageTitle.p$ - ^pageHead.p^ - %body - $maybe mmsg msg - %p.message $msg$ - ^pageBody.p^ -|] - - -- | Gets called at the beginning of each request. Useful for logging. - onRequest :: GHandler sub a () - onRequest = return () - - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe String - urlRenderOverride _ _ = Nothing - - -- | Determine if a request is authorized or not. - -- - -- Return 'Nothing' is the request is authorized, 'Just' a message if - -- unauthorized. If authentication is required, you should use a redirect; - -- the Auth helper provides this functionality automatically. - isAuthorized :: Route a - -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult - isAuthorized _ _ = return Authorized - - -- | Determines whether the current request is a write request. By default, - -- this assumes you are following RESTful principles, and determines this - -- from request method. In particular, all except the following request - -- methods are considered write: GET HEAD OPTIONS TRACE. - -- - -- This function is used to determine if a request is authorized; see - -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool - isWriteRequest _ = do - wai <- waiRequest - return $ not $ W.requestMethod wai `elem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - - -- | The default route for authentication. - -- - -- Used in particular by 'isAuthorized', but library users can do whatever - -- they want with it. - authRoute :: a -> Maybe (Route a) - authRoute _ = Nothing - - -- | A function used to split a raw PATH_INFO value into path pieces. It - -- returns a 'Left' value when you should redirect to the given path, and a - -- 'Right' value on successful parse. - -- - -- By default, it splits paths on slashes, and ensures the following are true: - -- - -- * No double slashes - -- - -- * If the last path segment has a period, there is no trailing slash. - -- - -- * Otherwise, ensures there /is/ a trailing slash. - splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ s = - if corrected == s - then Right $ filter (not . null) - $ decodePathInfo - $ S8.unpack s - else Left corrected - where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s - - -- | Remove double slashes - rds :: String -> String - rds [] = [] - rds [x] = [x] - rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - - -- | Add a trailing slash if it is missing. Empty string is left alone. - ats :: String -> String - ats [] = [] - ats t = - if last t == '/' || dbs (reverse t) - then t - else t ++ "/" - - -- | Remove a trailing slash if the last piece has a period. - rts :: String -> String - rts [] = [] - rts t = - if last t == '/' && dbs (tail $ reverse t) - then init t - else t - - -- | Is there a period before a slash here? - dbs :: String -> Bool - dbs ('/':_) = False - dbs (_:'.':_) = True - dbs (_:x) = dbs x - dbs [] = False - - - -- | Join the pieces of a path together into an absolute URL. This should - -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> [(String, String)] -> String - joinPath _ ar pieces qs = - ar ++ '/' : encodePathInfo (fixSegs pieces) qs - where - fixSegs [] = [] - fixSegs [x] - | anyButLast (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash - fixSegs (x:xs) = x : fixSegs xs - anyButLast _ [] = False - anyButLast _ [_] = False - anyButLast p (x:xs) = p x || anyButLast p xs - - -- | This function is used to store some static content to be served as an - -- external file. The most common case of this is stashing CSS and - -- JavaScript content in an external file; the "Yesod.Widget" module uses - -- this feature. - -- - -- The return value is 'Nothing' if no storing was performed; this is the - -- default implementation. A 'Just' 'Left' gives the absolute URL of the - -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is - -- necessary when you are serving the content outside the context of a - -- Yesod application, such as via memcached. - addStaticContent :: String -- ^ filename extension - -> String -- ^ mime-type - -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) - addStaticContent _ _ _ = return Nothing - - -- | Whether or not to tie a session to a specific IP address. Defaults to - -- 'True'. - sessionIpAddress :: a -> Bool - sessionIpAddress _ = True - -data AuthResult = Authorized | AuthenticationRequired | Unauthorized String - deriving (Eq, Show, Read) - --- | A type-safe, concise method of creating breadcrumbs for pages. For each --- resource, you declare the title of the page and the parent resource (if --- present). -class YesodBreadcrumbs y where - -- | Returns the title and the parent resource, if available. If you return - -- a 'Nothing', then this is considered a top-level page. - breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y)) - --- | Gets the title of the current page and the hierarchy of parent pages, --- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)]) -breadcrumbs = do - x' <- getCurrentRoute - tm <- getRouteToMaster - let x = fmap tm x' - case x of - Nothing -> return ("Not found", []) - Just y -> do - (title, next) <- breadcrumb y - z <- go [] next - return (title, z) - where - go back Nothing = return back - go back (Just this) = do - (title, next) <- breadcrumb this - go ((this, title) : back) next - --- | Provide both an HTML and JSON representation for a piece of data, using --- the default layout for the HTML output ('defaultLayout'). -defaultLayoutJson :: Yesod master - => GWidget sub master () - -> Json - -> GHandler sub master RepHtmlJson -defaultLayoutJson w json = do - RepHtml html' <- defaultLayout w - json' <- jsonToContent json - return $ RepHtmlJson html' json' - -applyLayout' :: Yesod master - => Html -- ^ title - -> Hamlet (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do - setTitle title - addHamlet body - --- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = bsToChars $ W.pathInfo r - applyLayout' "Not Found" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Not Found -%p $path'$ -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Permission denied -%p $msg$ -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Invalid Arguments -%ul - $forall ia msg - %li $msg$ -|] -defaultErrorHandler (InternalError e) = - applyLayout' "Internal Server Error" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Internal Server Error -%p $e$ -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -%h1 Method Not Supported -%p Method "$m$" not supported -|] - -class YesodPersist y where - type YesodDB y :: (* -> *) -> * -> * - runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a - - --- Get the given entity by ID, or return a 404 not found if it doesn't exist. -get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m), - Failure ErrorResponse m, MonadTrans t) - => Key val -> t m val -get404 key = do - mres <- get key - case mres of - Nothing -> lift notFound - Just res -> return res - --- | Return the same URL if the user is authorized to see it. --- --- Built on top of 'isAuthorized'. This is useful for building page that only --- contain links to pages the user is allowed to see. -maybeAuthorized :: Yesod a - => Route a - -> Bool -- ^ is this a write request? - -> GHandler s a (Maybe (Route a)) -maybeAuthorized r isWrite = do - x <- isAuthorized r isWrite - return $ if x == Authorized then Just r else Nothing - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent (GWidget w) = do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - Last mTitle), - scripts'), - stylesheets'), - style), - jscript), - Head head') = w' - let title = maybe mempty unTitle mTitle - let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts' - let stylesheets = map (locationToHamlet . unStylesheet) - $ runUniqueList stylesheets' - let cssToHtml (Css b) = Html b - celper :: Cassius url -> Hamlet url - celper = fmap cssToHtml - jsToHtml (Javascript b) = Html b - jelper :: Julius url -> Hamlet url - jelper = fmap jsToHtml - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - cssLoc <- - case style of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "css" "text/css; charset=utf-8" - $ renderCassius render s - return $ renderLoc x - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ renderJulius render s - return $ renderLoc x - - let head'' = -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -$forall scripts s - %script!src=^s^ -$forall stylesheets s - %link!rel=stylesheet!href=^s^ -$maybe style s - $maybe cssLoc s - %link!rel=stylesheet!href=$s$ - $nothing - %style ^celper.s^ -$maybe jscript j - $maybe jsLoc s - %script!src=$s$ - $nothing - %script ^jelper.j^ -^head'^ -|] - return $ PageContent title head'' body - -#if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Yesod" - [ testProperty "join/split path" propJoinSplitPath - , testCase "join/split path [\".\"]" caseJoinSplitPathDquote - , testCase "utf8 split path" caseUtf8SplitPath - , testCase "utf8 join path" caseUtf8JoinPath - ] - -data TmpYesod = TmpYesod -data TmpRoute = TmpRoute deriving Eq -type instance Route TmpYesod = TmpRoute -instance Yesod TmpYesod where approot _ = "" - -propJoinSplitPath :: [String] -> Bool -propJoinSplitPath ss = - splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - == Right ss' - where - ss' = filter (not . null) ss - -caseJoinSplitPathDquote :: Assertion -caseJoinSplitPathDquote = do - splitPath TmpYesod (BSU.fromString "/x%2E/") @?= Right ["x."] - splitPath TmpYesod (BSU.fromString "/y./") @?= Right ["y."] - joinPath TmpYesod "" ["z."] [] @?= "/z./" - x @?= Right ss - where - x = splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' []) - ss' = filter (not . null) ss - ss = ["a."] - -caseUtf8SplitPath :: Assertion -caseUtf8SplitPath = do - Right ["שלום"] @=? - splitPath TmpYesod (BSU.fromString "/שלום/") - Right ["page", "Fooé"] @=? - splitPath TmpYesod (BSU.fromString "/page/Fooé/") - Right ["\156"] @=? - splitPath TmpYesod (BSU.fromString "/\156/") - Right ["ð"] @=? - splitPath TmpYesod (BSU.fromString "/%C3%B0/") - -caseUtf8JoinPath :: Assertion -caseUtf8JoinPath = do - "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] -#endif - --- | Redirect to a POST resource. --- --- This is not technically a redirect; instead, it returns an HTML page with a --- POST form, and some Javascript to automatically submit the form. This can be --- useful when you need to post a plain link somewhere that needs to cause --- changes on the server. -redirectToPost :: Route master -> GHandler sub master a -redirectToPost dest = hamletToRepHtml -#if GHC7 - [hamlet| -#else - [$hamlet| -#endif -!!! -%html - %head - %title Redirecting... - %body!onload="document.getElementById('form').submit()" - %form#form!method=post!action=@dest@ - %noscript - %p Javascript has been disabled; please click on the button below to be redirected. - %input!type=submit!value=Continue -|] >>= sendResponse diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 --- a/runtests.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Framework (defaultMain) - -import qualified Yesod.Content -import qualified Yesod.Json -import qualified Yesod.Dispatch -import qualified Yesod.Helpers.Static -import qualified Yesod.Yesod -import qualified Yesod.Handler - -main :: IO () -main = defaultMain - [ Yesod.Content.testSuite - , Yesod.Json.testSuite - , Yesod.Dispatch.testSuite - , Yesod.Helpers.Static.testSuite - , Yesod.Yesod.testSuite - , Yesod.Handler.testSuite - ] diff --git a/scaffold.hs b/scaffold.hs --- a/scaffold.hs +++ b/scaffold.hs @@ -18,6 +18,15 @@ qq = "$" #endif +prompt :: (String -> Bool) -> IO String +prompt f = do + s <- getLine + if f s + then return s + else do + putStrLn "That was not a valid entry, please try again: " + prompt f + main :: IO () main = do putStr $(codegen "welcome") @@ -26,7 +35,14 @@ putStr $(codegen "project-name") hFlush stdout - project <- getLine + let validPN c + | 'A' <= c && c <= 'Z' = True + | 'a' <= c && c <= 'z' = True + | '0' <= c && c <= '9' = True + validPN '-' = True + validPN '_' = True + validPN _ = False + project <- prompt $ all validPN putStr $(codegen "dir-name") hFlush stdout @@ -35,11 +51,12 @@ putStr $(codegen "site-arg") hFlush stdout - sitearg <- getLine + let isUpperAZ c = 'A' <= c && c <= 'Z' + sitearg <- prompt $ \s -> not (null s) && all validPN s && isUpperAZ (head s) putStr $(codegen "database") hFlush stdout - backendS <- getLine + backendS <- prompt $ flip elem ["s", "p"] let pconn1 = $(codegen "pconn1") let pconn2 = $(codegen "pconn2") let (lower, upper, connstr1, connstr2) = @@ -63,8 +80,8 @@ mkDir "cassius" mkDir "julius" - writeFile' "simple-server.hs" $(codegen "simple-server_hs") - writeFile' "fastcgi.hs" $(codegen "fastcgi_hs") + writeFile' "test.hs" $(codegen "test_hs") + writeFile' "production.hs" $(codegen "production_hs") writeFile' "devel-server.hs" $(codegen "devel-server_hs") writeFile' (project ++ ".cabal") $(codegen "cabal") writeFile' "LICENSE" $(codegen "LICENSE") diff --git a/scaffold/Controller_hs.cg b/scaffold/Controller_hs.cg --- a/scaffold/Controller_hs.cg +++ b/scaffold/Controller_hs.cg @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Controller ( with~sitearg~ @@ -9,6 +11,7 @@ import Yesod.Helpers.Static import Yesod.Helpers.Auth import Database.Persist.GenericSql +import Data.ByteString (ByteString) -- Import all relevant handler modules here. import Handler.Root @@ -24,7 +27,7 @@ getFaviconR = sendFile "image/x-icon" "favicon.ico" getRobotsR :: Handler RepPlain -getRobotsR = return $ RepPlain $ toContent "User-agent: *" +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) -- This function allocates resources (such as a database connection pool), -- performs initialization and creates a WAI application. This is also the @@ -36,5 +39,5 @@ let h = ~sitearg~ s p toWaiApp h >>= f where - s = fileLookupDir Settings.staticdir typeByExt + s = static Settings.staticdir diff --git a/scaffold/Model_hs.cg b/scaffold/Model_hs.cg --- a/scaffold/Model_hs.cg +++ b/scaffold/Model_hs.cg @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell #-} module Model where import Yesod diff --git a/scaffold/Root_hs.cg b/scaffold/Root_hs.cg --- a/scaffold/Root_hs.cg +++ b/scaffold/Root_hs.cg @@ -14,7 +14,7 @@ getRootR = do mu <- maybeAuth defaultLayout $ do - h2id <- newIdent + h2id <- lift newIdent setTitle "~project~ homepage" addWidget $(widgetFile "homepage") diff --git a/scaffold/Settings_hs.cg b/scaffold/Settings_hs.cg --- a/scaffold/Settings_hs.cg +++ b/scaffold/Settings_hs.cg @@ -24,7 +24,7 @@ import qualified Text.Julius as H import Language.Haskell.TH.Syntax import Database.Persist.~upper~ -import Yesod (MonadInvertIO, addWidget, addCassius, addJulius) +import Yesod (MonadPeelIO, addWidget, addCassius, addJulius) import Data.Monoid (mempty) import System.Directory (doesFileExist) @@ -139,9 +139,9 @@ -- database actions using a pool, respectively. It is used internally -- by the scaffolded application, and therefore you will rarely need to use -- them yourself. -withConnectionPool :: MonadInvertIO m => (ConnectionPool -> m a) -> m a +withConnectionPool :: MonadPeelIO m => (ConnectionPool -> m a) -> m a withConnectionPool = with~upper~Pool connStr connectionCount -runConnectionPool :: MonadInvertIO m => SqlPersist m a -> ConnectionPool -> m a +runConnectionPool :: MonadPeelIO m => SqlPersist m a -> ConnectionPool -> m a runConnectionPool = runSqlPool diff --git a/scaffold/cabal.cg b/scaffold/cabal.cg --- a/scaffold/cabal.cg +++ b/scaffold/cabal.cg @@ -16,43 +16,41 @@ Description: Build the production executable. Default: False -executable simple-server +executable ~project~-test if flag(production) Buildable: False - main-is: simple-server.hs + main-is: test.hs build-depends: base >= 4 && < 5 - , yesod >= 0.6 && < 0.7 - , yesod-auth >= 0.2 && < 0.3 - , mime-mail >= 0.0 && < 0.1 + , yesod >= 0.7 && < 0.8 + , yesod-auth + , yesod-static + , mime-mail , wai-extra , directory , bytestring , text - , persistent >= 0.3.1.1 + , persistent , persistent-~lower~ , template-haskell , hamlet , web-routes - , hjsmin >= 0.0.4 && < 0.1 - ghc-options: -Wall - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies - -executable devel-server - if flag(production) - Buildable: False - else - build-depends: wai-handler-devel >= 0.1.0 && < 0.2 - main-is: devel-server.hs - ghc-options: -Wall -O2 + , hjsmin + , transformers + , warp + ghc-options: -Wall -threaded -executable fastcgi +executable ~project~-production if flag(production) Buildable: True - build-depends: wai-handler-fastcgi >= 0.2.2 && < 0.3 else Buildable: False cpp-options: -DPRODUCTION - main-is: fastcgi.hs + main-is: production.hs ghc-options: -Wall -threaded - extensions: TemplateHaskell, QuasiQuotes, TypeFamilies + +executable ~project~-devel + if flag(production) + Buildable: False + main-is: devel-server.hs + ghc-options: -Wall -O2 -threaded diff --git a/scaffold/default-layout_hamlet.cg b/scaffold/default-layout_hamlet.cg --- a/scaffold/default-layout_hamlet.cg +++ b/scaffold/default-layout_hamlet.cg @@ -1,10 +1,10 @@ !!! -%html - %head - %title $pageTitle.pc$ - ^pageHead.pc^ - %body - $maybe mmsg msg - #message $msg$ - ^pageBody.pc^ +#{pageTitle pc} + ^{pageHead pc} + #{msg} + ^{pageBody pc} diff --git a/scaffold/devel-server_hs.cg b/scaffold/devel-server_hs.cg --- a/scaffold/devel-server_hs.cg +++ b/scaffold/devel-server_hs.cg @@ -1,20 +1,5 @@ -import Network.Wai.Handler.DevelServer (run) -import Control.Concurrent (forkIO) +import Yesod (develServer) main :: IO () -main = do - mapM_ putStrLn - [ "Starting your server process. Code changes will be automatically" - , "loaded as you save your files. Type \"quit\" to exit." - , "You can view your app at http://localhost:3000/" - , "" - ] - _ <- forkIO $ run 3000 "Controller" "with~sitearg~" ["hamlet"] - go - where - go = do - x <- getLine - case x of - 'q':_ -> putStrLn "Quitting, goodbye!" - _ -> go +main = develServer 3000 "Controller" "with~sitearg~" diff --git a/scaffold/fastcgi_hs.cg b/scaffold/fastcgi_hs.cg deleted file mode 100644 --- a/scaffold/fastcgi_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.FastCGI (run) - -main :: IO () -main = with~sitearg~ run - diff --git a/scaffold/favicon_ico.cg b/scaffold/favicon_ico.cg Binary files a/scaffold/favicon_ico.cg and b/scaffold/favicon_ico.cg differ diff --git a/scaffold/homepage_cassius.cg b/scaffold/homepage_cassius.cg --- a/scaffold/homepage_cassius.cg +++ b/scaffold/homepage_cassius.cg @@ -1,5 +1,5 @@ h1 text-align: center -h2#$h2id$ +h2##{h2id} color: #990 diff --git a/scaffold/homepage_hamlet.cg b/scaffold/homepage_hamlet.cg --- a/scaffold/homepage_hamlet.cg +++ b/scaffold/homepage_hamlet.cg @@ -1,13 +1,13 @@ -%h1 Hello -%h2#$h2id$ You do not have Javascript enabled. -$maybe mu u - %p - You are logged in as $userIdent.snd.u$. $ - %a!href=@AuthR.LogoutR@ Logout - \. +

Hello +

You do not have Javascript enabled. +$maybe u <- mu +

Logout + . $nothing - %p - You are not logged in. $ - %a!href=@AuthR.LoginR@ Login now - \. +

Login now + . diff --git a/scaffold/homepage_julius.cg b/scaffold/homepage_julius.cg --- a/scaffold/homepage_julius.cg +++ b/scaffold/homepage_julius.cg @@ -1,4 +1,4 @@ window.onload = function(){ - document.getElementById("%h2id%").innerHTML = "Added from JavaScript."; + document.getElementById("#{h2id}").innerHTML = "Added from JavaScript."; } diff --git a/scaffold/production_hs.cg b/scaffold/production_hs.cg new file mode 100644 --- /dev/null +++ b/scaffold/production_hs.cg @@ -0,0 +1,6 @@ +import Controller (with~sitearg~) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = with~sitearg~ $ run 3000 + diff --git a/scaffold/simple-server_hs.cg b/scaffold/simple-server_hs.cg deleted file mode 100644 --- a/scaffold/simple-server_hs.cg +++ /dev/null @@ -1,6 +0,0 @@ -import Controller -import Network.Wai.Handler.SimpleServer (run) - -main :: IO () -main = putStrLn "Loaded" >> with~sitearg~ (run 3000) - diff --git a/scaffold/sitearg_hs.cg b/scaffold/sitearg_hs.cg --- a/scaffold/sitearg_hs.cg +++ b/scaffold/sitearg_hs.cg @@ -22,7 +22,6 @@ import qualified Settings import System.Directory import qualified Data.ByteString.Lazy as L -import Web.Routes.Site (Site (formatPathSegments)) import Database.Persist.GenericSql import Settings (hamletFile, cassiusFile, juliusFile, widgetFile) import Model @@ -94,11 +93,7 @@ -- This is done to provide an optimization for serving static files from -- a separate domain. Please see the staticroot setting in Settings.hs urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ format s - where - format = formatPathSegments ss - ss :: Site StaticRoute (String -> Maybe (GHandler Static ~sitearg~ ChooseRep)) - ss = getSubSite + Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. @@ -126,7 +121,8 @@ -- How to run database actions. instance YesodPersist ~sitearg~ where type YesodDB ~sitearg~ = SqlPersist - runDB db = fmap connPool getYesod >>= Settings.runConnectionPool db + runDB db = liftIOHandler + $ fmap connPool getYesod >>= Settings.runConnectionPool db instance YesodAuth ~sitearg~ where type AuthId ~sitearg~ = UserId @@ -179,17 +175,19 @@ , "" , "Thank you" ] + , partHeaders = [] } htmlPart = Part { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing , partContent = renderHtml [~qq~hamlet| -%p Please confirm your email address by clicking on the link below. -%p - %a!href=$verurl$ $verurl$ -%p Thank you +

Please confirm your email address by clicking on the link below. +

+ Thank you |] + , partHeaders = [] } getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get setVerifyKey eid key = runDB $ update eid [EmailVerkey $ Just key] diff --git a/scaffold/test_hs.cg b/scaffold/test_hs.cg new file mode 100644 --- /dev/null +++ b/scaffold/test_hs.cg @@ -0,0 +1,11 @@ +import Controller (with~sitearg~) +import System.IO (hPutStrLn, stderr) +import Network.Wai.Middleware.Debug (debug) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = do + let port = 3000 + hPutStrLn stderr $ "Application launched, listening on port " ++ show port + with~sitearg~ $ run port . debug + diff --git a/yesod.cabal b/yesod.cabal --- a/yesod.cabal +++ b/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 0.6.7 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -16,97 +16,51 @@ homepage: http://docs.yesodweb.com/ extra-source-files: scaffold/*.cg -flag test - description: Build the executable to run unit tests - default: False - flag ghc7 library if flag(ghc7) - build-depends: base >= 4.3 && < 5 + build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else - build-depends: base >= 4 && < 4.3 - build-depends: time >= 1.1.4 && < 1.3 - , wai >= 0.2.0 && < 0.3 - , wai-extra >= 0.2.4 && < 0.3 - , bytestring >= 0.9.1.4 && < 0.10 - , directory >= 1 && < 1.2 - , text >= 0.5 && < 0.12 - , template-haskell >= 2.4 && < 2.6 - , web-routes-quasi >= 0.6.2 && < 0.7 - , hamlet >= 0.5.1 && < 0.7 - , blaze-builder >= 0.2.1 && < 0.3 + build-depends: base >= 4 && < 4.3 + , wai-handler-devel >= 0.2 && < 0.3 + build-depends: yesod-core >= 0.7 && < 0.8 + , yesod-auth >= 0.3 && < 0.4 + , yesod-json >= 0.0 && < 0.1 + , yesod-persistent >= 0.0 && < 0.1 + , yesod-static >= 0.0 && < 0.1 + , yesod-form >= 0.0 && < 0.1 + , monad-peel >= 0.1 && < 0.2 , transformers >= 0.2 && < 0.3 - , clientsession >= 0.4.0 && < 0.5 - , pureMD5 >= 1.1.0.0 && < 2.2 - , random >= 1.0.0.2 && < 1.1 - , cereal >= 0.2 && < 0.4 - , base64-bytestring >= 0.1 && < 0.2 - , old-locale >= 1.0.0.2 && < 1.1 - , persistent >= 0.3.0 && < 0.4 - , neither >= 0.1.0 && < 0.2 - , network >= 2.2.1.5 && < 2.4 - , email-validate >= 0.2.5 && < 0.3 - , web-routes >= 0.23 && < 0.24 - , xss-sanitize >= 0.2.3 && < 0.3 - , data-default >= 0.2 && < 0.3 - , failure >= 0.1 && < 0.2 - , containers >= 0.2 && < 0.5 + , wai >= 0.3 && < 0.4 + , wai-extra >= 0.3 && < 0.4 + , hamlet >= 0.7 && < 0.8 + , warp >= 0.3 && < 0.4 + , mime-mail >= 0.1 && < 0.2 + , hjsmin >= 0.0.12 && < 0.1 + , attoparsec-text >= 0.8 && < 0.9 exposed-modules: Yesod - Yesod.Content - Yesod.Dispatch - Yesod.Form - Yesod.Form.Core - Yesod.Form.Jquery - Yesod.Form.Nic - Yesod.Hamlet - Yesod.Handler - Yesod.Json - Yesod.Request - Yesod.Widget - Yesod.Yesod - Yesod.Helpers.AtomFeed - Yesod.Helpers.Crud - Yesod.Helpers.Sitemap - Yesod.Helpers.Static - other-modules: Yesod.Form.Class - Yesod.Internal - Yesod.Form.Fields - Yesod.Form.Profiles ghc-options: -Wall executable yesod if flag(ghc7) - build-depends: base >= 4.3 && < 5 + build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 else - build-depends: base >= 4 && < 4.3 - build-depends: parsec >= 2.1 && < 4 + build-depends: base >= 4 && < 4.3 + build-depends: parsec >= 2.1 && < 4 + , text >= 0.11 && < 0.12 + , bytestring >= 0.9 && < 0.10 + , time >= 1.1.4 && < 1.3 + , template-haskell + , directory >= 1.0 && < 1.2 ghc-options: -Wall main-is: scaffold.hs other-modules: CodeGen extensions: TemplateHaskell - -executable runtests if flag(ghc7) - build-depends: base >= 4.3 && < 5 cpp-options: -DGHC7 - else - build-depends: base >= 4 && < 4.3 - if flag(test) - Buildable: True - cpp-options: -DTEST - build-depends: test-framework, - test-framework-quickcheck2, - test-framework-hunit, - HUnit, - QuickCheck >= 2 && < 3 - else - Buildable: False - ghc-options: -Wall - main-is: runtests.hs source-repository head type: git