diff --git a/Yesod.hs b/Yesod.hs index 32272254..124c83d4 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -15,7 +15,7 @@ module Yesod ( module Yesod.Request , module Yesod.Response - , module Yesod.Application + , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler , module Yesod.Resource @@ -24,7 +24,7 @@ module Yesod import Yesod.Request import Yesod.Response -import Yesod.Application +import Yesod.Yesod import Yesod.Definitions import Yesod.Handler import Yesod.Resource diff --git a/Yesod/Application.hs b/Yesod/Application.hs deleted file mode 100644 index e2907a94..00000000 --- a/Yesod/Application.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} ---------------------------------------------------------- --- --- Module : Yesod.Application --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Defining the application. --- ---------------------------------------------------------- -module Yesod.Application - ( - toHackApp - , RestfulApp (..) - ) where - -import Web.Encodings -import Data.Enumerable -import Control.Monad (when) -import Data.Object.Html - -import qualified Hack -import Hack.Middleware.CleanPath -import Hack.Middleware.ClientSession -import Hack.Middleware.Gzip -import Hack.Middleware.Jsonp -import Hack.Middleware.MethodOverride - -import Yesod.Request -import Yesod.Response -import Yesod.Utils -import Yesod.Handler -import Yesod.Definitions -import Yesod.Constants -import Yesod.Resource -import Yesod.Rep - -import Data.Convertible.Text -import Control.Arrow ((***)) - --- | A data type that can be turned into a Hack application. -class ResourceName a => RestfulApp a where - -- | The encryption key to be used for encrypting client sessions. - encryptKey :: a -> IO Word256 - encryptKey _ = getKey defaultKeyFile - - -- | All of the middlewares to install. - hackMiddleware :: a -> [Hack.Middleware] - hackMiddleware _ = - [ gzip - , cleanPath - , jsonp - , methodOverride - ] - - -- | Output error response pages. - errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig? - - -- | Whether or not we should check for overlapping resource names. - checkOverlaps :: a -> Bool - checkOverlaps = const True - --- | Given a sample resource name (purely for typing reasons), generating --- a Hack application. -toHackApp :: RestfulApp resourceName - => resourceName - -> IO Hack.Application -toHackApp a = do - when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? - key <- encryptKey a - let app' = toHackApplication a getHandler - clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... - app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] - return app - -findResourceNames :: ResourceName a - => Resource - -> [(a, [(String, String)])] -findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate - -checkPatternHelper :: ResourceName a - => Resource - -> a - -> Maybe (a, [(String, String)]) -checkPatternHelper r rn = - case checkPattern (fromString $ resourcePattern rn) r of - Nothing -> Nothing - Just pairs -> Just (rn, pairs) - -takeJusts :: [Maybe a] -> [a] -takeJusts [] = [] -takeJusts (Nothing:rest) = takeJusts rest -takeJusts (Just x:rest) = x : takeJusts rest - -toHackApplication :: RestfulApp resourceName - => resourceName - -> (resourceName -> Verb -> Handler resourceName [(ContentType, Content)]) - -> Hack.Application -toHackApplication sampleRN hm env = do - -- The following is safe since we run cleanPath as middleware - let (Right resource) = splitPath $ Hack.pathInfo env - let (handler, urlParams') = - case findResourceNames resource of - [] -> (notFound, []) - ((rn, urlParams''):_) -> - let verb = toVerb $ Hack.requestMethod env - in (hm rn verb, urlParams'') - let rr = envToRawRequest urlParams' env - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept - r <- - runHandler handler rr sampleRN ctypes' >>= - either (applyErrorHandler sampleRN rr ctypes') return - responseToHackResponse (rawLanguages rr) r - -applyErrorHandler :: (RestfulApp ra, Monad m) - => ra - -> RawRequest - -> [ContentType] - -> (ErrorResult, [Header]) - -> m Response -applyErrorHandler ra rr cts (er, headers) = do - let (ct, c) = chooseRep (errorHandler ra rr er) cts - return $ Response - (getStatus er) - (getHeaders er ++ headers) - ct - c - -responseToHackResponse :: [String] -- ^ language list - -> Response -> IO Hack.Response -responseToHackResponse _FIXMEls (Response sc hs ct c) = do - hs' <- mapM toPair hs - let hs'' = ("Content-Type", show ct) : hs' - let asLBS = unContent c - return $ Hack.Response sc hs'' asLBS - -envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest -envToRawRequest urlParams' env = - let (Right rawPieces) = splitPath $ Hack.pathInfo env - gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] - clength = tryLookup "0" "Content-Length" $ Hack.http env - ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = map (convertSuccess *** convertSuccess) *** - map (convertSuccess *** convertFileInfo) - $ parsePost ctype clength - $ Hack.hackInput env - rawCookie = tryLookup "" "Cookie" $ Hack.http env - cookies' = decodeCookies rawCookie :: [(String, String)] - langs = ["en"] -- FIXME - in RawRequest rawPieces urlParams' gets' posts cookies' files env langs - -convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c -convertFileInfo (FileInfo a b c) = - FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index e3cc3a12..43f38aec 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} --------------------------------------------------------- -- -- Module : Yesod.Definitions @@ -15,22 +14,22 @@ --------------------------------------------------------- module Yesod.Definitions ( Verb (..) - , toVerb , Resource , Approot (..) , Language ) where import qualified Hack +import Data.Convertible.Text data Verb = Get | Put | Delete | Post deriving (Eq, Show) -toVerb :: Hack.RequestMethod -> Verb -toVerb Hack.PUT = Put -toVerb Hack.DELETE = Delete -toVerb Hack.POST = Post -toVerb _ = Get +instance ConvertSuccess Hack.RequestMethod Verb where + convertSuccess Hack.PUT = Put + convertSuccess Hack.DELETE = Delete + convertSuccess Hack.POST = Post + convertSuccess _ = Get type Resource = [String] diff --git a/Yesod/Request.hs b/Yesod/Request.hs index a25ed720..515f0388 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} -- Parameter String --------------------------------------------------------- -- -- Module : Yesod.Request @@ -56,6 +57,9 @@ import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) import qualified Data.ByteString.Lazy as BL +import Data.Convertible.Text +import Hack.Middleware.CleanPath (splitPath) +import Control.Arrow ((***)) -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -319,3 +323,19 @@ notBlank rp = case paramValue rp of "" -> invalidParam (paramType rp) (paramName rp) "Required field" s -> return s + +instance ConvertSuccess ([(ParamName, ParamValue)], Hack.Env) RawRequest where + convertSuccess (urlParams', env) = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = tryLookup "0" "Content-Length" $ Hack.http env + ctype = tryLookup "" "Content-Type" $ Hack.http env + convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c + (posts, files) = map (convertSuccess *** convertSuccess) *** + map (convertSuccess *** convertFileInfo) + $ parsePost ctype clength + $ Hack.hackInput env + rawCookie = tryLookup "" "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 024f5a20..03a89f9a 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -4,6 +4,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Yesod.Resource @@ -18,9 +20,8 @@ -- --------------------------------------------------------- module Yesod.Resource - ( ResourceName (..) - , ResourcePatternString - , fromString + ( ResourcePatternString -- FIXME rename + , fromString -- FIXME rename , checkPattern , validatePatterns , checkResourceName @@ -32,16 +33,12 @@ module Yesod.Resource import Data.List.Split (splitOn) import Yesod.Definitions -import Yesod.Handler import Data.List (intercalate) -import Data.Enumerable import Data.Char (isDigit) -#if TEST -import Yesod.Rep hiding (testSuite) -#else -import Yesod.Rep -#endif +import Data.Typeable (Typeable) +import Control.Exception (Exception) +import Data.Attempt -- for failure stuff #if TEST import Control.Monad (replicateM, when) @@ -83,18 +80,6 @@ fromString' ('*':rest) = Slurp rest fromString' ('#':rest) = DynInt rest fromString' x = Static x -class (Show a, Enumerable a) => ResourceName a where - -- | Get the URL pattern for each different resource name. - -- Something like /foo/$bar/baz/ will match the regular expression - -- /foo/(\\w*)/baz/, matching the middle part with the urlParam bar. - -- - -- Also, /foo/\*bar/ will match /foo/, capturing the value - -- into the bar urlParam. - resourcePattern :: a -> String - - -- | Find the handler for each resource name/verb pattern. - getHandler :: a -> Verb -> Handler a [(ContentType, Content)] -- FIXME - type ResourcePatternString = String type SMap = [(String, String)] @@ -150,14 +135,19 @@ overlaps (Static s:x) (DynInt _:y) | otherwise = False overlaps (Static a:x) (Static b:y) = a == b && overlaps x y -checkResourceName :: (Monad m, ResourceName rn) => rn -> m () -checkResourceName rn = do - let avs@(y:_) = enumerate - _ignore = asTypeOf rn y - let patterns = map (fromString . resourcePattern) avs - case validatePatterns patterns of +data OverlappingPatterns = + OverlappingPatterns [(ResourcePattern, ResourcePattern)] + deriving (Show, Typeable) +instance Exception OverlappingPatterns + +checkResourceName :: MonadFailure OverlappingPatterns f + => [ResourcePatternString] + -> f () +checkResourceName patterns' = + let patterns = map fromString patterns' + in case validatePatterns patterns of [] -> return () - x -> fail $ "Overlapping patterns:\n" ++ unlines (map show x) + x -> failure $ OverlappingPatterns x validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] validatePatterns [] = [] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 83a6d64a..a8e5af05 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -13,7 +13,11 @@ import Yesod.Definitions import Yesod.Resource import Yesod.Handler ---import Control.Monad (when) +import Control.Monad (when) +import Data.Maybe (fromMaybe) +import Data.Convertible.Text +import Web.Encodings +import Control.Arrow ((***)) import qualified Hack import Hack.Middleware.CleanPath @@ -33,15 +37,6 @@ class Yesod a where encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile - -- | All of the middlewares to install. - hackMiddleware :: a -> [Hack.Middleware] - hackMiddleware _ = - [ gzip - , cleanPath - , jsonp - , methodOverride - ] - -- | Output error response pages. errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair errorHandler = defaultErrorHandler @@ -74,14 +69,72 @@ defaultErrorHandler (InternalError e) cts = [ ("Internal server error", e) ]) cts +-- | For type signature reasons. +handlers' :: Yesod y => y -> + [(ResourcePatternString, + [(Verb, [ContentType] -> Handler y ContentPair)])] +handlers' _ = handlers + toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do - -- FIXME when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? + let patterns = map fst $ handlers' a + when (checkOverlaps a) $ checkResourceName patterns -- FIXME maybe this should be done compile-time? key <- encryptKey a let app' = toHackApp' a - clientsession' = clientsession [authCookieName] key -- FIXME gotta be a better way... - app = foldr ($) app' $ hackMiddleware a ++ [clientsession'] + middleware = + [ gzip + , cleanPath + , jsonp + , methodOverride + , clientsession [authCookieName] key + ] + app = foldr ($) app' middleware app env toHackApp' :: Yesod y => y -> Hack.Application -toHackApp' = undefined -- FIXME +toHackApp' y env = do + let (Right resource) = splitPath $ Hack.pathInfo env + types = httpAccept env + (handler, urlParams') = fromMaybe (notFound, []) $ do + (verbPairs, urlParams'') <- lookupHandlers resource + let verb = cs $ Hack.requestMethod env + handler'' <- lookup verb verbPairs + return (handler'' types, urlParams'') + rr = envToRawRequest urlParams' env + runHandler' handler rr y + +httpAccept :: Hack.Env -> [ContentType] +httpAccept = undefined + +lookupHandlers :: Yesod y + => Resource + -> Maybe + ( [(Verb, [ContentType] -> Handler y ContentPair)] + , [(ParamName, ParamValue)] + ) +lookupHandlers = undefined + +runHandler' :: Yesod y + => Handler y ContentPair + -> RawRequest + -> y + -> IO Hack.Response +runHandler' = undefined + +envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest +envToRawRequest urlParams' env = + let (Right rawPieces) = splitPath $ Hack.pathInfo env + gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] + clength = fromMaybe "0" $ lookup "Content-Length" $ Hack.http env + ctype = fromMaybe "" $ lookup "Content-Type" $ Hack.http env + (posts, files) = map (cs *** cs) *** map (cs *** convertFileInfo) + $ parsePost ctype clength + $ Hack.hackInput env + rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env + cookies' = decodeCookies rawCookie :: [(String, String)] + langs = ["en"] -- FIXME + in RawRequest rawPieces urlParams' gets' posts cookies' files env langs + +convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c +convertFileInfo (FileInfo a b c) = + FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/yesod.cabal b/yesod.cabal index e4982fa0..3bff64b1 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -51,7 +51,6 @@ library Yesod.Utils Yesod.Definitions Yesod.Handler - Yesod.Application Yesod.Resource Yesod.Yesod Data.Object.Html