diff --git a/Web/Scotty.hs b/Web/Scotty.hs --- a/Web/Scotty.hs +++ b/Web/Scotty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} -- | It should be noted that most of the code snippets below depend on the -- OverloadedStrings language pragma. module Web.Scotty @@ -21,24 +21,27 @@ -- definition, as they completely replace the current 'Response' body. , text, html, file, json -- ** Exceptions - , raise, rescue + , raise, rescue, next -- * Types - , ScottyM, ActionM + , ScottyM, ActionM, Parsable ) where import Blaze.ByteString.Builder (fromByteString, fromLazyByteString) import Control.Applicative +import qualified Control.Exception as E +import qualified Control.DeepSeq as DS import Control.Monad.Error import Control.Monad.Reader import qualified Control.Monad.State as MS +import Control.Monad.Trans.Resource (ResourceT) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as B import qualified Data.CaseInsensitive as CI import Data.Default (Default, def) -import Data.Enumerator.List (consume) -import Data.Enumerator.Internal (Iteratee) +import Data.Conduit.List (consume) +import Data.Conduit (($$)) import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T @@ -48,6 +51,8 @@ import Network.Wai import Network.Wai.Handler.Warp (Port, run) +import Prelude hiding (catch) -- this always trips me up + import Web.Scotty.Util data ScottyState = ScottyState { @@ -86,6 +91,7 @@ data ActionError = Redirect T.Text | ActionError T.Text + | Next deriving (Eq,Show) instance Error ActionError where @@ -95,13 +101,16 @@ deriving ( Monad, MonadIO, Functor , MonadReader (Request,[Param]), MS.MonadState Response, MonadError ActionError) -runAction :: [Param] -> ActionM () -> Application -runAction ps action req = lift - $ flip MS.execStateT def - $ flip runReaderT (req,ps) - $ runErrorT - $ runAM - $ action `catchError` defaultHandler +-- Nothing indicates route failed (due to Next) and pattern matching should continue. +-- Just indicates a successful response. +runAction :: [Param] -> ActionM () -> Request -> ResourceT IO (Maybe Response) +runAction ps action req = do + (e,r) <- lift $ flip MS.runStateT def + $ flip runReaderT (req, ps ++ queryParams req) + $ runErrorT + $ runAM + $ action `catchError` defaultHandler + return $ either (const Nothing) (const $ Just r) e defaultHandler :: ActionError -> ActionM () defaultHandler (Redirect url) = do @@ -110,19 +119,37 @@ defaultHandler (ActionError msg) = do status status500 html $ mconcat ["

500 Internal Server Error

", msg] +defaultHandler Next = next -- | Throw an exception, which can be caught with 'rescue'. Uncaught exceptions -- turn into HTTP 500 responses. raise :: T.Text -> ActionM a raise = throwError . ActionError +-- | Abort execution of this action and continue pattern matching routes. +-- Like an exception, any code after 'next' is not executed. +-- +-- As an example, these two routes overlap. The only way the second one will +-- ever run is if the first one calls 'next'. +-- +-- > get "/foo/:number" $ do +-- > n <- param "number" +-- > unless (all isDigit n) $ next +-- > text "a number" +-- > +-- > get "/foo/:bar" $ do +-- > bar <- param "bar" +-- > text "not a number" +next :: ActionM a +next = throwError Next + -- | Catch an exception thrown by 'raise'. -- -- > raise "just kidding" `rescue` (\msg -> text msg) rescue :: ActionM a -> (T.Text -> ActionM a) -> ActionM a rescue action handler = catchError action $ \e -> case e of - ActionError msg -> handler msg -- handle errors - r -> throwError r -- rethrow redirects + ActionError msg -> handler msg -- handle errors + other -> throwError other -- rethrow redirects and nexts -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect -- will not be run. @@ -139,24 +166,65 @@ request :: ActionM Request request = fst <$> ask --- | Get a parameter. First looks in captures, then form data, then query parameters. Raises --- an exception which can be caught by 'rescue' if parameter is not found. -param :: T.Text -> ActionM T.Text +-- | Get a parameter. First looks in captures, then form data, then query parameters. +-- +-- * Raises an exception which can be caught by 'rescue' if parameter is not found. +-- +-- * If parameter is found, but 'read' fails to parse to the correct type, 'next' is called. +-- This means captures are somewhat typed, in that a route won't match if a correctly typed +-- capture cannot be parsed. +param :: (Parsable a) => T.Text -> ActionM a param k = do val <- lookup k <$> snd <$> ask - maybe (raise $ mconcat ["Param: ", k, " not found!"]) return val + case val of + Nothing -> raise $ mconcat ["Param: ", k, " not found!"] + Just v -> maybe next return =<< liftIO (parseParam v) +-- This needs to be in IO to catch parse errors from 'read', but is otherwise pure. +class Parsable a where + parseParam :: T.Text -> IO (Maybe a) + + -- if any individual element fails to parse, the whole list fails to parse. + parseParamList :: T.Text -> IO (Maybe [a]) + parseParamList t = sequence <$> mapM parseParam (T.split (==',') t) + +-- No point using 'read' for Text, ByteString, Char, and String. +instance Parsable T.Text where parseParam = return . Just +instance Parsable B.ByteString where parseParam = return . Just . lazyTextToStrictByteString +instance Parsable Char where + parseParam t = case T.unpack t of + [c] -> return $ Just c + _ -> return Nothing + parseParamList = return . Just . T.unpack -- String +instance Parsable () where + parseParam t = if T.null t then return (Just ()) else return Nothing + +instance (Parsable a) => Parsable [a] where parseParam = parseParamList + +instance Parsable Bool where parseParam = readMaybe +instance Parsable Double where parseParam = readMaybe +instance Parsable Float where parseParam = readMaybe +instance Parsable Int where parseParam = readMaybe +instance Parsable Integer where parseParam = readMaybe + +-- Called by parseParam. Uses 'read' to attempt to parse Text value, catching +-- any ErrorCall exceptions (which should be the No Parse error). +readMaybe :: (Read a, DS.NFData a) => T.Text -> IO (Maybe a) +readMaybe tv = E.handleJust E.fromException + (\(_::E.ErrorCall) -> return Nothing) + $ return DS.$!! Just $ read $ T.unpack tv + -- | get = addroute 'GET' get :: T.Text -> ActionM () -> ScottyM () -get = addroute GET +get = addroute GET -- | post = addroute 'POST' post :: T.Text -> ActionM () -> ScottyM () -post = addroute POST +post = addroute POST -- | put = addroute 'PUT' put :: T.Text -> ActionM () -> ScottyM () -put = addroute PUT +put = addroute PUT -- | delete = addroute 'DELETE' delete :: T.Text -> ActionM () -> ScottyM () @@ -183,17 +251,19 @@ Just ('/',_) -> path _ -> T.cons '/' path --- todo: wildcards? route :: StdMethod -> T.Text -> ActionM () -> Middleware route method path action app req = if Right method == parseMethod (requestMethod req) then case matchRoute path (strictByteStringToLazyText $ rawPathInfo req) of - Just params -> do + Just captures -> do formParams <- parseFormData method req - runAction (addQueryParams req $ params ++ formParams) action req - Nothing -> app req - else app req + res <- runAction (captures ++ formParams) action req + maybe tryNext return res + Nothing -> tryNext + else tryNext + where tryNext = app req +-- todo: wildcards? matchRoute :: T.Text -> T.Text -> Maybe [Param] matchRoute pat req = go (T.split (=='/') pat) (T.split (=='/') req) [] where go [] [] ps = Just ps -- request string and pattern match! @@ -208,19 +278,19 @@ | otherwise = Nothing -- both literals, but unequal, fail -- TODO: this is probably better implemented as middleware -parseFormData :: StdMethod -> Request -> Iteratee B.ByteString IO [Param] +parseFormData :: StdMethod -> Request -> ResourceT IO [Param] parseFormData POST req = case lookup "Content-Type" [(CI.mk k, CI.mk v) | (k,v) <- requestHeaders req] of - Just "application/x-www-form-urlencoded" -> do reqBody <- mconcat <$> consume - return $ parseEncodedParams reqBody [] + Just "application/x-www-form-urlencoded" -> do reqBody <- mconcat <$> (requestBody req $$ consume) + return $ parseEncodedParams reqBody _ -> do lift $ putStrLn "Unsupported form data encoding. TODO: Fix" return [] parseFormData _ _ = return [] -addQueryParams :: Request -> [Param] -> [Param] -addQueryParams = parseEncodedParams . rawQueryString +queryParams :: Request -> [Param] +queryParams = parseEncodedParams . rawQueryString -parseEncodedParams :: B.ByteString -> [Param] -> [Param] -parseEncodedParams bs = (++ [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]) +parseEncodedParams :: B.ByteString -> [Param] +parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ] -- | Set the HTTP response status. Default is 200. status :: Status -> ActionM () diff --git a/Web/Scotty/Util.hs b/Web/Scotty/Util.hs --- a/Web/Scotty/Util.hs +++ b/Web/Scotty/Util.hs @@ -26,29 +26,23 @@ strictByteStringToLazyText :: B.ByteString -> T.Text strictByteStringToLazyText = T.fromStrict . ES.decodeUtf8 --- Note: ResponseEnumerator is about to go away in favor of ResponseSource - setContent :: Either Builder FilePath -> Response -> Response setContent (Left b) (ResponseBuilder s h _) = ResponseBuilder s h b setContent (Left b) (ResponseFile s h _ _) = ResponseBuilder s h b -setContent (Left b) (ResponseEnumerator _) = ResponseBuilder status200 [] b --- setContent (Left b) (ResponseSource s h _) = ResponseBuilder s h b +setContent (Left b) (ResponseSource s h _) = ResponseBuilder s h b setContent (Right f) (ResponseBuilder s h _) = ResponseFile s h f Nothing setContent (Right f) (ResponseFile s h _ _) = ResponseFile s h f Nothing -setContent (Right f) (ResponseEnumerator _) = ResponseFile status200 [] f Nothing --- setContent (Right f) (ResponseSource s h _) = ResponseFile s h f Nothing +setContent (Right f) (ResponseSource s h _) = ResponseFile s h f Nothing setHeader :: (CI Ascii, Ascii) -> Response -> Response setHeader (k,v) (ResponseBuilder s h b) = ResponseBuilder s (update h k v) b setHeader (k,v) (ResponseFile s h f fp) = ResponseFile s (update h k v) f fp -setHeader _ re = re --- setHeader (k,v) (ResponseSource s h cs) = ResponseSource s (update h k v) cs +setHeader (k,v) (ResponseSource s h cs) = ResponseSource s (update h k v) cs setStatus :: Status -> Response -> Response setStatus s (ResponseBuilder _ h b) = ResponseBuilder s h b setStatus s (ResponseFile _ h f fp) = ResponseFile s h f fp -setStatus _ re = re --- setStatus s (ResponseSource _ h cs) = ResponseSource s h cs +setStatus s (ResponseSource _ h cs) = ResponseSource s h cs -- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not) update :: (Eq a) => [(a,b)] -> a -> b -> [(a,b)] diff --git a/examples/basic.hs b/examples/basic.hs --- a/examples/basic.hs +++ b/examples/basic.hs @@ -5,7 +5,7 @@ import Control.Monad.Trans import Data.Monoid -import System.Random +import System.Random (newStdGen, randomRs) import Network.HTTP.Types (status302) @@ -53,10 +53,18 @@ -- Files are streamed directly to the client. get "/404" $ file "404.html" + get "/random" $ do + next + redirect "http://www.we-never-go-here.com" + -- You can do IO with liftIO, and you can return JSON content. get "/random" $ do g <- liftIO newStdGen json $ take 20 $ randomRs (1::Int,100) g + + get "/ints/:is" $ do + is <- param "is" + json $ [(1::Int)..10] ++ is {- If you don't want to use Warp as your webserver, you can use any WAI handler. diff --git a/examples/urlshortener.hs b/examples/urlshortener.hs --- a/examples/urlshortener.hs +++ b/examples/urlshortener.hs @@ -7,8 +7,8 @@ import Data.Monoid (mconcat) import qualified Data.Text.Lazy as T -import Network.HTTP.Types import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.Static import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes @@ -21,6 +21,7 @@ main :: IO () main = scotty 3000 $ do middleware logStdoutDev + middleware static m <- liftIO $ newMVar (0::Int,M.empty) @@ -34,19 +35,22 @@ post "/shorten" $ do url <- param "url" - liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i url db) + liftIO $ modifyMVar_ m $ \(i,db) -> return (i+1, M.insert i (T.pack url) db) redirect "/list" - get "/list" $ do - db <- liftIO $ withMVar m $ \(_,db) -> return (M.toList db) - json db - - -- todo: static serving middleware - get "/favicon.ico" $ status status404 - + -- We have to be careful here, because this route can match pretty much anything. + -- Thankfully, the type system knows that 'hash' must be an Int, so this route + -- only matches if 'read' can successfully parse the hash capture as an Int. + -- Otherwise, the pattern match will fail and Scotty will continue matching + -- subsequent routes. get "/:hash" $ do hash <- param "hash" (_,db) <- liftIO $ readMVar m - case M.lookup (read $ T.unpack $ hash) db of - Nothing -> raise $ mconcat ["URL hash #", hash, " not found in database!"] + case M.lookup hash db of + Nothing -> raise $ mconcat ["URL hash #", T.pack $ show $ hash, " not found in database!"] Just url -> redirect url + + -- We put /list down here to show that it will not match the '/:hash' route above. + get "/list" $ do + (_,db) <- liftIO $ readMVar m + json $ M.toList db diff --git a/scotty.cabal b/scotty.cabal --- a/scotty.cabal +++ b/scotty.cabal @@ -1,5 +1,5 @@ Name: scotty -Version: 0.0.1 +Version: 0.1.0 Synopsis: Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp Homepage: https://github.com/xich/scotty Bug-reports: https://github.com/xich/scotty/issues @@ -61,18 +61,19 @@ Exposed-modules: Web.Scotty other-modules: Web.Scotty.Util default-language: Haskell2010 - Build-depends: aeson >= 0.5, + build-depends: aeson >= 0.5, base >= 4.3.1 && < 5, blaze-builder >= 0.3, bytestring >= 0.9.1, case-insensitive >= 0.4, + conduit >= 0.1.1.1, data-default >= 0.3, - enumerator >= 0.4.16, + deepseq >= 1.2, http-types >= 0.6.8, mtl >= 2.0.1, text >= 0.11.1, - wai >= 0.4.3, - warp >= 0.4.6 + wai >= 1.0.0, + warp >= 1.0.0 GHC-options: -Wall -fno-warn-orphans