Switched to ResourceName type class

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

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 =

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 []

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

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"

Web/Restful/Resource.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+---------------------------------------------------------
+--
+-- Module        : Web.Restful.Resource
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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