Ketchup 0.1.2 → 0.2.0

raw patch · 34 files changed

+121/−269 lines, 34 filesdep +directorybinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

API changes (from Hackage documentation)

Files

• .git/COMMIT_EDITMSG +1/−0
• .git/index binary
• .git/logs/HEAD +2/−0
• .git/logs/refs/heads/master +2/−0
• .git/logs/refs/remotes/origin/master +2/−0
• .git/objects/01/e3b6fea98c7d1cd0b8d7b76a5b558e82c6e182 binary
• .git/objects/04/c3e16687ed10eefe4dc64aeebdfb04d44ca2ca binary
• .git/objects/1b/5e76a54f1a37ba3e0920ce750eb71528cf66c7 binary
• .git/objects/29/3dd1b539d3932cada98422cd2a4d8117f693b3 binary
• .git/objects/41/bb1c25a293d0754c3554f5a07a8a2a883b40d8 binary
• .git/objects/4b/c44265a2bbd4697b8408ff44cfdaad4777b18b binary
• .git/objects/55/99915d18d029056942c1193b62f0469dd55de8 binary
• .git/objects/73/e675e209d1125be27d5c119389c9337942f3b9 +2/−0
• .git/objects/79/9af54fbed761e676c67738cc6233b446e0e1e7 binary
• .git/objects/98/5425b5fac6f110e7da367684ea0168dbc8d4dd binary
• .git/objects/a3/7a47a2c1e944a56b3018b388c79fe13c082d4d binary
• .git/objects/b9/61383890c9e39ba7e178c2f3afb5adc10ea8a0 binary
• .git/objects/bb/f22517e7bb65f1c989ac568e5d6fe08f7a8b51 binary
• .git/objects/c8/59418b5c47a1a2516f5fbfa3881490687126fa binary
• .git/objects/cb/bdc6717954437d467660c6c1d4355c420de08c binary
• .git/objects/cd/4c39b6676acd7436a462a964926eb11e4b348a binary
• .git/refs/heads/master +1/−1
• .git/refs/remotes/origin/master +1/−1
• Ketchup.cabal +5/−5
• Ketchup.cabal~ +0/−31
• Ketchup/.Routing.hs.swp binary
• Ketchup/Chunked.hs +2/−1
• Ketchup/Httpd.hs +0/−44
• Ketchup/Httpd.hs~ +0/−138
• Ketchup/Routing.hs +9/−4
• Ketchup/Routing.hs~ +0/−41
• Ketchup/Static.hs +33/−0
• Ketchup/Utils.hs +49/−1
• example.hs +12/−2

@@ -0,0 +1,1 @@+Static file handling

binary file changed (896 → 976 bytes)

@@ -1,2 +1,4 @@ 0000000000000000000000000000000000000000 6dd1040ce0fbc93348725498c912f0e19175d433 hamcha <hamcha@localhost.localdomain> 1400936747 +0200	clone: from git@github.com:Hamcha/Ketchup.git 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha <hamcha@localhost.localdomain> 1400972318 +0200	pull: Fast-forward+2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha <zikyky@gmail.com> 1401224802 +0200	commit: Regexp matching+41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha <zikyky@gmail.com> 1401228393 +0200	commit: Static file handling

@@ -1,2 +1,4 @@ 0000000000000000000000000000000000000000 6dd1040ce0fbc93348725498c912f0e19175d433 hamcha <hamcha@localhost.localdomain> 1400936747 +0200	clone: from git@github.com:Hamcha/Ketchup.git 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha <hamcha@localhost.localdomain> 1400972318 +0200	pull: Fast-forward+2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha <zikyky@gmail.com> 1401224802 +0200	commit: Regexp matching+41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha <zikyky@gmail.com> 1401228393 +0200	commit: Static file handling

@@ -1,1 +1,3 @@ 6dd1040ce0fbc93348725498c912f0e19175d433 2e95147d7a2c86bb224527a5624c118b53f9c736 hamcha <hamcha@localhost.localdomain> 1400972318 +0200	pull: fast-forward+2e95147d7a2c86bb224527a5624c118b53f9c736 41bb1c25a293d0754c3554f5a07a8a2a883b40d8 Hamcha <zikyky@gmail.com> 1401224806 +0200	update by push+41bb1c25a293d0754c3554f5a07a8a2a883b40d8 73e675e209d1125be27d5c119389c9337942f3b9 Hamcha <zikyky@gmail.com> 1401228397 +0200	update by push

binary file changed (absent → 587 bytes)

binary file changed (absent → 147 bytes)

binary file changed (absent → 1761 bytes)

binary file changed (absent → 1184 bytes)

binary file changed (absent → 161 bytes)

binary file changed (absent → 281 bytes)

binary file changed (absent → 519 bytes)

@@ -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

binary file changed (absent → 906 bytes)

binary file changed (absent → 445 bytes)

binary file changed (absent → 493 bytes)

binary file changed (absent → 605 bytes)

binary file changed (absent → 455 bytes)

binary file changed (absent → 498 bytes)

binary file changed (absent → 281 bytes)

binary file changed (absent → 179 bytes)

@@ -1,1 +1,1 @@-2e95147d7a2c86bb224527a5624c118b53f9c736+73e675e209d1125be27d5c119389c9337942f3b9

@@ -1,1 +1,1 @@-2e95147d7a2c86bb224527a5624c118b53f9c736+73e675e209d1125be27d5c119389c9337942f3b9

@@ -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
 

@@ -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

binary file changed (12288 → absent bytes)

@@ -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"

@@ -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])

@@ -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

@@ -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] = ("","")

@@ -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

@@ -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

@@ -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

@@ -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