scotty 0.0.1 → 0.1.0
raw patch · 5 files changed
+137/−60 lines, 5 filesdep +conduitdep +deepseqdep −enumeratordep ~waidep ~warp
Dependencies added: conduit, deepseq
Dependencies removed: enumerator
Dependency ranges changed: wai, warp
Files
- Web/Scotty.hs +103/−33
- Web/Scotty/Util.hs +4/−10
- examples/basic.hs +9/−1
- examples/urlshortener.hs +15/−11
- scotty.cabal +6/−5
Web/Scotty.hs view
@@ -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 ["<h1>500 Internal Server Error</h1>", 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 ()
Web/Scotty/Util.hs view
@@ -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)]
examples/basic.hs view
@@ -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.
examples/urlshortener.hs view
@@ -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
scotty.cabal view
@@ -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