diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index a847a09a..561632e8 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -26,6 +26,7 @@ import Web.Encodings import qualified Data.ByteString.Lazy as B import Data.Object import Data.Enumerable +import Control.Monad (when) import qualified Hack import Hack.Middleware.CleanPath @@ -80,13 +81,17 @@ class ResourceName a b => RestfulApp a b | a -> b where errorHandler _ _ PermissionDenied = reps $ toRawObject "Permission denied" + -- | 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 modelType => resourceName -> IO Hack.Application toHackApp a = do - checkResourceName a -- FIXME maybe this should be done compile-time? + when (checkOverlaps a) $ checkResourceName a -- FIXME maybe this should be done compile-time? model <- getModel a key <- encryptKey a let handlers = getHandler model @@ -123,10 +128,9 @@ toHackApplication sampleRN hm env = do let (handler, urlParams', wrapper) = case findResourceNames resource of [] -> (notFound, [], const return) - [(rn, urlParams'')] -> + ((rn, urlParams''):_) -> let verb = toVerb $ Hack.requestMethod env in (hm rn verb, urlParams'', responseWrapper rn) - x -> error $ "Invalid findResourceNames: " ++ show x let rr = envToRawRequest urlParams' env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env ctypes' = parseHttpAccept rawHttpAccept diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 9e28a9ed..68e7f13e 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -14,6 +14,7 @@ module Web.Restful.Response.Sitemap ( sitemap + , robots , SitemapUrl (..) , SitemapLoc (..) , SitemapChangeFreq (..) @@ -88,3 +89,8 @@ sitemap urls' = do let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env) urls <- liftIO urls' return $ reps $ SitemapResponse req urls + +robots :: Handler +robots = do + ar <- approot + genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml"