From 4a0d7baa68ec3d1e62b7a811d4831b980b976101 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 20 Sep 2009 23:26:30 +0300 Subject: [PATCH] Slurp paths and static helper --- TODO | 1 + Web/Restful/Helpers/Auth.hs | 2 +- Web/Restful/Helpers/Static.hs | 54 +++++++++++++++++++++++++++++++++++ Web/Restful/Resource.hs | 25 +++++++++++++--- Web/Restful/Response.hs | 6 +++- restful.cabal | 1 + 6 files changed, 83 insertions(+), 6 deletions(-) create mode 100644 Web/Restful/Helpers/Static.hs diff --git a/TODO b/TODO index 7fb61ea3..443e2ed8 100644 --- a/TODO +++ b/TODO @@ -1,2 +1,3 @@ Static files and directories Better error handling for invalid arguments (currently 500 error) +Include request getting in Response monad. diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 7844e2c9..067cd551 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do case dest of Just dest' -> addCookie 20 "DEST" dest' Nothing -> return () - return $! HtmlResponse html + return $! htmlResponse html data OIDFReq = OIDFReq String String instance Request OIDFReq where diff --git a/Web/Restful/Helpers/Static.hs b/Web/Restful/Helpers/Static.hs new file mode 100644 index 00000000..9d88131c --- /dev/null +++ b/Web/Restful/Helpers/Static.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +--------------------------------------------------------- +-- +-- Module : Web.Restful.Helpers.Static +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Serve static files from a Restful app. +-- +--------------------------------------------------------- +module Web.Restful.Helpers.Static + ( serveStatic + , FileLookup + ) where + +import qualified Data.ByteString as B + +import Web.Restful + +type FileLookup = FilePath -> IO (Maybe B.ByteString) + +serveStatic :: FileLookup -> Verb -> Handler +serveStatic fl Get = liftHandler $ getStatic fl +serveStatic _ _ = noHandler + +newtype StaticReq = StaticReq FilePath +instance Request StaticReq where + parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for .. + +getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse +getStatic fl (StaticReq fp) = do + content <- liftIO $ fl fp + case content of + Nothing -> notFound + Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs + +mimeType :: String -> String +mimeType "jpg" = "image/jpeg" +mimeType "jpeg" = "image/jpeg" +mimeType "js" = "text/javascript" +mimeType "css" = "text/css" +mimeType "html" = "text/html" +mimeType "png" = "image/png" +mimeType "gif" = "image/gif" +mimeType "txt" = "text/plain" +mimeType _ = "application/octet-stream" + +ext :: String -> String +ext = reverse . fst . break (== '.') . reverse diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index 2470c70d..d253edb3 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -22,12 +22,18 @@ module Web.Restful.Resource import Data.List.Split (splitOn) import Web.Restful.Definitions import Web.Restful.Handler +import Data.List (intercalate) data ResourcePatternPiece = Static String | Dynamic String + | Slurp String -- ^ take up the rest of the pieces. must be last deriving Show +isSlurp :: ResourcePatternPiece -> Bool +isSlurp (Slurp _) = True +isSlurp _ = False + type ResourcePattern = [ResourcePatternPiece] fromString :: String -> ResourcePattern @@ -35,12 +41,16 @@ fromString = map fromString' . filter (not . null) . splitOn "/" fromString' :: String -> ResourcePatternPiece fromString' ('$':rest) = Dynamic rest +fromString' ('*':rest) = Slurp rest fromString' x = Static x class Show a => ResourceName a b | a -> b 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. + -- + -- Also, /foo/*bar/ will match /foo/[anything else], capturing the value + -- into the bar urlParam. resourcePattern :: a -> String -- | Get all possible values for resource names. @@ -58,14 +68,21 @@ 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 rp r + | length rp /= 0 && isSlurp (last rp) = do + let rp' = init rp + (r1, r2) = splitAt (length rp') r + smap <- checkPattern rp' r1 + let slurpValue = intercalate "/" r2 + Slurp slurpKey = last rp + return $ (slurpKey, slurpValue) : smap + | length rp /= length r = Nothing + | otherwise = 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) +checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" combine :: SMap -> [CheckPatternReturn] -> Maybe SMap combine s [] = Just $ reverse s diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index f0db694b..5336bfb9 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -32,6 +32,7 @@ module Web.Restful.Response , ErrorResult (..) , HasRepsW (..) , byteStringResponse + , htmlResponse ) where import Data.ByteString.Class @@ -183,7 +184,7 @@ addHeader h = ResponseT (return (Right (), [h])) instance HasReps () where reps _ = [("text/plain", toLazyByteString "")] -data GenResponse = HtmlResponse String +data GenResponse = HtmlResponse B.ByteString | ObjectResponse Object | HtmlOrObjectResponse String Object | ByteStringResponse ContentType B.ByteString @@ -197,6 +198,9 @@ instance HasReps GenResponse where byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse byteStringResponse ct = ByteStringResponse ct . toLazyByteString +htmlResponse :: LazyByteString lbs => lbs -> GenResponse +htmlResponse = HtmlResponse . toLazyByteString + instance HasReps Object where reps o = [ ("text/html", unHtml $ safeFromObject o) diff --git a/restful.cabal b/restful.cabal index a2f3f781..73dce39d 100644 --- a/restful.cabal +++ b/restful.cabal @@ -43,6 +43,7 @@ library Data.Object.Instances, Hack.Middleware.MethodOverride, Web.Restful.Helpers.Auth, + Web.Restful.Helpers.Static, Web.Restful.Response.AtomFeed, Web.Restful.Response.Sitemap, Web.Restful.Generic.ListDetail