Removed Yesod.Application; still have some undefineds
This commit is contained in:
Michael Snoyman
parent
ac54b644bc
commit
52f5ab2374
4
Yesod.hs
4
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
|
||||
|
||||
@ -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 <michael@snoyman.com>
|
||||
-- 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
|
||||
@ -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]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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/<anything else>, 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 [] = []
|
||||
|
||||
@ -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
|
||||
|
||||
@ -51,7 +51,6 @@ library
|
||||
Yesod.Utils
|
||||
Yesod.Definitions
|
||||
Yesod.Handler
|
||||
Yesod.Application
|
||||
Yesod.Resource
|
||||
Yesod.Yesod
|
||||
Data.Object.Html
|
||||
|
||||
Loading…
Reference in New Issue
Block a user