wai-routes 0.4.1 → 0.5.0
raw patch · 7 files changed
+133/−50 lines, 7 filesdep +aesondep ~wai
Dependencies added: aeson
Dependency ranges changed: wai
Files
- README.md +2/−1
- examples/Example.hs +10/−21
- src/Network/Wai/Middleware/Routes.hs +6/−0
- src/Network/Wai/Middleware/Routes/ContentTypes.hs +3/−3
- src/Network/Wai/Middleware/Routes/Handler.hs +98/−12
- src/Network/Wai/Middleware/Routes/Routes.hs +1/−1
- wai-routes.cabal +13/−12
README.md view
@@ -1,4 +1,4 @@-Wai Routes (wai-routes-0.4.1)+Wai Routes (wai-routes-0.5.0) ============================== [](https://travis-ci.org/ajnsit/wai-routes)@@ -82,4 +82,5 @@ * 0.3.4 : Added 'liftResourceT' to lift a ResourceT into HandlerM * 0.4.0 : Wai 2 compatibility. Replaced 'liftResourceT' with 'lift' * 0.4.1 : showRoute now returns "/" instead of ""+* 0.5.0 : Added raw,text,html,json helpers. Update to wai-2.1.
examples/Example.hs view
@@ -9,7 +9,7 @@ import Network.HTTP.Types import qualified Data.Text as T import Data.Text (Text)-import Data.Aeson+import Data.Aeson hiding (json) import Data.IORef import qualified Data.Map as M import Control.Monad.Trans@@ -44,13 +44,6 @@ -- Handlers --- Standard Json output-jsonOut :: ToJSON a => a -> Response-jsonOut = responseLBS status200 jsonHeaders . encode- where- jsonHeaders :: ResponseHeaders- jsonHeaders = [contentType typeJson]- -- Util: Fetch the database getDB :: HandlerM MyRoute DB getDB = do@@ -59,7 +52,8 @@ -- Display the possible actions getHomeR :: Handler MyRoute-getHomeR = runHandlerM $ return $ jsonOut $ M.fromList (+getHomeR = runHandlerM $ do+ json $ M.fromList ( [("description", [["Simple User database Example"]]) ,("links" ,[["home", showRoute HomeR]@@ -74,10 +68,9 @@ getUsersR = runHandlerM $ do db <- getDB let dblinks = map linkify db- let out = M.fromList (+ json $ M.fromList ( [("description", [["Users List"]]) ,("links", dblinks)] :: [(Text, [[Text]])] )- return $ jsonOut out where linkify user = [userName user, showRoute $ UserR (userId user) UserRootR] @@ -86,9 +79,9 @@ getUserRootR i = runHandlerM $ do db <- getDB case ulookup i db of- Nothing -> return $ jsonOut ("ERROR: User not found" :: Text)+ Nothing -> json ("ERROR: User not found" :: Text) Just user -> do- let out = M.fromList (+ json $ M.fromList ( [("description", [["User details"]]) ,("data" ,[["Id", T.pack $ show $ userId user]@@ -102,24 +95,21 @@ ] ) ] :: [(Text, [[Text]])] )- return $ jsonOut out where ulookup _ [] = Nothing ulookup ui (u:us) = if userId u == ui then Just u else ulookup ui us -- Delete a user: GET getUserDeleteR :: Int -> Handler MyRoute-getUserDeleteR _ = runHandlerM $ return $ jsonOut err- where err = ["DELETE","please use POST"]::[Text]+getUserDeleteR _ = runHandlerM $ json (["DELETE","please use POST"]::[Text]) -- Delete a user: POST postUserDeleteR :: Int -> Handler MyRoute-postUserDeleteR _ = runHandlerM $ return $ jsonOut err- where err = ["DELETE","not implemented"]::[Text]+postUserDeleteR _ = runHandlerM $ json (["DELETE","not implemented"]::[Text]) -- Demonstrate skipping routes getSkipR :: [Text] -> Handler MyRoute-getSkipR _ = runHandlerM next+getSkipR _ = runHandlerM $ next >> return () -- Initial database initdb :: [User]@@ -137,8 +127,7 @@ |] getSkippedR :: [Text] -> Handler MySkippedRoute-getSkippedR rest = runHandlerM $ return $ jsonOut err- where err = ["SKIPPED ROUTE: "] ++ rest+getSkippedR rest = runHandlerM $ json $ ["SKIPPED ROUTE: "] ++ rest -- The application that uses our route -- NOTE: We use the Route Monad to simplify routing
src/Network/Wai/Middleware/Routes.hs view
@@ -53,6 +53,12 @@ , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data , master -- | Access the master datatype+ , header -- | Add a header to the response+ , status -- | Set the response status+ , raw -- | Set the raw response body+ , json -- | Set the json response body+ , text -- | Set the text response body+ , html -- | Set the html response body , next -- | Run the next application in the stack ) where
src/Network/Wai/Middleware/Routes/ContentTypes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# LANGUAGE OverloadedStrings, TypeFamilies #-} {- | Module : Network.Wai.Middleware.Routes.ContentTypes@@ -29,8 +29,8 @@ -- | Creates a content type header -- Ready to be passed to `responseLBS`-contentType :: ByteString -> (HeaderName, ByteString)-contentType typ = ("Content-Type", typ)+contentType :: HeaderName+contentType = "Content-Type" typeHtml :: ByteString typeHtml = "text/html; charset=utf-8"
src/Network/Wai/Middleware/Routes/Handler.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} {- | Module : Network.Wai.Middleware.Routes.Handler Copyright : (c) Anupam Jain 2013@@ -15,41 +15,127 @@ , runHandlerM -- | Run a HandlerM to get a Handler , request -- | Access the request data , master -- | Access the master datatype+ , header -- | Add a header to the response+ , status -- | Set the response status+ , raw -- | Set the raw response body+ , json -- | Set the json response body+ , text -- | Set the text response body+ , html -- | Set the html response body , next -- | Run the next application in the stack ) where -import Network.Wai (Request, Response)-import Control.Monad.Reader (ReaderT, ask, runReaderT, MonadReader, MonadIO, lift, MonadTrans)+import Network.Wai (Request, Response, responseBuilder)+import Control.Monad (liftM)+import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, MonadTrans) import Network.Wai.Middleware.Routes.Routes (RequestData, Handler, waiReq, runNext)+import Network.Wai.Middleware.Routes.ContentTypes (contentType, typeHtml, typeJson, typePlain) +import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import Network.HTTP.Types.Header (HeaderName())+import Network.HTTP.Types.Status (Status(), status200)++import Data.Aeson (ToJSON)+import qualified Data.Aeson as A++import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding (encodeUtf8)++import Blaze.ByteString.Builder (fromLazyByteString)+ -- | The internal implementation of the HandlerM monad-newtype HandlerMI master m a = H { extractH :: ReaderT (HandlerState master) m a }- deriving (Monad, MonadIO, Functor, MonadTrans, MonadReader (HandlerState master))+-- TODO: Should change this to StateT over ReaderT (but performance may suffer)+newtype HandlerMI master m a = H { extractH :: StateT (HandlerState master) m a }+ deriving (Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState master)) -- | The HandlerM Monad type HandlerM master a = HandlerMI master IO a -- | The state kept in a HandlerM Monad data HandlerState master = HandlerState- { getMaster :: master+ { getMaster :: master , getRequestData :: RequestData+ , respHeaders :: [(HeaderName, ByteString)]+ , respStatus :: Status+ , respBody :: BL.ByteString+ , respResp :: Maybe Response } -- | "Run" HandlerM, resulting in a Handler-runHandlerM :: HandlerM master Response -> Handler master-runHandlerM h m r = runReaderT (extractH h) (HandlerState m r)+runHandlerM :: HandlerM master () -> Handler master+runHandlerM h m req = do+ (_, state) <- runStateT (extractH h) (HandlerState m req [] status200 "" Nothing)+ case respResp state of+ Nothing -> return $ toResp state+ Just resp -> return resp +toResp :: HandlerState master -> Response+toResp hs = responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs)+ -- | Get the master master :: HandlerM master master-master = ask >>= return . getMaster+master = liftM getMaster get -- | Get the request request :: HandlerM master Request-request = ask >>= return . waiReq . getRequestData+request = liftM (waiReq . getRequestData) get +-- | Add a header to the application response+-- TODO: Differentiate between setting and adding headers+header :: HeaderName -> ByteString -> HandlerM master ()+header h s = modify $ addHeader h s+ where+ addHeader :: HeaderName -> ByteString -> HandlerState master -> HandlerState master+ addHeader h b s@(HandlerState {respHeaders=hs}) = s {respHeaders=(h,b):hs}++-- | Set the response status+status :: Status -> HandlerM master ()+status s = modify $ setStatus s+ where+ setStatus :: Status -> HandlerState master -> HandlerState master+ setStatus s st = st{respStatus=s}++-- | Set the response body+-- TODO: Add functions to append to body, and also to flush body contents+raw :: BL.ByteString -> HandlerM master ()+raw s = modify $ setBody s+ where+ setBody :: BL.ByteString -> HandlerState master -> HandlerState master+ setBody s st = st{respBody=s}++-- Standard response bodies++-- | Set the body of the response to the JSON encoding of the given value. Also sets \"Content-Type\"+-- header to \"application/json\".+json :: ToJSON a => a -> HandlerM master ()+json a = do+ header contentType typeJson+ raw $ A.encode a++-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\"+-- header to \"text/plain\".+text :: Text -> HandlerM master ()+text t = do+ header contentType typePlain+ raw $ encodeUtf8 t++-- | Set the body of the response to the given 'Text' value. Also sets \"Content-Type\"+-- header to \"text/html\".+html :: BL.ByteString -> HandlerM master ()+html s = do+ header contentType typeHtml+ raw s+ -- | Run the next application-next :: HandlerM master Response-next = ask >>= H . lift . runNext . getRequestData+next :: HandlerM master ()+next = do+ s <- get+ resp <- lift $ runNext $ getRequestData s+ modify $ setResp resp+ where+ setResp :: Response -> HandlerState master -> HandlerState master+ setResp r st = st{respResp=Just r}
src/Network/Wai/Middleware/Routes/Routes.hs view
@@ -92,7 +92,7 @@ app404 _master = runNext app405 :: Handler master-app405 _master _req = return $ responseBuilder status405 [contentType typePlain] $ fromByteString "405 - Method Not Allowed"+app405 _master _req = return $ responseBuilder status405 [(contentType, typePlain)] $ fromByteString "405 - Method Not Allowed" -- | Generates all the things needed for efficient routing, -- including your application's `Route` datatype, and
wai-routes.cabal view
@@ -1,5 +1,5 @@ name : wai-routes-version : 0.4.1+version : 0.5.0 cabal-version : >=1.10 build-type : Simple license : MIT@@ -63,19 +63,20 @@ source-repository this type : git- location : http://github.com/ajnsit/wai-routes/tree/v0.4.1- tag : v0.4.1+ location : http://github.com/ajnsit/wai-routes/tree/v0.5.0+ tag : v0.5.0 library- build-depends : base >= 4.6.0.1 && < 4.7- , wai >= 2.0.0 && < 2.1- , text >= 0.11.3.1 && < 0.12- , bytestring >= 0.10.0.2 && < 0.11- , http-types >= 0.8.3 && < 0.9- , blaze-builder >= 0.3.3.2 && < 0.4- , template-haskell >= 2.8.0.0 && < 2.9- , yesod-routes >= 1.2.0.6 && < 1.3- , mtl >= 2.1.2 && < 2.2+ build-depends: base >= 4.6.0.1 && < 4.7+ , wai >= 2.0.0 && < 2.2+ , text >= 0.11.3.1 && < 0.12+ , bytestring >= 0.10.0.2 && < 0.11+ , http-types >= 0.8.3 && < 0.9+ , blaze-builder >= 0.3.3.2 && < 0.4+ , template-haskell >= 2.8.0.0 && < 2.9+ , yesod-routes >= 1.2.0.6 && < 1.3+ , mtl >= 2.1.2 && < 2.2+ , aeson >= 0.7.0.1 && < 0.8 exposed-modules: Network.Wai.Middleware.Routes Network.Wai.Middleware.Routes.Routes Network.Wai.Middleware.Routes.Monad