iterio-server 0.0 → 0.1

raw patch · 7 files changed

+442/−24 lines, 7 filesdep +mtldep +splitdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, split, transformers

API changes (from Hackage documentation)

Files

• Data/IterIO/Http/Support/Action.hs +125/−0
• Data/IterIO/Http/Support/Responses.hs +45/−0
• Data/IterIO/Http/Support/RestController.hs +102/−0
• Data/IterIO/Http/Support/Routing.hs +35/−0
• Data/IterIO/Server/TCPServer.hs +56/−22
• Examples/BasicSite.hs +66/−0
• iterio-server.cabal +13/−2

@@ -0,0 +1,125 @@+-- |Defines the 'Action' monad which abstracts some of the details of handling+-- HTTP requests with IterIO.+module Data.IterIO.Http.Support.Action (+    Action+  , Param(..)+  , routeAction+  , routeActionPattern+  , params+  , param+  , getHttpReq+  , setSession+  , destroySession+  , requestHeader+) where++import Control.Monad.Trans+import Control.Monad.Trans.State+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.List.Split+import Data.IterIO+import Data.IterIO.Http+import Data.IterIO.HttpRoute++-- | A request parameter from a form field in the HTTP body+data Param = Param {+    paramKey :: S.ByteString+  , paramValue :: L.ByteString+  , paramHeaders :: [(S.ByteString, S.ByteString)] -- ^ Header of a @multipart/form-data@ post+}++-- | A 'StateT' monad in which requests can be handled. It keeps track of the+-- 'HttpReq', the form parameters from the request body and an 'HttpResp' used+-- to reply to the client.+type Action t m a = StateT (HttpReq t, HttpResp m, [Param]) m a++-- | Routes an 'Action'+routeAction :: Monad m => Action t m () -> HttpRoute m t+routeAction action = routeFn $ runAction action++-- | Routes an 'Action' to the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be passed+-- into the 'Action' as extra 'Param's. Some examples of URL patters:+--+--  * \/posts\/:id+--+--  * \/posts\/:id\/new+--+--  * \/:date\/posts\/:category\/new+--+routeActionPattern :: Monad m => String -> Action t m () -> HttpRoute m t+routeActionPattern pattern action = foldl' addVar (routeFn $ runActionWithRouteNames patternList action) patternList+  where patternList = reverse $ filter ((/= 0) . length) $ splitOn "/" pattern+        addVar rt (':':_) = routeVar rt+        addVar rt name = routeName name rt++-- |Sets a the value for \"_sess\" in the cookie to the given string.+setSession :: Monad m => String -> Action t m ()+setSession cookie = StateT $ \(req, resp, prm) ->+  let cookieHeader = S.pack $ "Set-Cookie: _sess=" ++ cookie ++ "; path=/;"+  in return $ ((), (req, resp { respHeaders = cookieHeader:(respHeaders resp)}, prm))++-- |Removes the \"_sess\" key-value pair from the cookie.+destroySession :: Monad m => Action t m ()+destroySession = StateT $ \(req, resp, prm) ->+  let cookieHeader = S.pack $ "Set-Cookie: _sess=; path=/; expires=Thu, Jan 01 1970 00:00:00 UTC;"+  in return $ ((), (req, resp { respHeaders = cookieHeader:(respHeaders resp)}, prm))++-- |Returns the value of an Http Header from the request if it exists otherwise+-- 'Nothing'+requestHeader :: Monad m => S.ByteString -> Action t m (Maybe S.ByteString)+requestHeader name = do+  httpReq <- getHttpReq+  return $ lookup name (reqHeaders httpReq)++-- |Returns the 'HttpReq' for the current request.+getHttpReq :: Monad m => Action t m (HttpReq t)+getHttpReq = StateT $ \(req, resp, prm) -> return $ (req, (req, resp, prm))++-- | Returns a list of all 'Param's.+params :: Monad m => Action t m ([Param])+params = StateT $ \s@(_, _, prm) -> return (prm, s)++-- | Returns the 'Param' corresponding to the specified key or 'Nothing'+-- if one is not present in the request.+param :: Monad m => S.ByteString -> Action t m (Maybe Param)+param key = do+  prms <- params+  return $ foldl go Nothing prms+  where go Nothing p = if paramKey p == key then Just p else Nothing+        go a _ = a+++runAction :: Monad m+              => Action s m ()+              -> HttpReq s+              -> Iter L.ByteString m (HttpResp m)+runAction = runActionWithRouteNames []++runActionWithRouteNames :: Monad m+              => [String]+              -> Action s m ()+              -> HttpReq s+              -> Iter L.ByteString m (HttpResp m)+runActionWithRouteNames routeNames action req = do+  prms <- paramList req+  let pathLstParams = pathLstToParams req routeNames+  (_, (_, response, _)) <- lift $ (runStateT action) (req, mkHttpHead stat200, pathLstParams ++ prms)+  return $ response+++pathLstToParams :: HttpReq s -> [String] -> [Param]+pathLstToParams req routeNames = result+  where (result, _) = foldl go ([], reqPathParams req) routeNames+        go (prms, plst) (':':var) = ((transform var $ head plst):prms, tail plst)+        go s _ = s+        transform k v = Param (S.pack k) (L.fromChunks [v]) []++paramList :: Monad m => HttpReq s -> Iter L.ByteString m [Param]+paramList req = foldForm req handle []+  where handle accm field = do+          val <- pureI+          return $ (Param (ffName field) val (ffHeaders field)):accm+

