Added Http parsing

8 files changed, 192 insertions, 14 deletions

diff --git a/Main.hs b/Main.hs
index 1bc06d5..8e3925e 100644
--- a/Main.hs
+++ b/Main.hs
@@ -2,7 +2,9 @@ module Main where
 
 import System.IO
 import Response
+import Request
 import Router
+import Views
 
 renderTemplate name = do
   template <- readTemplate name
@@ -12,14 +14,9 @@ readTemplate name = do
   handle <- openFile ("templates/" ++ name) ReadMode
   hGetContents handle
 
-route url method
-  | url == "/"      = renderTemplate "index.html"
-  | url == "/hello" = renderTemplate "hello.html"
-
-table = [
-  Route 
-]
+table = [ Route indexGet "/" "GET"
+        , Route helloGet "/hello" "GET" ]
 
 main = do
-  response <- route "/hello" "GET"
+  response <- resolve table (Request "query" "/jopa" "GET")
   print $ getContent response
\ No newline at end of file
diff --git a/Request.hs b/Request.hs
index a0c18d7..fae0a32 100644
--- a/Request.hs
+++ b/Request.hs
@@ -1,5 +1,6 @@
 module Request where
 
+-- Request query url method
 data Request = Request String String String
 
 getQuery (Request query _ _) = query
diff --git a/Response.hs b/Response.hs
index f33777d..7b99005 100644
--- a/Response.hs
+++ b/Response.hs
@@ -4,6 +4,7 @@ data Response =
   HtmlResponse Int String -- Код возврата, содержимое HTML
   | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML
 
+notFoundResponse = HtmlResponse 404 "<strong>404 Not Found</strong>"
 
 getStatusCode (HtmlResponse code _) = code
 getStatusCode (TextResponse code _ _) = code
diff --git a/Router.hs b/Router.hs
index 4798ec1..cad4bc8 100644
--- a/Router.hs
+++ b/Router.hs
@@ -4,6 +4,7 @@ import Control.Exception
 import Response
 import Request
 
+-- Route callback url method
 data Route = Route (Request -> IO Response) String String
 
 data RouterError = RouteNotFound
@@ -11,11 +12,9 @@ data RouterError = RouteNotFound
 
 instance Exception RouterError
 
-getResponse [] _ = throw RouteNotFound
-getResponse (Route callback routeUrl _ : routerTable) req @ (Request _ url _) =
+resolve :: [Route] -> Request -> IO Response
+resolve [] _ = return notFoundResponse
+resolve (Route callback routeUrl _ : routerTable) req @ (Request _ url _) =
   if url == routeUrl then
     callback req
