From 564d1431df5cd0014ab0069ffb07f6f3840c7eae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 14 Oct 2009 00:46:14 +0200 Subject: [PATCH] Removed model bits --- Data/Object/Instances.hs | 2 +- TODO | 1 + Web/Restful/Application.hs | 18 ++++++----------- Web/Restful/Helpers/Auth.hs | 39 +++++++++++++++++++++---------------- Web/Restful/Resource.hs | 7 +++---- restful.cabal | 2 +- 6 files changed, 34 insertions(+), 35 deletions(-) diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 13402e71..3c9ae8ae 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -89,7 +89,7 @@ instance SafeFromObject Html where map helper2 m ++ [ toLazyByteString "" ] helper2 :: (B.ByteString, RawObject) -> B.ByteString - helper2 (k, v) = B.concat $ + helper2 (k, v) = B.concat [ toLazyByteString "
" , toLazyByteString k , toLazyByteString "
" diff --git a/TODO b/TODO index 45fb01e7..db5eacf3 100644 --- a/TODO +++ b/TODO @@ -1 +1,2 @@ HTML sitemap generation +Remove model diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 561632e8..dc9f5296 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,10 +43,7 @@ import Web.Restful.Constants import Web.Restful.Resource -- | A data type that can be turned into a Hack application. -class ResourceName a b => RestfulApp a b | a -> b where - -- | Load up the model, ie the data which use passed to each handler. - getModel :: a -> IO b - +class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 encryptKey _ = getKey defaultKeyFile @@ -87,25 +83,23 @@ class ResourceName a b => RestfulApp a b | a -> b where -- | Given a sample resource name (purely for typing reasons), generating -- a Hack application. -toHackApp :: RestfulApp resourceName modelType +toHackApp :: RestfulApp resourceName => resourceName -> IO Hack.Application toHackApp a = do when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? - model <- getModel a key <- encryptKey a - let handlers = getHandler model - app' = toHackApplication a handlers + 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 model +findResourceNames :: ResourceName a => Resource -> [(a, [(String, String)])] findResourceNames r = takeJusts $ map (checkPatternHelper r) enumerate -checkPatternHelper :: ResourceName a model +checkPatternHelper :: ResourceName a => Resource -> a -> Maybe (a, [(String, String)]) @@ -119,7 +113,7 @@ takeJusts [] = [] takeJusts (Nothing:rest) = takeJusts rest takeJusts (Just x:rest) = x : takeJusts rest -toHackApplication :: RestfulApp resourceName model +toHackApplication :: RestfulApp resourceName => resourceName -> (resourceName -> Verb -> Handler) -> Hack.Application diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 272fc656..9b3457ec 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -15,6 +15,9 @@ --------------------------------------------------------- module Web.Restful.Helpers.Auth ( AuthResource + , authHandler + , authResourcePattern + , RpxnowApiKey (..) ) where import qualified Hack @@ -50,24 +53,26 @@ instance Enumerable AuthResource where , LoginRpxnow ] -type RpxnowApiKey = String -- FIXME newtype -instance ResourceName AuthResource (Maybe RpxnowApiKey) where - getHandler _ Check Get = authCheck - getHandler _ Logout Get = authLogout - getHandler _ Openid Get = authOpenidForm - getHandler _ OpenidForward Get = authOpenidForward - getHandler _ OpenidComplete Get = authOpenidComplete - -- two different versions of RPX protocol apparently... - getHandler (Just key) LoginRpxnow Get = rpxnowLogin key - getHandler (Just key) LoginRpxnow Post = rpxnowLogin key - getHandler _ _ _ = notFound +newtype RpxnowApiKey = RpxnowApiKey String - 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/" +authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler +authHandler _ Check Get = authCheck +authHandler _ Logout Get = authLogout +authHandler _ Openid Get = authOpenidForm +authHandler _ OpenidForward Get = authOpenidForward +authHandler _ OpenidComplete Get = authOpenidComplete +-- two different versions of RPX protocol apparently... +authHandler (Just (RpxnowApiKey key)) LoginRpxnow Get = rpxnowLogin key +authHandler (Just (RpxnowApiKey key)) LoginRpxnow Post = rpxnowLogin key +authHandler _ _ _ = notFound + +authResourcePattern :: AuthResource -> String -- FIXME supply prefix as well +authResourcePattern Check = "/auth/check/" +authResourcePattern Logout = "/auth/logout/" +authResourcePattern Openid = "/auth/openid/" +authResourcePattern OpenidForward = "/auth/openid/forward/" +authResourcePattern OpenidComplete = "/auth/openid/complete/" +authResourcePattern LoginRpxnow = "/auth/login/rpxnow/" data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index a0fa555d..3bffbffb 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -70,7 +69,7 @@ fromString' ('*':rest) = Slurp rest fromString' ('#':rest) = DynInt rest fromString' x = Static x -class (Show a, Enumerable a) => ResourceName a b | a -> b where +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. @@ -80,7 +79,7 @@ class (Show a, Enumerable a) => ResourceName a b | a -> b where resourcePattern :: a -> String -- | Find the handler for each resource name/verb pattern. - getHandler :: b -> a -> Verb -> Handler + getHandler :: a -> Verb -> Handler type SMap = [(String, String)] @@ -135,7 +134,7 @@ 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 model) => rn -> m () +checkResourceName :: (Monad m, ResourceName rn) => rn -> m () checkResourceName rn = do let avs@(y:_) = enumerate _ignore = asTypeOf rn y diff --git a/restful.cabal b/restful.cabal index e2e2bc47..e598a704 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.6 +version: 0.1.7 license: BSD3 license-file: LICENSE author: Michael Snoyman