diff --git a/.gitignore b/.gitignore index 39b806f8..678893b5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ dist *.swp +*.hi +*.o diff --git a/README.md b/README.md index 21c4cc8d..6b699ebc 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,11 @@ clearly do not want to write code twice to process these requests. Instead, convert the article name into a URL parameter and then articles will have its own ResourceName. +### ResourceParser + +A ResourceParser converts a Resource (ie, a URL) to a ResourceName and URL +parameters. + ## RawRequest The parsed data sent from the client. Has, for example, GET and POST @@ -83,6 +88,15 @@ in different ways. There is a single Handler for each combination of ResourceName and Verb. A Handler takes some instance of Request and returns a Response. +### HandlerMap + +Maps a ResourceName/Verb pair to a Handler. + +## Application + +An application is essentially a ResourceParser and HandlerMap. It also has some +settings involved. + # Static files All static files should go under the /static/ path. A typical application will @@ -94,3 +108,8 @@ Restful API. Search engines nad older clients should not be ignored. However, it is quite tedious to write view code twice. Hopefully, in the future there will be a view component to this framework which can automate some of that process. + +# Passing global data + +You should use function currying to pass around global information (the list of +entries in a blog, a database connection, etc). diff --git a/Web/Restful.hs b/Web/Restful.hs index f4925cad..c2878f2c 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -17,9 +17,11 @@ module Web.Restful , module Web.Restful.Request , module Web.Restful.Response , module Web.Restful.Application + , module Web.Restful.Definitions ) where import Data.Object import Web.Restful.Request import Web.Restful.Response import Web.Restful.Application +import Web.Restful.Definitions diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index dc9679fa..f03f3d43 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Web.Restful.Application @@ -22,10 +23,12 @@ module Web.Restful.Application -- ** Settings , setHandler , setRpxnowApiKey - , setUrlRewriter + , setResourceParser , setHtmlWrapper -- ** Engage , run + -- * FIXME + , Application (..) ) where -- hideously long import list @@ -56,31 +59,33 @@ import Web.Restful.Request import Web.Restful.Response import Web.Restful.Constants import Web.Restful.Utils +import Web.Restful.Handler +import Web.Restful.Definitions import Data.Object -- | Contains settings and a list of resources. -type ApplicationMonad = StateT ApplicationSettings (Writer [Resource]) -instance Applicative ApplicationMonad where +type ApplicationMonad a = StateT (ApplicationSettings a) (Writer (HandlerMap a)) +instance Applicative (ApplicationMonad a) where pure = return f <*> a = do f' <- f a' <- a return $! f' a' -data ApplicationSettings = ApplicationSettings +data ApplicationSettings rn = ApplicationSettings { hackHandler :: Hack.Application -> IO () , rpxnowApiKey :: Maybe String , encryptKey :: Either FilePath Word256 - , urlRewriter :: UrlRewriter + , appResourceParser :: ResourceParser rn , hackMiddleware :: [Hack.Middleware] , response404 :: Hack.Env -> IO Hack.Response , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance Default ApplicationSettings where +instance ResourceName a => Default (ApplicationSettings a) where def = ApplicationSettings { hackHandler = Hack.Handler.CGI.run , rpxnowApiKey = Nothing , encryptKey = Left defaultKeyFile - , urlRewriter = \s -> (s, []) + , appResourceParser = \s -> ParsedResource (toResourceName s) [] , hackMiddleware = [ gzip , cleanPath @@ -98,44 +103,32 @@ default404 env = return $ [("Content-Type", "text/plain")] $ toLazyByteString $ "Not found: " ++ Hack.pathInfo env -data Handler = forall req res. (Request req, Response res) - => Handler (req -> IO res) -type LiftedHandler = RawRequest -> IO ResponseWrapper - -liftHandler :: - Handler - -> RawRequest - -> IO ResponseWrapper -liftHandler (Handler h) rr = do - case runRequestParser parseRequest rr of - Left errors -> return $ ResponseWrapper - $ ErrorResponse - $ unlines errors - Right req -> ResponseWrapper `fmap` h req - -data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler - -- FIXME document below here -addResource :: (Request req, Response res) - => [Hack.RequestMethod] - -> PathInfo +addResource :: (Request req, Response res, ResourceName rn) + => Verb + -> rn -> (req -> IO res) - -> ApplicationMonad () -addResource methods path f = - tell [Resource methods path $ liftHandler $ Handler f] + -> ApplicationMonad rn () +addResource verb resourceName' f = do + let handler :: Handler + handler = Handler $ (fmap ResponseWrapper) . f + handlerDesc = HandlerDesc resourceName' verb handler + tell [handlerDesc] -setUrlRewriter :: UrlRewriter -> ApplicationMonad () -setUrlRewriter newUrlRewriter = do +setResourceParser :: ResourceName rn + => ResourceParser rn + -> ApplicationMonad rn () +setResourceParser newRP = do s <- get - put $ s { urlRewriter = newUrlRewriter } + put $ s { appResourceParser = newRP } -setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad () +setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad a () setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -run :: ApplicationMonad () -> IO () +run :: ResourceName a => ApplicationMonad a () -> IO () run m = do let (settings, resources') = runWriter $ execStateT m def key <- case encryptKey settings of @@ -143,36 +136,38 @@ run m = do Right k -> return k let defApp = defaultResources settings defResources = execWriter $ execStateT defApp def - resources = resources' ++ defResources + resources = resources' ++ defResources -- FIXME rename HandlerDescs app' :: Hack.Application - app' = makeApplication' resources settings + app' = toHackApplication $ Application resources settings clientsession' :: Hack.Middleware clientsession' = clientsession [authCookieName] key app :: Hack.Application app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] hackHandler settings app -setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad () +setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad a () setHandler h = do settings <- get put $ settings { hackHandler = h } -setRpxnowApiKey :: String -> ApplicationMonad () +setRpxnowApiKey :: String -> ApplicationMonad a () setRpxnowApiKey k = do settings <- get put $ settings { rpxnowApiKey = Just k } -defaultResources :: ApplicationSettings -> ApplicationMonad () +defaultResources :: ResourceName rn + => ApplicationSettings rn + -> ApplicationMonad rn () defaultResources settings = do - addResource [Hack.GET] ["auth", "check"] authCheck - addResource [Hack.GET] ["auth", "logout"] authLogout - addResource [Hack.GET] ["auth", "openid"] authOpenidForm - addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward - addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete + addResource Get (toResourceName ["auth", "check"]) authCheck + addResource Get (toResourceName ["auth", "logout"]) authLogout + addResource Get (toResourceName ["auth", "openid"]) authOpenidForm + addResource Get (toResourceName ["auth", "openid", "forward"]) authOpenidForward + addResource Get (toResourceName ["auth", "openid", "complete"]) authOpenidComplete case rpxnowApiKey settings of Nothing -> return () Just key -> do - addResource [Hack.GET] ["auth", "login", "rpxnow"] $ + addResource Get (toResourceName ["auth", "login", "rpxnow"]) $ rpxnowLogin key data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) @@ -314,22 +309,24 @@ instance Response LogoutResponse where Hack.Response s (h':h) c h' = resetCookie authCookieName -makeApplication' :: [Resource] - -> ApplicationSettings - -> Hack.Env - -> IO Hack.Response -makeApplication' resources settings env = do - let method = Hack.requestMethod env - rr = envToRawRequest (urlRewriter settings) env - path' = rawPathInfo rr - isValid :: Resource -> Bool - isValid (Resource methods path _) = method `elem` methods - && path == path' - case filter isValid resources of - [Resource _ _ handler] -> do +toHackApplication :: Eq resourceName + => Application resourceName + -> Hack.Application +toHackApplication (Application hm settings) env = do + let (Right resource) = splitPath $ Hack.pathInfo env + (ParsedResource rn urlParams') = (appResourceParser settings) resource + verb :: Verb + verb = toVerb $ Hack.requestMethod env + rr :: RawRequest + rr = envToRawRequest urlParams' env + matchingHandler (HandlerDesc resourceName' verb' _) = + rn == resourceName' && + verb == verb' + case filter matchingHandler hm of + [HandlerDesc _ _ handler] -> do let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept - body <- handler rr + body <- runHandler handler rr let reps' = reps body ctypes = filter (\c -> isJust $ lookup c reps') ctypes' let handlerPair = @@ -351,13 +348,11 @@ makeApplication' resources settings env = do (("Content-Type", ctype) : headers) $ toLazyByteString $ wrapper content [] -> response404 settings $ env - _ -> fail "Overlapping handlers" + _ -> fail $ "Overlapping handlers for: " ++ show env -type UrlRewriter = PathInfo -> (PathInfo, [(String, String)]) -envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest -envToRawRequest rewriter env = +envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest +envToRawRequest urlParams' env = let (Right rawPieces) = splitPath $ Hack.pathInfo env - (pi', urls) = rewriter rawPieces gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] clength = tryLookup "0" "Content-Length" $ Hack.http env ctype = tryLookup "" "Content-Type" $ Hack.http env @@ -365,4 +360,9 @@ envToRawRequest rewriter env = $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest pi' urls gets' posts cookies' files env + in RawRequest rawPieces urlParams' gets' posts cookies' files env + +data Application a = Application + { handlerMap :: HandlerMap a + , applicationSettings :: ApplicationSettings a + } diff --git a/Web/Restful/Constants.hs b/Web/Restful/Constants.hs index c39aa532..e6445b54 100644 --- a/Web/Restful/Constants.hs +++ b/Web/Restful/Constants.hs @@ -11,7 +11,9 @@ -- Constants used throughout Restful. -- --------------------------------------------------------- -module Web.Restful.Constants where +module Web.Restful.Constants + ( authCookieName + ) where authCookieName :: String authCookieName = "IDENTIFIER" diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs new file mode 100644 index 00000000..f96ca895 --- /dev/null +++ b/Web/Restful/Definitions.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Definitions +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Definitions throughout Restful. +-- +--------------------------------------------------------- +module Web.Restful.Definitions + ( Verb (..) + , toVerb + , Resource + , ParsedResource (..) + , ResourceParser + , ResourceName (..) + ) where + +import qualified Hack + +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 + +type Resource = [String] + +class Eq a => ResourceName a where + toResourceName :: [String] -> a +instance ResourceName [String] where + toResourceName = id + +data ParsedResource a = ParsedResource + { resourceName :: a + , urlParameters :: [(String, String)] + } + +type ResourceParser a = Resource -> ParsedResource a diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs new file mode 100644 index 00000000..100440ad --- /dev/null +++ b/Web/Restful/Handler.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ExistentialQuantification #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Handler +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : unstable +-- Portability : portable +-- +-- Define Handler stuff. +-- +--------------------------------------------------------- +module Web.Restful.Handler + ( Handler (..) + , runHandler + , HandlerMap + , HandlerDesc (..) + ) where + +import Web.Restful.Definitions +import Web.Restful.Request +import Web.Restful.Response + +data Handler = forall req. Request req => Handler (req -> IO ResponseWrapper) + +runHandler :: Handler -> RawRequest -> IO ResponseWrapper +runHandler (Handler f) rreq = do + let rparser = parseRequest + case runRequestParser rparser rreq of + Left errors -> fail $ unlines errors -- FIXME + Right req -> f req + +data HandlerDesc a = HandlerDesc a Verb Handler +type HandlerMap a = [HandlerDesc a] diff --git a/restful.cabal b/restful.cabal index dacf32c7..7a10957a 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.0.0 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -35,5 +35,7 @@ library Web.Restful.Request, Web.Restful.Response, Web.Restful.Utils, + Web.Restful.Definitions, + Web.Restful.Handler, Web.Restful.Application ghc-options: -Wall