diff --git a/.git/COMMIT_EDITMSG b/.git/COMMIT_EDITMSG new file mode 100644 --- /dev/null +++ b/.git/COMMIT_EDITMSG @@ -0,0 +1,1 @@ +Static file handling diff --git a/.git/index b/.git/index Binary files a/.git/index and b/.git/index differ diff --git a/.git/logs/HEAD b/.git/logs/HEAD --- a/.git/logs/HEAD +++ b/.git/logs/HEAD @@ -1,2 +1,4 @@ 0000000000000000000000000000000000000000 6dd1040ce0fbc93348725498c912f0e19175d433 hamcha 1400936747 +0200 clone: from git@github.com:Hamcha/Ketchup.git 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha 1400972318 +0200 pull: Fast-forward +2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha 1401224802 +0200 commit: Regexp matching +41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha 1401228393 +0200 commit: Static file handling diff --git a/.git/logs/refs/heads/master b/.git/logs/refs/heads/master --- a/.git/logs/refs/heads/master +++ b/.git/logs/refs/heads/master @@ -1,2 +1,4 @@ 0000000000000000000000000000000000000000 6dd1040ce0fbc93348725498c912f0e19175d433 hamcha 1400936747 +0200 clone: from git@github.com:Hamcha/Ketchup.git 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha 1400972318 +0200 pull: Fast-forward +2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha 1401224802 +0200 commit: Regexp matching +41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha 1401228393 +0200 commit: Static file handling diff --git a/.git/logs/refs/remotes/origin/master b/.git/logs/refs/remotes/origin/master --- a/.git/logs/refs/remotes/origin/master +++ b/.git/logs/refs/remotes/origin/master @@ -1,1 +1,3 @@ 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha 1400972318 +0200 pull: fast-forward +2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha 1401224806 +0200 update by push +41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha 1401228397 +0200 update by push diff --git a/.git/objects/01/e3b6fea98c7d1cd0b8d7b76a5b558e82c6e182 b/.git/objects/01/e3b6fea98c7d1cd0b8d7b76a5b558e82c6e182 new file mode 100644 Binary files /dev/null and b/.git/objects/01/e3b6fea98c7d1cd0b8d7b76a5b558e82c6e182 differ diff --git a/.git/objects/04/c3e16687ed10eefe4dc64aeebdfb04d44ca2ca b/.git/objects/04/c3e16687ed10eefe4dc64aeebdfb04d44ca2ca new file mode 100644 Binary files /dev/null and b/.git/objects/04/c3e16687ed10eefe4dc64aeebdfb04d44ca2ca differ diff --git a/.git/objects/1b/5e76a54f1a37ba3e0920ce750eb71528cf66c7 b/.git/objects/1b/5e76a54f1a37ba3e0920ce750eb71528cf66c7 new file mode 100644 Binary files /dev/null and b/.git/objects/1b/5e76a54f1a37ba3e0920ce750eb71528cf66c7 differ diff --git a/.git/objects/29/3dd1b539d3932cada98422cd2a4d8117f693b3 b/.git/objects/29/3dd1b539d3932cada98422cd2a4d8117f693b3 new file mode 100644 Binary files /dev/null and b/.git/objects/29/3dd1b539d3932cada98422cd2a4d8117f693b3 differ diff --git a/.git/objects/41/bb1c25a293d0754c3554f5a07a8a2a883b40d8 b/.git/objects/41/bb1c25a293d0754c3554f5a07a8a2a883b40d8 new file mode 100644 Binary files /dev/null and b/.git/objects/41/bb1c25a293d0754c3554f5a07a8a2a883b40d8 differ diff --git a/.git/objects/4b/c44265a2bbd4697b8408ff44cfdaad4777b18b b/.git/objects/4b/c44265a2bbd4697b8408ff44cfdaad4777b18b new file mode 100644 Binary files /dev/null and b/.git/objects/4b/c44265a2bbd4697b8408ff44cfdaad4777b18b differ diff --git a/.git/objects/55/99915d18d029056942c1193b62f0469dd55de8 b/.git/objects/55/99915d18d029056942c1193b62f0469dd55de8 new file mode 100644 Binary files /dev/null and b/.git/objects/55/99915d18d029056942c1193b62f0469dd55de8 differ diff --git a/.git/objects/73/e675e209d1125be27d5c119389c9337942f3b9 b/.git/objects/73/e675e209d1125be27d5c119389c9337942f3b9 new file mode 100644 --- /dev/null +++ b/.git/objects/73/e675e209d1125be27d5c119389c9337942f3b9 @@ -0,0 +1,2 @@ +x•ŽK +Â0@]ç³d’L>—î=Ádm°i¥ÄE=½½‚ÛÇ{ðdi­v0z8ôµ”²ø ÃàˆlÈäƒ÷(^t&뜐Á\0ŠzóZæ¤SÒb›Áf Žd·èáG6£M„9*þôqYáÆMF†ó·¾¶×v}6®ÓI–vM¨‰v°pDƒ¨vº¯õòW¤î{xÔ©ÀÈsžêüT?<`D diff --git a/.git/objects/79/9af54fbed761e676c67738cc6233b446e0e1e7 b/.git/objects/79/9af54fbed761e676c67738cc6233b446e0e1e7 new file mode 100644 Binary files /dev/null and b/.git/objects/79/9af54fbed761e676c67738cc6233b446e0e1e7 differ diff --git a/.git/objects/98/5425b5fac6f110e7da367684ea0168dbc8d4dd b/.git/objects/98/5425b5fac6f110e7da367684ea0168dbc8d4dd new file mode 100644 Binary files /dev/null and b/.git/objects/98/5425b5fac6f110e7da367684ea0168dbc8d4dd differ diff --git a/.git/objects/a3/7a47a2c1e944a56b3018b388c79fe13c082d4d b/.git/objects/a3/7a47a2c1e944a56b3018b388c79fe13c082d4d new file mode 100644 Binary files /dev/null and b/.git/objects/a3/7a47a2c1e944a56b3018b388c79fe13c082d4d differ diff --git a/.git/objects/b9/61383890c9e39ba7e178c2f3afb5adc10ea8a0 b/.git/objects/b9/61383890c9e39ba7e178c2f3afb5adc10ea8a0 new file mode 100644 Binary files /dev/null and b/.git/objects/b9/61383890c9e39ba7e178c2f3afb5adc10ea8a0 differ diff --git a/.git/objects/bb/f22517e7bb65f1c989ac568e5d6fe08f7a8b51 b/.git/objects/bb/f22517e7bb65f1c989ac568e5d6fe08f7a8b51 new file mode 100644 Binary files /dev/null and b/.git/objects/bb/f22517e7bb65f1c989ac568e5d6fe08f7a8b51 differ diff --git a/.git/objects/c8/59418b5c47a1a2516f5fbfa3881490687126fa b/.git/objects/c8/59418b5c47a1a2516f5fbfa3881490687126fa new file mode 100644 Binary files /dev/null and b/.git/objects/c8/59418b5c47a1a2516f5fbfa3881490687126fa differ diff --git a/.git/objects/cb/bdc6717954437d467660c6c1d4355c420de08c b/.git/objects/cb/bdc6717954437d467660c6c1d4355c420de08c new file mode 100644 Binary files /dev/null and b/.git/objects/cb/bdc6717954437d467660c6c1d4355c420de08c differ diff --git a/.git/objects/cd/4c39b6676acd7436a462a964926eb11e4b348a b/.git/objects/cd/4c39b6676acd7436a462a964926eb11e4b348a new file mode 100644 Binary files /dev/null and b/.git/objects/cd/4c39b6676acd7436a462a964926eb11e4b348a differ diff --git a/.git/refs/heads/master b/.git/refs/heads/master --- a/.git/refs/heads/master +++ b/.git/refs/heads/master @@ -1,1 +1,1 @@ -2e95147d7a2c86bb224527a5624c118b53f9c736 +73e675e209d1125be27d5c119389c9337942f3b9 diff --git a/.git/refs/remotes/origin/master b/.git/refs/remotes/origin/master --- a/.git/refs/remotes/origin/master +++ b/.git/refs/remotes/origin/master @@ -1,1 +1,1 @@ -2e95147d7a2c86bb224527a5624c118b53f9c736 +73e675e209d1125be27d5c119389c9337942f3b9 diff --git a/Ketchup.cabal b/Ketchup.cabal --- a/Ketchup.cabal +++ b/Ketchup.cabal @@ -1,5 +1,5 @@ Name: Ketchup -Version: 0.1.2 +Version: 0.2.0 Cabal-Version: >= 1.6 Build-Type: Simple License: MIT @@ -12,17 +12,17 @@ Library Exposed-Modules: - Ketchup.Httpd, - Ketchup.Routing Ketchup.Chunked - - Other-Modules: + Ketchup.Httpd + Ketchup.Routing + Ketchup.Static Ketchup.Utils Build-Depends: base ==4.*, bytestring >=0.9 && <0.11, containers >=0.2 && <0.6, + directory <1.3, network <2.5, regex-posix <1.0 diff --git a/Ketchup.cabal~ b/Ketchup.cabal~ deleted file mode 100644 --- a/Ketchup.cabal~ +++ /dev/null @@ -1,31 +0,0 @@ -Name: Ketchup -Version: 0.1.1 -Cabal-Version: >= 1.6 -Build-Type: Simple -License: MIT -License-File: LICENSE -Author: Alessandro Gatti -Maintainer: zikyky@gmail.com -Homepage: https://github.com/Hamcha/Ketchup -Category: Web, Ketchup -Synopsis: A super small web framework for those who don't like big and fancy codebases - -Library - Exposed-Modules: - Ketchup.Httpd, - Ketchup.Routing - Ketchup.Chunked - - Other-Modules: - Ketchup.Utils - - Build-Depends: - base ==4.*, - bytestring >=0.9 && <0.11, - containers >=0.2 && <0.6, - network <2.5, - regex-posix <1.0 - -Source-Repository head - type: git - location: git://github.com/Hamcha/Ketchup.git diff --git a/Ketchup/.Routing.hs.swp b/Ketchup/.Routing.hs.swp deleted file mode 100644 Binary files a/Ketchup/.Routing.hs.swp and /dev/null differ diff --git a/Ketchup/Chunked.hs b/Ketchup/Chunked.hs --- a/Ketchup/Chunked.hs +++ b/Ketchup/Chunked.hs @@ -9,6 +9,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.List as List import Ketchup.Httpd +import Ketchup.Utils import Network import Network.Socket.ByteString import Numeric @@ -30,4 +31,4 @@ "\r\n", value, "\r\n"] endchunk :: Socket -> IO () -endchunk handle = sendAll handle "0\r\n\r\n" +endchunk handle = sendAll handle "0\r\n\r\n" diff --git a/Ketchup/Httpd.hs b/Ketchup/Httpd.hs --- a/Ketchup/Httpd.hs +++ b/Ketchup/Httpd.hs @@ -3,18 +3,13 @@ module Ketchup.Httpd ( HTTPRequest , method, uri, httpver, headers -, statusMsg -, sendReply , listenHTTP -, sendBadRequest -, sendNotFound ) where import Control.Concurrent (forkIO) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import qualified Data.Map as Map -import qualified Data.List as List import Network import qualified Network.Socket as NS import Network.Socket.ByteString @@ -27,45 +22,6 @@ , httpver :: B.ByteString , headers :: Map.Map B.ByteString [B.ByteString] } deriving (Show) - --- Returns status message from status id -statusMsg :: Int -> B.ByteString -statusMsg stat - -- 200 Success - | stat == 200 = "200 OK" - | stat == 201 = "201 Created" - | stat == 204 = "204 No Content" - -- 400 Client Errors - | stat == 400 = "400 Bad Request" - | stat == 403 = "403 Forbidden" - | stat == 404 = "404 Not Found" - | stat == 405 = "405 Method Not Allowed" - | stat == 410 = "410 Gone" - -- 500 Server Errors - | stat == 500 = "500 Internal Server Error" - | stat == 501 = "501 Not Implemented" - | stat == 502 = "502 Bad Gateway" - | stat == 503 = "503 Service Unavailable" - | otherwise = "500 Internal Server Error" - -sendBadRequest :: Socket -> IO () -sendBadRequest client = do - sendReply client 400 [("Content-Type",["text/plain"])] "400 Bad Request!\n" - -sendNotFound :: Socket -> IO () -sendNotFound client = do - sendReply client 404 [("Content-Type",["text/plain"])] "404 Not Found!\n" - --- Sends HTTP reply -sendReply :: Socket -> Int -> [(B.ByteString, [B.ByteString])] -> B.ByteString -> IO () -sendReply client status headers body = do - sendAll client reply - where - reply = B.concat ["HTTP/1.1 ", statusMsg status,"\r\n\ - \Content-Length: ", C.pack $ show $ C.length body, "\r\n\ - \Connection: close\r\n",heads,"\r\n",body] - -- Turn ("a", ["b", "c"]) headers into "a: b,c" - heads = B.concat $ map (\x -> B.concat [fst x, ": ", B.concat $ List.intersperse "," $ snd x, "\r\n"]) headers -- Parses header lines parseRequestLine :: B.ByteString -> (B.ByteString, [B.ByteString]) diff --git a/Ketchup/Httpd.hs~ b/Ketchup/Httpd.hs~ deleted file mode 100644 --- a/Ketchup/Httpd.hs~ +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Ketchup.Httpd -( HTTPRequest -, method, uri, httpver, headers -, statusMsg -, sendReply -, listenHTTP -, sendBadRequest -, sendNotFound -) where - -import Control.Concurrent (forkIO) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import qualified Data.Map as Map -import qualified Data.List as List -import Network -import qualified Network.Socket as NS -import Network.Socket.ByteString -import Ketchup.Utils -import System.IO - --- HTTP Request type -data HTTPRequest = HTTPRequest { method :: B.ByteString - , uri :: B.ByteString - , httpver :: B.ByteString - , headers :: Map.Map B.ByteString [B.ByteString] - } deriving (Show) - --- Returns status message from status id -statusMsg :: Int -> B.ByteString -statusMsg stat - -- 200 Success - | stat == 200 = "200 OK" - | stat == 201 = "201 Created" - | stat == 204 = "204 No Content" - -- 400 Client Errors - | stat == 400 = "400 Bad Request" - | stat == 403 = "403 Forbidden" - | stat == 404 = "404 Not Found" - | stat == 405 = "405 Method Not Allowed" - | stat == 410 = "410 Gone" - -- 500 Server Errors - | stat == 500 = "500 Internal Server Error" - | stat == 501 = "501 Not Implemented" - | stat == 502 = "502 Bad Gateway" - | stat == 503 = "503 Service Unavailable" - | otherwise = "500 Internal Server Error" - -sendBadRequest :: Socket -> IO () -sendBadRequest client = do - sendReply client 400 [("Content-Type",["text/plain"])] "400 Bad Request!\n" - -sendNotFound :: Socket -> IO () -sendNotFound client = do - sendReply client 404 [("Content-Type",["text/plain"])] "404 Not Found!\n" - --- Sends HTTP reply -sendReply :: Socket -> Int -> [(B.ByteString, [B.ByteString])] -> B.ByteString -> IO () -sendReply client status headers body = do - sendAll client reply - where - reply = B.concat ["HTTP/1.1 ", statusMsg status,"\r\n\ - \Content-Length: ", C.pack $ show $ C.length body, "\r\n\ - \Connection: close\r\n",heads,"\r\n",body] - -- Turn ("a", ["b", "c"]) headers into "a: b,c" - heads = B.concat $ map (\x -> B.concat [fst x, ": ", B.concat $ List.intersperse "," $ snd x, "\r\n"]) headers - --- Parses header lines -parseRequestLine :: B.ByteString -> (B.ByteString, [B.ByteString]) -parseRequestLine line = - (property, values) - where - property = head items - values = C.split ',' $ (trim . last) items - items = C.split ':' line - --- Gets all request lines -getRequest :: Socket -> IO [B.ByteString] -getRequest client = do - content <- recv client 1024 - return $ C.lines content - --- Parses requests -parseRequest :: [B.ByteString] -> HTTPRequest -parseRequest reqlines = - HTTPRequest { method=met, uri=ur, httpver=ver, headers=heads } - where - [met, ur, ver] = (C.words . head) reqlines -- First line is METHOD URI VERSION - heads = Map.fromList $ map parseRequestLine $ tail reqlines - --- Handles each client request -handleRequest :: Socket -> (Socket -> HTTPRequest -> IO ()) -> IO () -handleRequest client cback = do - reqlines <- getRequest client - case length reqlines of - 0 -> sendBadRequest client - _ -> cback client $ parseRequest reqlines - sClose client - --- Acceptor -acceptAll :: Socket -> (Socket -> HTTPRequest -> IO ()) -> IO () -acceptAll sock cback = do - (client, _) <- NS.accept sock - handleRequest client cback - acceptAll sock cback - --- Creates Acceptor pools -createAcceptorPool :: Socket -> Int -> (Socket -> HTTPRequest -> IO ()) -> IO () -createAcceptorPool sock max cback = - case max of - 0 -> acceptAll sock cback - x -> do - forkIO $ acceptAll sock cback - createAcceptorPool sock (x-1) cback - --- Gets host from hostname string -getHostaddr :: String -> IO NS.HostAddress -getHostaddr "*" = return NS.iNADDR_ANY -getHostaddr host = NS.inet_addr host - --- Listens for incoming HTTP request -listenHTTP :: String -> PortNumber -> (Socket -> HTTPRequest -> IO ()) -> IO () -listenHTTP hostname port cback = withSocketsDo $ do - -- Get hostname - host <- getHostaddr hostname - let addr = NS.SockAddrInet port host - putStr $ concat ["{* Listening on ", show addr, " (POOL SIZE ", show 128, "*}"] - -- Prepare Socket - sock <- NS.socket NS.AF_INET NS.Stream 0 - NS.setSocketOption sock NS.ReuseAddr 1 - NS.setSocketOption sock NS.NoDelay 1 - -- Bind socket to address and listen - NS.bindSocket sock addr - NS.listen sock 128 - createAcceptorPool sock 128 cback - sClose sock diff --git a/Ketchup/Routing.hs b/Ketchup/Routing.hs --- a/Ketchup/Routing.hs +++ b/Ketchup/Routing.hs @@ -7,14 +7,17 @@ import qualified Data.ByteString.Char8 as C import qualified Data.Map as M import Ketchup.Httpd +import Ketchup.Utils import Network import qualified Text.Regex.Posix as R -route :: [(C.ByteString, (Socket -> HTTPRequest -> (M.Map C.ByteString C.ByteString) -> IO ()))] +route :: [(C.ByteString, (Socket -> HTTPRequest + -> (M.Map C.ByteString C.ByteString) -> IO ()))] -> (Socket -> HTTPRequest -> IO ()) route [] handle request = sendNotFound handle route (r:routes) handle request - | match (uri request) (fst r) = (snd r) handle request $ params (uri request) (fst r) + | match (uri request) (fst r) = (snd r) handle request $ + params (uri request) (fst r) | otherwise = route routes handle request match :: C.ByteString -> C.ByteString -> Bool @@ -22,16 +25,18 @@ and $ zipWith compare urlparts tmpparts where compare x y - | x R.=~ y = True + | x == y = True | or [C.null y, C.null x] = False | C.head y == ':' = True + | x R.=~ y = True | otherwise = False urlparts = C.split '/' url tmpparts = C.split '/' template params :: C.ByteString -> C.ByteString -> M.Map C.ByteString C.ByteString params url template = - M.fromList $ filter (not . C.null . fst) $ zipWith retrieve urlparts tmpparts + M.fromList $ filter (not . C.null . fst) $ + zipWith retrieve urlparts tmpparts where retrieve x y | or [C.null y, C.null x] = ("","") diff --git a/Ketchup/Routing.hs~ b/Ketchup/Routing.hs~ deleted file mode 100644 --- a/Ketchup/Routing.hs~ +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Ketchup.Routing -( route -) where - -import qualified Data.ByteString.Char8 as C -import qualified Data.Map as M -import Ketchup.Httpd -import Network -import qualified Text.Regex.Posix - -route :: [(C.ByteString, (Socket -> HTTPRequest -> (M.Map C.ByteString C.ByteString) -> IO ()))] - -> (Socket -> HTTPRequest -> IO ()) -route [] handle request = sendNotFound handle -route (r:routes) handle request - | match (uri request) (fst r) = (snd r) handle request $ params (uri request) (fst r) - | otherwise = route routes handle request - -match :: C.ByteString -> C.ByteString -> Bool -match url template = - and $ zipWith compare urlparts tmpparts - where - compare x y - | x =~ y = True - | or [C.null y, C.null x] = False - | C.head y == ':' = True - | otherwise = False - urlparts = C.split '/' url - tmpparts = C.split '/' template - -params :: C.ByteString -> C.ByteString -> M.Map C.ByteString C.ByteString -params url template = - M.fromList $ filter (not . C.null . fst) $ zipWith retrieve urlparts tmpparts - where - retrieve x y - | or [C.null y, C.null x] = ("","") - | C.head y == ':' = (C.tail y, x) - | otherwise = ("","") - urlparts = C.split '/' url - tmpparts = C.split '/' template diff --git a/Ketchup/Static.hs b/Ketchup/Static.hs new file mode 100644 --- /dev/null +++ b/Ketchup/Static.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ketchup.Static +( static +) where + +import qualified Data.ByteString.Char8 as B +import qualified Data.Map as M +import Ketchup.Httpd +import Ketchup.Utils +import Network +import System.Directory (doesFileExist) + +-- Static file handler +static :: B.ByteString -> Socket -> HTTPRequest + -> (M.Map B.ByteString B.ByteString) -> IO () +static folder hnd req params = do + let path = B.concat [folder, uri req] + let sane = sanecheck path + let strPath = B.unpack path + doesExist <- doesFileExist strPath + case and [sane, doesExist] of + True -> B.readFile strPath + >>= sendReply hnd 200 [] + False -> sendNotFound hnd + +sanecheck :: B.ByteString -> Bool +sanecheck url = + and checks + where + checks = [parentcheck] + parentcheck = length (filter (== "..") pieces) > 0 + pieces = B.split '/' url diff --git a/Ketchup/Utils.hs b/Ketchup/Utils.hs --- a/Ketchup/Utils.hs +++ b/Ketchup/Utils.hs @@ -2,13 +2,61 @@ module Ketchup.Utils ( trim +, sendReply +, sendBadRequest +, sendNotFound +, statusMsg ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as C import Data.Char (isSpace) +import qualified Data.List as List +import Network +import Network.Socket.ByteString +-- Returns status message from status id +statusMsg :: Int -> B.ByteString +statusMsg stat + -- 200 Success + | stat == 200 = "200 OK" + | stat == 201 = "201 Created" + | stat == 204 = "204 No Content" + -- 400 Client Errors + | stat == 400 = "400 Bad Request" + | stat == 403 = "403 Forbidden" + | stat == 404 = "404 Not Found" + | stat == 405 = "405 Method Not Allowed" + | stat == 410 = "410 Gone" + -- 500 Server Errors + | stat == 500 = "500 Internal Server Error" + | stat == 501 = "501 Not Implemented" + | stat == 502 = "502 Bad Gateway" + | stat == 503 = "503 Service Unavailable" + | otherwise = "500 Internal Server Error" + +-- Premade HTTP replies +sendBadRequest :: Socket -> IO () +sendBadRequest client = do + sendReply client 400 [("Content-Type",["text/plain"])] "400 Bad Request!\n" + +sendNotFound :: Socket -> IO () +sendNotFound client = do + sendReply client 404 [("Content-Type",["text/plain"])] "404 Not Found!\n" + +-- Template for 200 Reply +sendReply :: Socket -> Int -> [(B.ByteString, [B.ByteString])] -> B.ByteString -> IO () +sendReply client status headers body = do + sendAll client reply + where + reply = B.concat ["HTTP/1.1 ", statusMsg status,"\r\n\ + \Content-Length: ", C.pack $ show $ C.length body, "\r\n\ + \Connection: close\r\n",heads,"\r\n",body] + -- Turn ("a", ["b", "c"]) headers into "a: b,c" + heads = B.concat $ map (\x -> B.concat [fst x, ": ", B.concat $ List.intersperse "," $ snd x, "\r\n"]) headers + + -- Util function for trimming whitespace from headers trim :: B.ByteString -> B.ByteString trim = f . f - where f = C.reverse . C.dropWhile isSpace + where f = C.reverse . C.dropWhile isSpace diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -6,6 +6,9 @@ import qualified Data.Map as M import Ketchup.Httpd import Ketchup.Routing +import Ketchup.Utils +import Ketchup.Chunked +import Ketchup.Static handle hnd req params = do sendReply hnd 200 [("Content-Type", ["text/html"])] response @@ -21,6 +24,13 @@ getName Nothing = "Anonymous" name = M.lookup "user" params -router = route [("/", handle), ("/greet/:user", greet)] +chunked hnd req params = do + chunkHeaders hnd 200 [("Content-Type",["text/plain"])] + chunk hnd "PUTIFERIO" + chunk hnd "AAAAAAAAAHHH" + endchunk hnd -main = do listenHTTP "*" 8080 router +router = route [("/", handle), ("/greet/:user", greet), + ("/chunk", chunked), ("/Ketchup/(.*)", static ".")] + +main = do listenHTTP "*" 8080 router