From a3e328ca9969c4e31f752dc4f1b5fc504ab3b547 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 10 Aug 2009 08:51:16 +0300 Subject: [PATCH] Switched to ResourceName type class --- Web/Restful.hs | 2 ++ Web/Restful/Application.hs | 34 ++++++++++++++---- Web/Restful/Definitions.hs | 15 -------- Web/Restful/Handler.hs | 4 --- Web/Restful/Helpers/Auth.hs | 71 ++++++++++++++++--------------------- Web/Restful/Resource.hs | 65 +++++++++++++++++++++++++++++++++ 6 files changed, 125 insertions(+), 66 deletions(-) create mode 100644 Web/Restful/Resource.hs diff --git a/Web/Restful.hs b/Web/Restful.hs index a4699743..47ac2fbc 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -19,6 +19,7 @@ module Web.Restful , module Web.Restful.Application , module Web.Restful.Definitions , module Web.Restful.Handler + , module Web.Restful.Resource ) where import Data.Object @@ -27,3 +28,4 @@ import Web.Restful.Response import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler +import Web.Restful.Resource diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index dbe63821..1890644e 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -47,6 +47,7 @@ import Web.Restful.Utils import Web.Restful.Handler import Web.Restful.Definitions import Web.Restful.Constants +import Web.Restful.Resource -- | Contains settings and a list of resources. type ApplicationMonad a = State (ApplicationSettings a) @@ -63,8 +64,7 @@ data ApplicationSettings rn = ApplicationSettings , htmlWrapper :: BS.ByteString -> BS.ByteString } -instance (HasResourceParser a) => - Default (ApplicationSettings a) where +instance Default (ApplicationSettings a) where def = ApplicationSettings { encryptKey = Left defaultKeyFile , hackMiddleware = @@ -91,7 +91,7 @@ setHtmlWrapper f = do s <- get put $ s { htmlWrapper = f } -toHackApp :: (Eq a, HasResourceParser a, HasHandlers a b) +toHackApp :: ResourceName a b => ApplicationMonad a () -> b -> IO Hack.Application @@ -106,15 +106,34 @@ toHackApp am model = do app = foldr ($) app' $ hackMiddleware settings ++ [clientsession'] return app -toHackApplication :: (HasResourceParser resourceName, Eq resourceName) +findResourceNames :: ResourceName a model + => Resource + -> [(a, [(String, String)])] +findResourceNames r = takeJusts $ map (checkPatternHelper r) allValues + +checkPatternHelper :: ResourceName a model + => 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 :: ResourceName resourceName model => HandlerMap resourceName -> ApplicationSettings resourceName -> Hack.Application toHackApplication hm settings env = do let (Right resource) = splitPath $ Hack.pathInfo env - case resourceParser resource of - Nothing -> response404 settings $ env - (Just (ParsedResource rn urlParams')) -> do + case findResourceNames resource of + [] -> response404 settings $ env + [(rn, urlParams')] -> do let verb :: Verb verb = toVerb $ Hack.requestMethod env rr :: RawRequest @@ -145,6 +164,7 @@ toHackApplication hm settings env = do (("Content-Type", ctype) : headers) $ toLazyByteString $ wrapper content Nothing -> response404 settings $ env + x -> error $ "Invalid matches: " ++ show x envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest urlParams' env = diff --git a/Web/Restful/Definitions.hs b/Web/Restful/Definitions.hs index 12a6aab1..0d21bcd8 100644 --- a/Web/Restful/Definitions.hs +++ b/Web/Restful/Definitions.hs @@ -17,9 +17,6 @@ module Web.Restful.Definitions ( Verb (..) , toVerb , Resource - , ParsedResource (..) - , ResourceParser - , HasResourceParser (..) ) where import qualified Hack @@ -34,15 +31,3 @@ toVerb Hack.POST = Post toVerb _ = Get type Resource = [String] - -data ParsedResource a = ParsedResource - { resourceName :: a - , urlParameters :: [(String, String)] - } - -type ResourceParser a = Resource -> Maybe (ParsedResource a) - -class HasResourceParser a where - resourceParser :: ResourceParser a - simpleParse :: a -> Maybe (ParsedResource a) - simpleParse x = Just $ ParsedResource x [] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index 980ff848..b4a1f1fa 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -18,7 +18,6 @@ module Web.Restful.Handler ( Handler (..) , runHandler , HandlerMap - , HasHandlers (..) , liftHandler ) where @@ -37,9 +36,6 @@ runHandler (Handler f) rreq = do type HandlerMap a = a -> Verb -> Maybe Handler -class HasHandlers a b | a -> b where - getHandler :: b -> a -> Verb -> Maybe Handler - liftHandler :: (Request req, Response res) => (req -> IO res) -> Maybe Handler diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 44cd26e8..7d2c2481 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -15,8 +15,6 @@ --------------------------------------------------------- module Web.Restful.Helpers.Auth ( AuthResource - , FromAuthResource (..) - , authResourceParser ) where import qualified Hack @@ -34,48 +32,41 @@ import Control.Monad.Reader import Data.Object data AuthResource = - AuthCheck - | AuthLogout - | AuthOpenid - | AuthOpenidForward - | AuthOpenidComplete - | AuthLoginRpxnow - deriving Eq -class FromAuthResource a where - fromAuthResource :: AuthResource -> a - -authResourceParser :: FromAuthResource far - => Resource - -> Maybe (ParsedResource far) -authResourceParser ["check"] = - authResourceParser' AuthCheck -authResourceParser ["logout"] = - authResourceParser' AuthLogout -authResourceParser ["openid"] = - authResourceParser' AuthOpenid -authResourceParser ["openid", "forward"] = - authResourceParser' AuthOpenidForward -authResourceParser ["openid", "complete"] = - authResourceParser' AuthOpenidComplete -authResourceParser ["login", "rpxnow"] = - authResourceParser' AuthLoginRpxnow -authResourceParser _ = Nothing - -authResourceParser' :: FromAuthResource far - => AuthResource - -> Maybe (ParsedResource far) -authResourceParser' x = Just $ ParsedResource (fromAuthResource x) [] + Check + | Logout + | Openid + | OpenidForward + | OpenidComplete + | LoginRpxnow + deriving Show type RpxnowApiKey = String -- FIXME newtype -instance HasHandlers AuthResource (Maybe RpxnowApiKey) where - getHandler _ AuthCheck Get = liftHandler authCheck - getHandler _ AuthLogout Get = liftHandler authLogout - getHandler _ AuthOpenid Get = liftHandler authOpenidForm - getHandler _ AuthOpenidForward Get = liftHandler authOpenidForward - getHandler _ AuthOpenidComplete Get = liftHandler authOpenidComplete - getHandler (Just key) AuthLoginRpxnow Get = liftHandler $ rpxnowLogin key +instance ResourceName AuthResource (Maybe RpxnowApiKey) where + getHandler _ Check Get = liftHandler authCheck + getHandler _ Logout Get = liftHandler authLogout + getHandler _ Openid Get = liftHandler authOpenidForm + getHandler _ OpenidForward Get = liftHandler authOpenidForward + getHandler _ OpenidComplete Get = liftHandler authOpenidComplete + getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key getHandler _ _ _ = Nothing + allValues = + Check + : Logout + : Openid + : OpenidForward + : OpenidComplete + : LoginRpxnow + : [] + + resourcePattern Check = "/auth/check/" + resourcePattern Logout = "/auth/logout/" + resourcePattern Openid = "/auth/openid/" + resourcePattern OpenidForward = "/auth/openid/forward/" + resourcePattern OpenidComplete = "/auth/openid/complete/" + resourcePattern LoginRpxnow = "/auth/login/rpxnow/" + + data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) instance Request OIDFormReq where parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest" diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs new file mode 100644 index 00000000..f229c6d6 --- /dev/null +++ b/Web/Restful/Resource.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Resource +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Defines the Resource class. +-- +--------------------------------------------------------- +module Web.Restful.Resource + ( ResourceName (..) + , fromString + , checkPattern + ) where + +import Data.List.Split (splitOn) +import Web.Restful.Definitions +import Web.Restful.Handler + +data ResourcePatternPiece = + Static String + | Dynamic String + deriving Show + +type ResourcePattern = [ResourcePatternPiece] + +fromString :: String -> ResourcePattern +fromString = map fromString' . filter (not . null) . splitOn "/" + +fromString' :: String -> ResourcePatternPiece +fromString' ('$':rest) = Dynamic rest +fromString' x = Static x + +class Show a => ResourceName a b | a -> b where + resourcePattern :: a -> String + allValues :: [a] + getHandler :: b -> a -> Verb -> Maybe Handler + +-- FIXME add some overlap checking functions + +type SMap = [(String, String)] + +data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch + +checkPattern :: ResourcePattern -> Resource -> Maybe SMap +checkPattern rp r = + if length rp /= length r + then Nothing + else combine [] $ zipWith checkPattern' rp r + +checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn +checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch +checkPattern' (Dynamic x) y = DynamicMatch (x, y) + +combine :: SMap -> [CheckPatternReturn] -> Maybe SMap +combine s [] = Just $ reverse s +combine _ (NoMatch:_) = Nothing +combine s (StaticMatch:rest) = combine s rest +combine s (DynamicMatch x:rest) = combine (x:s) rest