wai-lite 0.1.0.0 → 0.2.0.0

raw patch · 12 files changed

+824/−34 lines, 12 filesdep −mtldep ~basedep ~bytestringdep ~conduitPVP ok

version bump matches the API change (PVP)

Dependencies removed: mtl

Dependency ranges changed: base, bytestring, conduit, http-types, text, transformers, wai, wai-extra

API changes (from Hackage documentation)

Files

• Network/Wai/Controller.hs +109/−7
• Network/Wai/Frank.hs +1/−1
• Network/Wai/REST.hs +13/−11
• Network/Wai/Responses.hs +1/−1
• Network/Wai/Router.hs +4/−3
• Web/Frank.hs +59/−0
• Web/REST.hs +89/−0
• Web/Simple.hs +10/−0
• Web/Simple/Controller.hs +151/−0
• Web/Simple/Responses.hs +131/−0
• Web/Simple/Router.hs +240/−0
• wai-lite.cabal +16/−11

@@ -1,49 +1,151 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} -module Network.Wai.Controller+{- | 'Controller' provides a convenient syntax for writting 'Application'+  code as a Monadic action with access to an HTTP request, rather than a+  function that takes the request as an argument. This module also defines some+  helper functions that leverage this feature. For example, 'redirectBack'+  reads the underlying request to extract the referer and returns a redirect+  response:++  @+    myController = do+      ...+      if badLogin then+        redirectBack+        else+          ...+  @+-}++module Network.Wai.Controller {-# DEPRECATED "Use Web.Simple.Controller" #-}   ( Controller-  , request-  , body+  -- * Utility functions+  , redirectBack+  , redirectBackOr   , queryParam   , parseForm   , respond+  -- * Low level functions+  , request+  , body   ) where -import Control.Monad.Reader+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Conduit import Data.Conduit.List as CL+import Network.HTTP.Types.Header import Network.Wai import Network.Wai.Parse+import Network.Wai.Responses import Network.Wai.Router  data ControllerState = ControllerState { csRequest :: Request } +-- | A 'Controller' is a 'Reader' monad that contains the HTTP request in its+-- environment. A 'Controller' is 'Routeable' simply by running the 'Reader'. type Controller = ReaderT ControllerState (ResourceT IO)  instance Routeable (Controller Response) where   runRoute controller req = fmap Just $     runReaderT controller $ ControllerState req +-- | Reads the underlying 'Request' request :: Controller Request request = fmap csRequest ask -queryParam :: S8.ByteString -> Controller (Maybe S8.ByteString)+-- | Redirect back to the referer. If the referer header is not present+-- redirect to root (i.e., @\/@).+redirectBack :: Controller Response+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back to the referer. If the referer header is not present+-- fallback on the given 'Response'.+redirectBackOr :: Response -- ^ Fallback 'Response'+               -> Controller Response+redirectBackOr def = do+  mrefr <- requestHeader "referer"+  case mrefr of+    Just refr -> return $ redirectTo $ S8.unpack refr+    Nothing   -> return def++-- | Looks up the parameter name in the request's query string and returns the+-- value as a 'S8.ByteString' or 'Nothing'.+--+-- For example, for a request with query string: \"?foo=bar&baz=7\",+-- @+--   queryParam \"foo\"+-- @+--+-- would return /Just "bar"/, but+--+-- @+--   queryParam \"zap\"+-- @+--+-- would return /Nothing/+queryParam :: S8.ByteString -- ^ Parameter name+           -> Controller (Maybe S8.ByteString) queryParam varName = do   qr <- fmap queryString request   case lookup varName qr of     Just n -> return n     _ -> return Nothing +-- | An alias for 'return' that's helps the the compiler type a code block as a+-- 'Controller'. For example, when using the 'Network.Wai.Frank' routing DSL to+-- define a simple route that justs returns a 'Response', 'respond' can be used+-- to avoid explicit typing of the argument:+--+-- @+--   get \"/\" $ do+--     someSideEffect+--     respond $ okHtml \"Hello World\"+-- @+--+-- instead of:+--+-- @+--   get \"/\" $ (do+--     someSideEffect+--     return $ okHtml \"Hello World\") :: Controller Response+-- @ respond :: Routeable r => r -> Controller r respond = return +-- | Returns the value of the given request header or 'Nothing' if it is not+-- present in the HTTP request.+requestHeader :: HeaderName -> Controller (Maybe S8.ByteString)+requestHeader name = do+  req <- request+  return $ lookup name $ requestHeaders req++-- | Reads and returns the body of the HTTP request. body :: Controller L8.ByteString body = do   bd <- fmap requestBody request   lift $ bd $$ (CL.consume >>= return . L8.fromChunks) -parseForm :: Controller ([Param], [File FilePath])+-- | Parses a HTML form from the request body. It returns a list of 'Param's as+-- well as a list of 'File's, which are pairs mapping the name of a /file/ form+-- field to a 'FileInfo' pointing to a temporary file with the contents of the+-- upload.+--+-- @+--   myController = do+--     (prms, files) <- parseForm+--     let mPicFile = lookup \"profile_pic\" files+--     case mPicFile of+--       Just (picFile) -> do+--         sourceFile (fileContent picFile) $$+--           sinkFile (\"images/\" ++ (fileName picFile))+--         respond $ redirectTo \"/\"+--       Nothing -> redirectBack+-- @+parseForm :: Controller ([Param], [(S.ByteString, FileInfo FilePath)]) parseForm = do   request >>= lift . (parseRequestBody tempFileBackEnd)+

@@ -21,7 +21,7 @@ @  -}-module Network.Wai.Frank+module Network.Wai.Frank {-# DEPRECATED "Use Web.Frank" #-}   ( get   , post   , put

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-}-module Network.Wai.REST+module Network.Wai.REST {-# DEPRECATED "Use Web.REST" #-}   ( RESTController   , index, show, create, update, delete   , edit, new@@ -7,7 +7,7 @@  import Prelude hiding (show) -import Control.Monad.State+import Control.Monad.Trans.State import Data.Conduit import Network.Wai.Responses import Network.Wai.Router@@ -49,39 +49,41 @@      routeMethod DELETE $ routeVar "id" $ restDelete controller -type RESTController a = StateT RESTControllerState (ResourceT IO) a+type RESTControllerM a = StateT RESTControllerState (ResourceT IO) a -instance Routeable (RESTController a) where+instance Routeable (RESTControllerM a) where   runRoute controller = rt     where rt req = do             (_, st) <- runStateT controller defaultRESTControllerState             runRoute st req -index :: Routeable r => r -> RESTController ()+type RESTController = RESTControllerM ()++index :: Routeable r => r -> RESTController index route = modify $ \controller ->   controller { restIndex = routeAll route } -create :: Routeable r => r -> RESTController ()+create :: Routeable r => r -> RESTController create route = modify $ \controller ->   controller { restCreate = routeAll route } -edit :: Routeable r => r -> RESTController ()+edit :: Routeable r => r -> RESTController edit route = modify $ \controller ->   controller { restEdit = routeAll route } -new :: Routeable r => r -> RESTController ()+new :: Routeable r => r -> RESTController new route = modify $ \controller ->   controller { restNew = routeAll route } -show :: Routeable r => r -> RESTController ()+show :: Routeable r => r -> RESTController show route = modify $ \controller ->   controller { restShow = routeAll route } -update :: Routeable r => r -> RESTController ()+update :: Routeable r => r -> RESTController update route = modify $ \controller ->   controller { restUpdate = routeAll route } -delete :: Routeable r => r -> RESTController ()+delete :: Routeable r => r -> RESTController delete route = modify $ \controller ->   controller { restDelete = routeAll route } 

@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- | This module defines some convenience functions for creating responses.-module Network.Wai.Responses+module Network.Wai.Responses {-# DEPRECATED "Use Web.Simple.Responses" #-}   ( ok, okHtml   , movedTo, redirectTo   , badRequest, requireBasicAuth, forbidden

@@ -13,7 +13,7 @@  -} -module Network.Wai.Router+module Network.Wai.Router {-# DEPRECATED "Use Simple.Web.Router" #-}   (   -- * Example   -- $Example@@ -152,8 +152,9 @@ -- routes that pop the 'pathInfo' list. routeTop :: Routeable r => r -> Route () routeTop route = mroute $ \req ->-  if null $ pathInfo req then runRoute route req-  else return Nothing+  if null (pathInfo req)  || (T.length . head $ pathInfo req) == 0+    then runRoute route req+    else return Nothing  -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') routeMethod :: Routeable r => StdMethod -> r -> Route ()

@@ -0,0 +1,59 @@+{- |+Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating+routes. It is composable with all 'Routeable' types, but is designed to be used+with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a+URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for+details) and a 'Routeable':++@+  main :: IO ()+  main = runSettings defaultSettings $ mkRouter $ do+    get \"\/\" $ do+      req <- request+      return $ okHtml $ fromString $+        \"Welcome Home \" ++ (show $ serverName req)+    get \"\/user\/:id\" $ do+      userId \<- queryParam \"id\" >>= fromMaybe \"\"+      return $ ok \"text/json\" $ fromString $+        \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"+    put \"\/user\/:id\" $ do+      ...+@++-}+module Web.Frank+  ( get+  , post+  , put+  , delete+  , options+  ) where++import Network.HTTP.Types+import Web.Simple.Router+import qualified Data.ByteString as S++-- | Helper method+frankMethod :: Routeable r => StdMethod -> S.ByteString -> r -> Route ()+frankMethod method pattern = routeMethod method . routePattern pattern++-- | Matches the GET method on the given URL pattern+get :: Routeable r => S.ByteString -> r -> Route ()+get = frankMethod GET++-- | Matches the POST method on the given URL pattern+post :: Routeable r => S.ByteString -> r -> Route ()+post = frankMethod POST++-- | Matches the PUT method on the given URL pattern+put :: Routeable r => S.ByteString -> r -> Route ()+put = frankMethod PUT++-- | Matches the DELETE method on the given URL pattern+delete :: Routeable r => S.ByteString -> r -> Route ()+delete = frankMethod DELETE++-- | Matches the OPTIONS method on the given URL pattern+options :: Routeable r => S.ByteString -> r -> Route ()+options = frankMethod OPTIONS+

@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+module Web.REST+  ( RESTController+  , index, show, create, update, delete+  , edit, new+  ) where++import Prelude hiding (show)++import Control.Monad.Trans.State+import Data.Conduit+import Network.Wai.Responses+import Web.Simple.Router+import Network.HTTP.Types++data RESTControllerState = RESTControllerState+  { restIndex   :: Route ()+  , restShow    :: Route ()+  , restCreate  :: Route ()+  , restUpdate  :: Route ()+  , restDelete  :: Route ()+  , restEdit    :: Route ()+  , restNew     :: Route ()+  }++defaultRESTControllerState :: RESTControllerState+defaultRESTControllerState = RESTControllerState+  { restIndex   = routeAll $ notFound+  , restShow    = routeAll $ notFound+  , restCreate  = routeAll $ notFound+  , restUpdate  = routeAll $ notFound+  , restDelete  = routeAll $ notFound+  , restEdit    = routeAll $ notFound+  , restNew     = routeAll $ notFound+  }++instance Routeable RESTControllerState where+  runRoute controller = runRoute $ do+    routeMethod GET $ do+      routeTop $ restIndex controller+      routeName "new" $ restNew controller+      routeVar "id" $ do+        routeTop $ restShow controller+        routeName "edit" $ restEdit controller++    routeMethod POST $ routeTop $ restCreate controller++    routeMethod PUT $ routeVar "id" $ restUpdate controller++    routeMethod DELETE $ routeVar "id" $ restDelete controller++type RESTControllerM a = StateT RESTControllerState (ResourceT IO) a++instance Routeable (RESTControllerM a) where+  runRoute controller = rt+    where rt req = do+            (_, st) <- runStateT controller defaultRESTControllerState+            runRoute st req++type RESTController = RESTControllerM ()++index :: Routeable r => r -> RESTController+index route = modify $ \controller ->+  controller { restIndex = routeAll route }++create :: Routeable r => r -> RESTController+create route = modify $ \controller ->+  controller { restCreate = routeAll route }++edit :: Routeable r => r -> RESTController+edit route = modify $ \controller ->+  controller { restEdit = routeAll route }++new :: Routeable r => r -> RESTController+new route = modify $ \controller ->+  controller { restNew = routeAll route }++show :: Routeable r => r -> RESTController+show route = modify $ \controller ->+  controller { restShow = routeAll route }++update :: Routeable r => r -> RESTController+update route = modify $ \controller ->+  controller { restUpdate = routeAll route }++delete :: Routeable r => r -> RESTController+delete route = modify $ \controller ->+  controller { restDelete = routeAll route }+

@@ -0,0 +1,10 @@+module Web.Simple (+    module Web.Simple.Router+  , module Web.Simple.Responses+  , module Web.Simple.Controller+  ) where++import Web.Simple.Router+import Web.Simple.Responses+import Web.Simple.Controller+

@@ -0,0 +1,151 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}++{- | 'Controller' provides a convenient syntax for writting 'Application'+  code as a Monadic action with access to an HTTP request, rather than a+  function that takes the request as an argument. This module also defines some+  helper functions that leverage this feature. For example, 'redirectBack'+  reads the underlying request to extract the referer and returns a redirect+  response:++  @+    myController = do+      ...+      if badLogin then+        redirectBack+        else+          ...+  @+-}++module Web.Simple.Controller+  ( Controller+  -- * Utility functions+  , redirectBack+  , redirectBackOr+  , queryParam+  , parseForm+  , respond+  -- * Low level functions+  , request+  , body+  ) where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Conduit+import Data.Conduit.List as CL+import Network.HTTP.Types.Header+import Network.Wai+import Network.Wai.Parse+import Web.Simple.Responses+import Web.Simple.Router++data ControllerState = ControllerState { csRequest :: Request }++-- | A 'Controller' is a 'Reader' monad that contains the HTTP request in its+-- environment. A 'Controller' is 'Routeable' simply by running the 'Reader'.+type Controller = ReaderT ControllerState (ResourceT IO)++instance Routeable (Controller Response) where+  runRoute controller req = fmap Just $+    runReaderT controller $ ControllerState req++-- | Reads the underlying 'Request'+request :: Controller Request+request = fmap csRequest ask++-- | Redirect back to the referer. If the referer header is not present+-- redirect to root (i.e., @\/@).+redirectBack :: Controller Response+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back to the referer. If the referer header is not present+-- fallback on the given 'Response'.+redirectBackOr :: Response -- ^ Fallback 'Response'+               -> Controller Response+redirectBackOr def = do+  mrefr <- requestHeader "referer"+  case mrefr of+    Just refr -> return $ redirectTo $ S8.unpack refr+    Nothing   -> return def++-- | Looks up the parameter name in the request's query string and returns the+-- value as a 'S8.ByteString' or 'Nothing'.+--+-- For example, for a request with query string: \"?foo=bar&baz=7\",+-- @+--   queryParam \"foo\"+-- @+--+-- would return /Just "bar"/, but+--+-- @+--   queryParam \"zap\"+-- @+--+-- would return /Nothing/+queryParam :: S8.ByteString -- ^ Parameter name+           -> Controller (Maybe S8.ByteString)+queryParam varName = do+  qr <- fmap queryString request+  case lookup varName qr of+    Just n -> return n+    _ -> return Nothing++-- | An alias for 'return' that's helps the the compiler type a code block as a+-- 'Controller'. For example, when using the 'Network.Wai.Frank' routing DSL to+-- define a simple route that justs returns a 'Response', 'respond' can be used+-- to avoid explicit typing of the argument:+--+-- @+--   get \"/\" $ do+--     someSideEffect+--     respond $ okHtml \"Hello World\"+-- @+--+-- instead of:+--+-- @+--   get \"/\" $ (do+--     someSideEffect+--     return $ okHtml \"Hello World\") :: Controller Response+-- @+respond :: Routeable r => r -> Controller r+respond = return++-- | Returns the value of the given request header or 'Nothing' if it is not+-- present in the HTTP request.+requestHeader :: HeaderName -> Controller (Maybe S8.ByteString)+requestHeader name = do+  req <- request+  return $ lookup name $ requestHeaders req++-- | Reads and returns the body of the HTTP request.+body :: Controller L8.ByteString+body = do+  bd <- fmap requestBody request+  lift $ bd $$ (CL.consume >>= return . L8.fromChunks)++-- | Parses a HTML form from the request body. It returns a list of 'Param's as+-- well as a list of 'File's, which are pairs mapping the name of a /file/ form+-- field to a 'FileInfo' pointing to a temporary file with the contents of the+-- upload.+--+-- @+--   myController = do+--     (prms, files) <- parseForm+--     let mPicFile = lookup \"profile_pic\" files+--     case mPicFile of+--       Just (picFile) -> do+--         sourceFile (fileContent picFile) $$+--           sinkFile (\"images/\" ++ (fileName picFile))+--         respond $ redirectTo \"/\"+--       Nothing -> redirectBack+-- @+parseForm :: Controller ([Param], [(S.ByteString, FileInfo FilePath)])+parseForm = do+  request >>= lift . (parseRequestBody tempFileBackEnd)+

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module defines some convenience functions for creating responses.+module Web.Simple.Responses+  ( ok, okHtml+  , movedTo, redirectTo+  , badRequest, requireBasicAuth, forbidden+  , notFound+  , serverError+  ) where++import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.HTTP.Types+import Network.Wai++-- | Type alias for 'S8.ByteString'+type ContentType = S8.ByteString++-- | Creates a 200 (OK) 'Response' with the given content-type and resposne+-- body+ok :: ContentType -> L8.ByteString -> Response+ok contentType body =+  responseLBS status200 [(hContentType, contentType)] body++-- | Helper to make responses with content-type \"text/html\"+mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response+mkHtmlResponse stat hdrs =+  responseLBS stat ((hContentType, S8.pack "text/html"):hdrs)++-- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the+-- given resposne body+okHtml :: L8.ByteString -> Response+okHtml body =+  mkHtmlResponse status200 [] body++-- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to+-- that URL.+movedTo :: String -> Response+movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>301 Moved Permanently</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Moved Permanently</H1>\n\+              \<P>The document has moved <A HREF=\""+             , L8.pack url+             , L8.pack "\">here</A>\n\+                       \</BODY></HTML>\n"]++-- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.+redirectTo :: String -> Response+redirectTo url = mkHtmlResponse status303 [(hLocation, S8.pack url)] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>303 See Other</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>See Other</H1>\n\+              \<P>The document has moved <A HREF=\""+             , L8.pack url+             , L8.pack "\">here</A>\n\+                       \</BODY></HTML>\n"]++-- | Returns a 400 (Bad Request) 'Response'.+badRequest :: Response+badRequest = mkHtmlResponse status400 [] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>400 Bad Request</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Bad Request</H1>\n\+              \<P>Your request could not be understood.</P>\n\+                       \</BODY></HTML>\n"]++-- | Returns a 401 (Authorization Required) 'Response' requiring basic+-- authentication in the given realm.+requireBasicAuth :: String -> Response+requireBasicAuth realm = mkHtmlResponse status401+  [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>401 Authorization Required</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Authorization Required</H1>\n\+                       \</BODY></HTML>\n"]++-- | Returns a 403 (Forbidden) 'Response'.+forbidden :: Response+forbidden = mkHtmlResponse status403 [] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>403 Forbidden</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Forbidden</H1>\n\+              \<P>You don't have permission to access this page.</P>\n\+                       \</BODY></HTML>\n"]++-- | Returns a 404 (Not Found) 'Response'.+notFound :: Response+notFound = mkHtmlResponse status404 [] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>404 Not Found</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Not Found</H1>\n\+              \<P>The requested URL was not found on this server.</P>\n\+                       \</BODY></HTML>\n"]++-- | Returns a 500 (Server Error) 'Response'.+serverError :: Response+serverError= mkHtmlResponse status500 [] html+  where html = L8.concat+             [L8.pack+              "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+              \<HTML><HEAD>\n\+              \<TITLE>500 Internal Server Error</TITLE>\n\+              \</HEAD><BODY>\n\+              \<H1>Internal Server Error</H1>\n\+              \</BODY></HTML>\n"]+