@@ -0,0 +1,45 @@+-- |Utility functions for responding to HTTP requests from within an 'Action'.+module Data.IterIO.Http.Support.Responses (+    render+  , redirectTo+  , respond404+  , respondStat+) where++import Control.Monad.Trans.State+import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.IterIO+import Data.IterIO.Http.Support.Action (Action)+import Data.IterIO.Http++-- | Responds to the client with an empty @404@ (Not Found) response.+respond404 :: Monad m => Action t m ()+respond404 = StateT $+  \(req, _, params) -> return $ ((), (req, resp404 req, params))++-- | Replaces the HTTP status in the current 'HttpResp' with the given+-- 'HttpStatus'.+respondStat :: Monad m => HttpStatus -> Action t m ()+respondStat status = StateT $+  \(req, resp, params) -> return $ ((), (req, resp { respStatus = status }, params))++-- | Responds to the client with a @303@ (Temporary Redirect) response to the given+-- path.+redirectTo :: Monad m+           => String -- ^ The path to redirect to+           -> Action t m ()+redirectTo path = StateT $+  \(req, _, params) -> return $ ((), (req, resp303 path, params))++-- | Responds to the client with a @200@ (Success) response with the given body+-- and mime-type.+render :: Monad m+       => String -- ^ The mime-type of the response (commonly \"text\/html\")+       -> L.ByteString -- ^ The response body+       -> Action t m ()+render ctype text = StateT $ \(req, resp, prm) -> return $ ((), (req, mkResp resp, prm))+  where len = S.pack $ "Content-Length: " ++ show (L.length text)+        ctypeHeader = S.pack $ "Content-Type: " ++ ctype+        mkResp resp = resp { respHeaders = respHeaders resp ++ [ctypeHeader, len],+                        respBody = inumPure text }

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module defines the 'RestController' class+ +module Data.IterIO.Http.Support.RestController (+    RestController(..)+  , routeRestController+) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.IterIO.HttpRoute+import Data.IterIO.Http.Support.Action+import Data.IterIO.Http.Support.Responses+import Data.Monoid++-- |The class @RestController@ allows a set of actions to be routed using+-- RESTful HTTP verbs.+class RestController a where+  -- |GET \/+  restIndex :: Monad m => a -> Action t m ()+  restIndex _ = respond404++  -- |GET \/:id+  --+  -- @id@ is passed in as the second parameter.+  restShow :: Monad m => a -> L.ByteString -> Action t m ()+  restShow _ _ = respond404++  -- |GET \/new+  restNew :: Monad m => a -> Action t m ()+  restNew _ = respond404++  -- |POST \/+  restCreate :: Monad m => a -> Action t m ()+  restCreate _ = respond404++  -- |GET \/:id\/edit+  --+  -- @id@ is passed in as the second parameter.+  restEdit :: Monad m => a -> L.ByteString -> Action t m ()+  restEdit _ _ = respond404++  -- |PUT \/:id+  --+  -- @id@ is passed in as the second parameter.+  --+  -- Since @PUT@ is not supported by many browsers, this action also responds to+  -- requests containing the HTTP header "X-HTTP-Method-Override: PUT"+  -- regardless of the actual HTTP method (@GET@ or @POST@)+  restUpdate :: Monad m => a -> L.ByteString -> Action t m ()+  restUpdate _ _ = respond404++  -- |DELETE \/:id+  -- +  -- @id@ is passed in as the second parameter.+  --+  -- Since @DELETE@ is not supported by many browsers, this action also responds to+  -- requests containing the HTTP header "X-HTTP-Method-Override: DELETE"+  -- regardless of the actual HTTP method (@GET@ or @POST@)+  restDestroy :: Monad m => a -> L.ByteString -> Action t m ()+  restDestroy _ _ = respond404++-- |Runs an action, passing in named parameter.+runWithVar :: Monad m => S.ByteString -> (L.ByteString -> Action t m ()) -> Action t m ()+runWithVar varName controller = do+  (Just var) <- param varName+  controller $ paramValue var++-- |Routes URLs under the given @String@ to actions in a @RestController@. For+-- example+--+-- @+--    routeRestController "posts" myRestController+-- @+--+-- will map the follwoing URLs:+--+--    * GET \/posts => myRestController#restIndex+--+--    * POST \/posts => myRestController#restCreate+--+--    * GET \/posts\/:id => myRestController#restShow+--+--    * GET \/posts\/:id\/edit => myRestController#restEdit+--+--    * GET \/posts\/:id\/new => myRestController#restNew+--+--    * DELETE \/posts\/:id => myRestController#restDestroy+--+--    * PUT \/posts\/:id => myRestController#restUpdate+--+routeRestController :: (Monad m, RestController a) => String -> a -> HttpRoute m t+routeRestController prefix controller = routeName prefix $ mconcat [+    routeTop $ routeMethod "GET" $ routeAction $ restIndex controller+  , routeTop $ routeMethod "POST" $ routeAction $ restCreate controller+  , routeMethod "GET" $ routeActionPattern "/:id/edit" $ runWithVar "id" $ restEdit controller+  , routeMethod "GET" $ routeActionPattern "/new" $ restNew controller+  , routeMethod "GET" $ routeActionPattern "/:id" $ runWithVar "id" $ restShow controller+  , routeMethod "DELETE" $ routeActionPattern "/:id" $ runWithVar "id" $ restDestroy controller+  , routeMethod "PUT" $ routeActionPattern "/:id" $ runWithVar "id" $ restUpdate controller+  ]+

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+-- |Utility functions for routing.+module Data.IterIO.Http.Support.Routing (+    runLHttpRoute+    ) where++import Data.Char+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as S+import Data.Maybe+import Data.IterIO.Http+import Data.IterIO.HttpRoute+import Data.IterIO.Iter++-- |Converts a 'ByteString' to upper-case+upcase :: S.ByteString -> S.ByteString+upcase = S.map toUpper++-- |Like 'runHttpRoute' but replaces @GET@ and @POST@ request headers with the+-- value of the @X-HTTP-Method-Override@ HTTP header if it is present. This+-- allows applicaitons to respond to @DELETE@ and @PUT@ methods even though+-- many browsers do not support those methods.+runLHttpRoute :: Monad m+              => HttpRoute m s+              -> HttpReq s+              -> Iter L.ByteString m (HttpResp m)+runLHttpRoute route req = runHttpRoute route $ transformedReq+  where method = upcase $ reqMethod req+        overrideHeader = lookup "X-HTTP-Method-Override" (reqHeaders req)+        transformedReq+          | method /= "GET" && method /= "POST" = req+          | isJust overrideHeader =+              req{reqMethod = (upcase . fromJust $ overrideHeader)}+          | otherwise = req+

@@ -1,7 +1,9 @@ -- |Generic building blocks for creating TCP Servers based on 'IterIO' module Data.IterIO.Server.TCPServer (-  TCPServer,+  TCPServer(..),   runTCPServer,+  defaultServerAcceptor,+  minimalTCPServer,   simpleHttpServer,   echoServer ) where@@ -15,6 +17,7 @@ import Data.IterIO.Http import Data.ListLike.IO +-- |Sets up a TCP socket to listen on the given port. sockListenTCP :: Net.PortNumber -> IO Net.Socket sockListenTCP pn = do   sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol@@ -25,44 +28,75 @@  -- |'TCPServer' holds all the information necessary to run -- bind to a sock and respond to TCP requests from the network.-data TCPServer inp m out = TCPServer {+data TCPServer inp m = TCPServer {+-- |The TCP port the server will listen for incomming connections on.     serverPort :: Net.PortNumber-  , serverHandler :: Inum inp out m ()+-- |This 'Inum' implements the actual functionality of the server. The input+--  and output of the 'Inum' correspond to the input and output of the socket.+  , serverHandler :: Inum inp inp m ()+-- |A function to transform an accept incomming connection into an iter and onum.+--  Most servers should just use 'defaultSocketAcceptor' but this can be used for+--  special cases, e.g. accepting SSL connections with 'Data.IterIO.SSL.iterSSL'.+  , serverAcceptor :: Net.Socket -> m (Iter inp m (), Onum inp m ())+-- |Must execute the monadic result. Servers operating in the 'IO' Monad can+--  use 'id'.+  , serverResultHandler :: m () -> IO () } -instance Show (TCPServer inp m out) where+instance Show (TCPServer inp m) where   show s = "TCPServer { serverPort: " ++ (show $ serverPort s) ++ " }" +-- |For convenience, a TCPServer in the 'IO' Monad with null defaults:+--+--    * Port 0 (next availabel port)+--+--    * Handler set to 'inumNop'+--+--    * Acceptor set to 'defaultServerAcceptor'+--+--    * Request handler set to 'id' (noop)+--+minimalTCPServer :: (ListLikeIO inp e, ChunkData inp) => TCPServer inp IO+minimalTCPServer = TCPServer 0 inumNop defaultServerAcceptor id++-- |This acceptor creates an 'Iter' and 'Onum' using 'handleI' and+--  'enumHandle' respectively.+defaultServerAcceptor ::  (ListLikeIO inp e,+                           ChunkData inp, MonadIO m)+                      => Net.Socket -> m (Iter inp m (), Onum inp m a)+defaultServerAcceptor sock = liftIO $ do+  h <- Net.socketToHandle sock ReadWriteMode+  hSetBuffering h NoBuffering+  return (handleI h, enumHandle h)+ -- |Runs a 'TCPServer' in a loop.-runTCPServer :: (ListLikeIO inp e, ListLikeIO out e,-                 ChunkData inp, ChunkData out, HasFork m)-              => TCPServer inp m out-              -> m ()+runTCPServer :: (ListLikeIO inp e,+                 ChunkData inp, Monad m)+              => TCPServer inp m+              -> IO () runTCPServer server = do-  sock <- liftIO $ sockListenTCP $ serverPort server+  sock <- sockListenTCP $ serverPort server+  let handler = serverResultHandler server   forever $ do-    (iter, enum) <- liftIO $ do-      (s, _) <- Net.accept sock-      h <- Net.socketToHandle s ReadWriteMode-      hSetBuffering h NoBuffering-      return (handleI h, enumHandle h)-    _ <- fork $ do+    (s, _) <- Net.accept sock+    _ <- forkIO $ handler $ do+      (iter, enum) <- (serverAcceptor server) s       enum |$ serverHandler server .| iter     return ()  -- |Creates a simple HTTP server from an 'HTTPRequestHandler'.-simpleHttpServer :: (HasFork m)-                =>  Net.PortNumber-                ->  HttpRequestHandler m ()-                -> TCPServer L.ByteString m L.ByteString-simpleHttpServer port reqHandler = TCPServer port httpAppHandler+simpleHttpServer :: Net.PortNumber+                 -> HttpRequestHandler IO ()+                 -> TCPServer L.ByteString IO+simpleHttpServer port reqHandler = minimalTCPServer { serverPort = port, serverHandler = httpAppHandler }   where httpAppHandler = mkInumM $ do           req <- httpReqI           resp <- liftI $ reqHandler req           irun $ enumHttpResp resp Nothing+ -- |Creates a 'TCPServer' that echoes each line from the client until EOF.-echoServer :: (HasFork m) => Net.PortNumber -> TCPServer String m String-echoServer port = TCPServer port echoAppHandler+echoServer :: Net.PortNumber -> TCPServer String IO+echoServer port = minimalTCPServer { serverPort = port, serverHandler = echoAppHandler }   where echoAppHandler = mkInumM $ forever $ do           input <- safeLineI           case input of

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.Trans+import qualified Data.ByteString.Lazy.Char8 as L+import Data.IterIO.HttpRoute+import Data.IterIO.Server.TCPServer+import Data.Monoid+import System.Random++import Text.Blaze.Renderer.Utf8 (renderHtml)+import Text.Blaze.Html5 hiding (param)+import Text.Blaze.Html5.Attributes++import Data.IterIO.Http.Support.Action+import Data.IterIO.Http.Support.Responses++main :: IO ()+main = runTCPServer httpServer++quotes :: [String]+quotes = [  +            "Now with more cowbell."+          , "Hot potato grand champion."+          , "Goes all the way to eleven."+          , "Does the Kessel Run in less than 12 parsecs."+          , "Will work for hugs."+          , "Ate a whole wheel of cheese."+          , "Fueled by Mountain Dew"+          , "Saw a MiG 28 do a 4g negative dive."+          , "Has never started a land war in Asia."+          , "Has, like, a ton of Facebook friends."+          , "Always chooses the write homophone."]++httpServer = simpleHttpServer 8080 $ runHttpRoute $ mconcat [+    routeTop $ routeAction welcomeAction+  , routeActionPattern "/factoid/:index" quoteAction+  , routeActionPattern "/factoid" indexAction+  ]++welcomeAction :: Action t IO ()+welcomeAction = do+  render "text/html" $ renderHtml $ docTypeHtml $ do+    body $ do+      h1 "Welcome to my simple site!"+      p $ do+        "Click "; a ! href "/factoid" $ "here"; " to learn somethine about me."++indexAction :: Action t IO ()+indexAction = do+  idx <- liftIO $ getStdRandom (randomR (0,length quotes - 1)) +  let quote = quotes !! idx+  render "text/html" $ renderHtml $ docTypeHtml $ do+    body $ do+      h1 "A Random quote:"+      p $ do+        "Johnny Carson "+        a ! href (toValue $ "/factoid/" ++ (show idx)) $ toHtml quote++quoteAction :: Action t IO ()+quoteAction = do+  (Just idx) <- param "index" +  let quote = quotes !! (read $ (L.unpack . paramValue) idx)+  render "text/html" $ renderHtml $ docTypeHtml $ do+    body $ do+      h1 $ do "Johnny Carson "; toHtml quote+      p $ a ! href "/factoid" $ "Another random quote..."

@@ -1,5 +1,5 @@ Name:           iterio-server-Version:        0.0+Version:        0.1 build-type:     Simple License:        BSD3 License-File:   LICENSE@@ -11,6 +11,9 @@ Category:       Network, Enumerator Cabal-Version:  >= 1.6 +Extra-source-files:+  Examples/BasicSite.hs+ Description:   This module contains a set of generic building blocks for building servers with IterIO. @@ -23,10 +26,18 @@                  bytestring >= 0.9 && < 1,                  ListLike >= 3 && < 4,                  monadIO >= 0.10 && < 0.20,+                 mtl >= 2.0 && < 2.1,                  iterIO >= 0.2 && < 0.3,-                 network >= 2.3 && < 2.4+                 network >= 2.3 && < 2.4,+                 split >= 0.1 && < 0.2,+                 transformers >= 0.2 && < 0.3    ghc-options: -Wall    Exposed-modules:+    Data.IterIO.Http.Support.Action+    Data.IterIO.Http.Support.Responses+    Data.IterIO.Http.Support.RestController+    Data.IterIO.Http.Support.Routing     Data.IterIO.Server.TCPServer+