-  else getResponse routerTable req
-
-router table req =
-  
+  else resolve routerTable req
diff --git a/Utils.hs b/Utils.hs
new file mode 100644
index 0000000..94ad0fb
--- /dev/null
+++ b/Utils.hs
@@ -0,0 +1,75 @@
+module Utils (parseQs, parseHttp) where
+
+import Network.HTTP.Types.URI as URI
+import qualified Data.ByteString as S
+import Data.ByteString (ByteString)
+
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Text (Text)
+
+-- Query string parser
+
+decodeUrl :: Text -> Text
+decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
+
+parseQs :: Text -> (Text, [(Text, Text)])
+parseQs url =
+  let
+    decoded = decodeUrl url
+    path = T.takeWhile (\c -> c /= '?') decoded
+    rest = T.dropWhile (\c -> c /= '?') decoded
+
+    parsePair :: Text -> Maybe (Text, Text)
+    parsePair s
+      | T.any ((==) '=') s = Just (a, b)
+      | otherwise = Nothing
+      where a : b : _ = T.splitOn (T.pack "=") s
+    
+    get (Just p : rest) = p : get rest
+    get (Nothing : rest) = get rest
+    get [] = []
+
+    pairs = 
+      if T.null rest
+      then []
+      else get $ map parsePair $ T.splitOn (T.pack "&") $ T.tail rest
+
+  in (path, pairs)
+
+-- HTTP Parser
+
+rev :: [a] -> [a]
+rev = foldl (flip (:)) []
+
+parseFirstLine :: Text -> (Text, Text)
+parseFirstLine l = (method, url)
+  where [method, url, _] = T.words l
+
+parseHeader :: Text -> (Text, Text)
+parseHeader line = 
+  (T.takeWhile p line, T.strip $ T.tail
+   $ T.dropWhile p line)
+    where p = (\c -> c /= ':')
+
+parseHeaders :: [Text] -> [(Text, Text)]
+parseHeaders = map parseHeader
+
+parseHttp :: Text -> ((Text, Text, [(Text, Text)]), [(Text, Text)], [Text])
+parseHttp text = 
+  let
+    lines = T.splitOn (T.pack "\r\n") text
+
+    getFirstLine (l : rest) = (l, rest)
+
+    getHeaders (l : rest) acc
+      | T.null l  = (rev acc, rest)
+      | otherwise = getHeaders rest (l : acc)
+    
+    (fl, rest1) = getFirstLine lines
+    (headers, rest2) = getHeaders rest1 []
+
+    (method, url) = parseFirstLine fl
+    (path, query) = parseQs url
+  in 
+    ((method, path, query), parseHeaders headers, rest2)
diff --git a/Views.hs b/Views.hs
new file mode 100644
index 0000000..47d81e5
--- /dev/null
+++ b/Views.hs
@@ -0,0 +1,10 @@
+module Views where
+
+import Request
+import Response
+
+indexGet (Request query url method) =
+  return $ HtmlResponse 200 "<strong>index</strong>"
+
+helloGet req =
+  return $ HtmlResponse 200 "<i>hello</i>"
\ No newline at end of file
diff --git a/net/Client.hs b/net/Client.hs
new file mode 100644
index 0000000..863df6e
--- /dev/null
+++ b/net/Client.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- Echo client program
+module Main (main) where
+
+import qualified Control.Exception as E
+import qualified Data.ByteString.Char8 as C
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+
+main :: IO ()
+main = runTCPClient "127.0.0.1" "3000" $ \s -> do
+    sendAll s "Hello, world!"
+    msg <- recv s 1024
+    putStr "Received: "
+    C.putStrLn msg
+
+-- from the "network-run" package.
+runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runTCPClient host port client = withSocketsDo $ do
+    addr <- resolve
+    E.bracket (open addr) close client
+  where
+    resolve = do
+        let hints = defaultHints { addrSocketType = Stream }
+        head <$> getAddrInfo (Just hints) (Just host) (Just port)
+    open addr = do
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        connect sock $ addrAddress addr
+        return sock
+
diff --git a/net/Server.hs b/net/Server.hs
new file mode 100644
index 0000000..0e53330
--- /dev/null
+++ b/net/Server.hs
@@ -0,0 +1,65 @@
+-- Echo server program
+module Main (main) where
+
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (unless, forever, void)
+
+import qualified Data.ByteString as S
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+
+join :: String -> [String] -> String
+join delim [] = ""
+join delim (s : []) = s
+join delim (s : rest) = 
+  s ++ delim ++ join delim rest
+
+packStr :: String -> S.ByteString
+packStr = encodeUtf8 . T.pack
+
+(+++) = S.append
+
+response =  join "\n" 
+                 [ "HTTP/1.1 200 OK"
+                 , "Content-Type: text/html; charset=utf-8"
+                 , "Connection: keep-alive"
+                 , ""
+                 , "<i>PRIVET</i>"
+                 ]
+
+main :: IO ()
+main = runTCPServer Nothing "3000" talk
+  where
+    talk s = do
+        msg <- recv s 1024
+        print msg
+        unless (S.null msg) $ do
+          sendAll s (packStr response)
+          talk s
+
+-- from the "network-run" package.
+runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runTCPServer mhost port server = withSocketsDo $ do
+    addr <- resolve
+    E.bracket (open addr) close loop
+  where
+    resolve = do
+        let hints = defaultHints {
+                addrFlags = [AI_PASSIVE]
+              , addrSocketType = Stream
+              }
+        head <$> getAddrInfo (Just hints) mhost (Just port)
+    open addr = do
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        setSocketOption sock ReuseAddr 1
+        withFdSocket sock $ setCloseOnExecIfNeeded
+        bind sock $ addrAddress addr
+        listen sock 1024
+        return sock
+    loop sock = forever $ do
+        (conn, _peer) <- accept sock
+        void $ forkFinally (server conn) (const $ gracefulClose conn 5000)