@@ -0,0 +1,240 @@+{-# LANGUAGE FlexibleInstances #-}+{- |++Conceptually, a route is function that, given an HTTP request, may return+an action (something that would return a response for the client if run).+Routes can be concatenated--where each route is evaluated until one+matches--and nested. Routes are expressed through the 'Routeable' type class.+'runRoute' transforms an instance of 'Routeable' to a function from 'Request'+to a monadic action (in the 'ResourceT' monad) that returns a+'Maybe' 'Response'. The return type was chosen to be monadic so routing+decisions can depend on side-effects (e.g. a random number or counter for A/B+testing, IP geolocation lookup etc').++-}++module Web.Simple.Router+  (+  -- * Example+  -- $Example+    Routeable(..)+  , mkRouter+  -- * Route Monad+  , Route(..)+  -- * Common Routes+  , routeAll, routeHost, routeTop, routeMethod+  , routePattern, routeName, routeVar+  ) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Monoid+import Data.Conduit+import qualified Data.Text as T+import Network.HTTP.Types+import Network.Wai+import Web.Simple.Responses+++{- |+'Routeable' types can be converted into a route function using 'runRoute'.+If the route is matched it returns a 'Response', otherwise 'Nothing'.++In general, 'Routeable's are data-dependant (on the 'Request'), but don't have+to be. For example, 'Application' is an instance of 'Routeable' that always+returns a 'Response':++@+  instance Routeable Application where+    runRoute app req = app req >>= return . Just+@++-}+class Routeable r where+  runRoute :: r -> Request -> ResourceT IO (Maybe Response)++-- | Converts any 'Routeable' into an 'Application' that can be passed directly+-- to a WAI server.+mkRouter :: Routeable r => r -> Application+mkRouter route req = do+  mapp <- runRoute route req+  case mapp of+    Just resp -> return resp+    Nothing -> return notFound+++instance Routeable Application where+  runRoute app req = fmap Just $ app req++instance Routeable Response where+  runRoute resp = const . return . Just $ resp++{- |+The 'Route' type is a basic instance of 'Routeable' that simply holds the+routing function and an arbitrary additional data parameter. The power is+derived from the instances of 'Monad' and 'Monoid', which allow the+simple construction of complex routing rules using either lists ('Monoid') or+do-notation. Moreover, because of it's simple type, any 'Routeable' can be used+as a 'Route' (using 'routeAll' or by applying it to 'runRoute'), making it+possible to leverage the monadic or monoid syntax for any 'Routeable'.++Commonly, route functions that construct a 'Route' only inspect the 'Request'+and other parameters. For example, 'routeHost' looks at the hostname:++@+  routeHost :: Routeable r => S.ByteString -> r -> Route ()+  routeHost host route = Route func ()+    where func req = if host == serverName req+                       then runRoute route req+                       else return Nothing+@++However, because the result of a route is in the+'ResourceT' monad, routes have all the power of an 'Application' and can make+state-dependant decisions. For example, it is trivial to implement a route that+succeeds for every other request (perhaps for A/B testing):++@+  routeEveryOther :: (Routeable r1, Routeable r2)+                  => TVar Int -> r1 -> r2 -> Route ()+  routeEveryOther counter r1 r2 = Route func ()+    where func req = do+            i <- liftIO . atomically $ do+                    i' <- readTVar counter+                    writeTVar counter (i' + 1)+                    return i'+            if i `mod` 2 == 0+              then runRoute r1 req+              else runRoute r2 req+@++-}+data Route a = Route (Request -> ResourceT IO (Maybe Response)) a++mroute :: (Request -> ResourceT IO (Maybe Response)) -> Route ()+mroute handler = Route handler ()++instance Monad Route where+  return a = Route (const $ return Nothing) a+  (Route rtA valA) >>= fn =+    let (Route rtB valB) = fn valA+    in Route (\req -> do+      resA <- rtA req+      case resA of+        Nothing -> rtB req+        Just _ -> return resA) valB++instance Monoid (Route ()) where+  mempty = mroute $ const $ return Nothing+  mappend (Route a _) (Route b _) = mroute $ \req -> do+    c <- a req+    case c of+      Nothing -> b req+      Just _ -> return c++instance Routeable (Route a) where+  runRoute (Route rtr _) req = rtr req++-- | A route that always matches (useful for converting a 'Routeable' into a+-- 'Route').+routeAll :: Routeable r => r -> Route ()+routeAll = mroute . runRoute++-- | Matches on the hostname from the 'Request'. The route only successeds on+-- exact matches.+routeHost :: Routeable r => S.ByteString -> r -> Route ()+routeHost host route = mroute $ \req ->+  if host == serverName req then runRoute route req+  else return Nothing++-- | Matches if the path is empty. Note that this route checks that 'pathInfo'+-- is empty, so it works as expected when nested under namespaces or other+-- routes that pop the 'pathInfo' list.+routeTop :: Routeable r => r -> Route ()+routeTop route = mroute $ \req ->+  if null (pathInfo req)  || (T.length . head $ pathInfo req) == 0+    then runRoute route req+    else return Nothing++-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')+routeMethod :: Routeable r => StdMethod -> r -> Route ()+routeMethod method route = mroute $ \req ->+  if renderStdMethod method == requestMethod req then+    runRoute route req+    else return Nothing++-- | Routes the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be added+-- to 'queryString' (see 'routeVar')+--+--  * \/posts\/:id+--+--  * \/posts\/:id\/new+--+--  * \/:date\/posts\/:category\/new+--+routePattern :: Routeable r => S.ByteString -> r -> Route ()+routePattern pattern route =+  let patternParts = map T.unpack $ decodePathSegments pattern+  in routeTop $ foldr mkRoute (mroute . runRoute $ route) patternParts+  where mkRoute (':':varName) = routeVar (S8.pack varName)+        mkRoute varName = routeName (S8.pack varName)++-- | Matches if the first directory in the path matches the given 'ByteString'+routeName :: Routeable r => S.ByteString -> r -> Route ()+routeName name route = mroute $ \req ->+  let poppedHdrReq = req { pathInfo = (tail . pathInfo $ req) }+  in if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req+    then runRoute route poppedHdrReq+    else return Nothing++-- | Always matches if there is at least one directory in 'pathInfo' but and+-- adds a parameter to 'queryString' where the key is the first parameter and+-- the value is the directory consumed from the path.+routeVar :: Routeable r => S.ByteString -> r -> Route ()+routeVar varName route = mroute $ \req ->+  let varVal = S8.pack . T.unpack . head . pathInfo $ req+      poppedHdrReq = req {+          pathInfo = (tail . pathInfo $ req)+        , queryString = (varName, Just varVal):(queryString req)}+  in if (length $ pathInfo req) > 0 then runRoute route poppedHdrReq+  else return Nothing++{- $Example+ #example#++The most basic 'Routeable' types are 'Application' and 'Response'. Reaching+either of these types marks a termination in the routing lookup. This module+exposes a monadic type 'Route' which makes it easy to create routing logic+in a DSL-like fashion.++'Route's are concatenated using the '>>' operator (or using do-notation).+In the end, any 'Routeable', including a 'Route' is converted to an+'Application' and passed to the server using 'mkRouter':++@++  mainAction :: Application+  mainAction req = ...++  signinForm :: Application+  signinForm req = ...++  login :: Application+  login req = ...++  updateProfile :: Application+  updateProfile req = ...++  main :: IO ()+  main = runSettings defaultSettings $ mkRouter $ do+    routeTop mainAction+    routeName \"sessions\" $ do+      routeMethod GET signinForm+      routeMethod POST login+    routeMethod PUT $ routePattern \"users/:id\" updateProfile+    routeAll $ responseLBS status404 [] \"Are you in the right place?\"+@++-}+

@@ -2,8 +2,8 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                wai-lite-version:             0.1.0.0-synopsis: A minimalist web framework for WAI web applications+version:             0.2.0.0+synopsis: DEPCRECATED (use package "simple" instead) A minimalist web framework for WAI web applications description: A minimalist web framework for WAI web applications license:             GPL-3 license-file:        LICENSE@@ -15,19 +15,24 @@  library   build-depends:-    base ==4.5.*,-    conduit == 0.5.*,-    wai ==1.3.*,-    wai-extra ==1.3.*,-    http-types ==0.7.1,-    text == 0.11.*,-    transformers ==0.3.*,-    bytestring ==0.9.*,-    mtl ==2.1.*+    base >=4.5 && < 5.0,+    conduit >= 0.5,+    wai >= 1.3 && < 2.0,+    wai-extra >= 1.3 && < 2.0,+    http-types >= 0.7.1,+    text >= 0.11,+    transformers >= 0.3,+    bytestring >= 0.9    ghc-options: -Wall    exposed-modules:+    Web.Simple,+    Web.Simple.Controller,+    Web.Simple.Responses,+    Web.Simple.Router,+    Web.Frank,+    Web.REST,     Network.Wai.Controller,     Network.Wai.Router,     Network.Wai.REST,