Slurp paths and static helper

TODO

@@ -1,2 +1,3 @@
 Static files and directories
 Better error handling for invalid arguments (currently 500 error)
+Include request getting in Response monad.

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

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 <michael@snoyman.com>
+-- 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

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 =
+checkPattern rp r
-    if length rp /= length r
+    | length rp /= 0 && isSlurp (last rp) = do
-        then Nothing
+        let rp' = init rp
-        else combine [] $ zipWith checkPattern' rp r
+            (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

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)

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