Added basic HTTP types

8 files changed, 50 insertions, 38 deletions

diff --git a/.gitignore b/.gitignore
index fdc4eb1..558187b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
 .stack-work
 dist-newstyle
-*.save*
\ No newline at end of file
+*.save*
+*.lock
\ No newline at end of file
diff --git a/Http.hs b/Http.hs
index 1d60456..f8da91f 100644
--- a/Http.hs
+++ b/Http.hs
@@ -3,5 +3,10 @@ module Http where
 import Data.Text (Text)
 
 data Header = Header Text Text
-data Method = GET | POST
+  deriving Show
+
+data Method = GET | PUT | POST
+  deriving (Show, Eq)
+
 data QueryPair = QueryPair Text Text
+  deriving Show
diff --git a/Main.hs b/Main.hs
index b2c6de1..ced8f22 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,24 +1,15 @@
 module Main where
 
-import System.IO
-
 import Response
 import Request
 import Router
 import Views
 import Utils
+import Http
 
-renderTemplate name = do
-  template <- readTemplate name
-  return $ HtmlResponse 200 template
-
-readTemplate name = do
-  handle <- openFile ("templates/" ++ name) ReadMode
-  hGetContents handle
-
-table = [ Route indexGet "/" "GET"
-        , Route helloGet "/hello" "GET" ]
+table = [ Route indexGet "/" GET
+        , Route helloGet "/hello" GET ]
 
 main = do
-  response <- resolve table (Request "query" "/jopa" "GET")
-  print $ getContent response
\ No newline at end of file
+  response <- resolve table (Request [] "/hello" GET)
+  print $ response
\ No newline at end of file
diff --git a/Request.hs b/Request.hs
index fae0a32..ad63909 100644
--- a/Request.hs
+++ b/Request.hs
@@ -1,7 +1,10 @@
 module Request where
 
+import Http
+
 -- Request query url method
-data Request = Request String String String
+data Request = Request [QueryPair] String Method
+  deriving Show
 
 getQuery (Request query _ _) = query
 
diff --git a/Response.hs b/Response.hs
index 7b99005..be347c1 100644
--- a/Response.hs
+++ b/Response.hs
@@ -1,8 +1,9 @@
 module Response where
 
-data Response =
-  HtmlResponse Int String -- Код возврата, содержимое HTML
+data Response
+  = HtmlResponse Int String -- Код возврата, содержимое HTML
   | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML
+  deriving Show
 
 notFoundResponse = HtmlResponse 404 "<strong>404 Not Found</strong>"
 
diff --git a/Router.hs b/Router.hs
index cad4bc8..17ee11c 100644
--- a/Router.hs
+++ b/Router.hs
@@ -1,16 +1,11 @@
 module Router where
 
-import Control.Exception
 import Response
 import Request
+import Http
 
 -- Route callback url method
-data Route = Route (Request -> IO Response) String String
-
-data RouterError = RouteNotFound
-  deriving Show
-
-instance Exception RouterError
+data Route = Route (Request -> IO Response) String Method
 
 resolve :: [Route] -> Request -> IO Response
 resolve [] _ = return notFoundResponse
diff --git a/Utils.hs b/Utils.hs
index 74fce4d..ba6fbac 100644
--- a/Utils.hs
+++ b/Utils.hs
@@ -15,16 +15,16 @@ import Http
 decodeUrl :: Text -> Text
 decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
 
-parseQs :: Text -> (Text, [(Text, Text)])
+parseQs :: Text -> (Text, [QueryPair])
 parseQs url =
   let
     decoded = decodeUrl url
     path = T.takeWhile (\c -> c /= '?') decoded
     rest = T.dropWhile (\c -> c /= '?') decoded
 
-    parsePair :: Text -> Maybe (Text, Text)
+    parsePair :: Text -> Maybe QueryPair
     parsePair s
-      | T.any ((==) '=') s = Just (a, b)
+      | T.any ((==) '=') s = Just (QueryPair a b)
       | otherwise = Nothing
       where a : b : _ = T.splitOn (T.pack "=") s
     
@@ -44,20 +44,26 @@ parseQs url =
 rev :: [a] -> [a]
 rev = foldl (flip (:)) []
 
-parseFirstLine :: Text -> (Text, Text)
-parseFirstLine l = (method, url)
-  where [method, url, _] = T.words l
+getMethod :: Text -> Method
+getMethod s
+  | s == (T.pack "POST") = POST
+  | s == (T.pack "PUT")  = PUT
+  | otherwise            = GET
 
-parseHeader :: Text -> (Text, Text)
+parseFirstLine :: Text -> (Method, Text)
+parseFirstLine l = (getMethod methodT, url)
+  where [methodT, url, _] = T.words l
+
+parseHeader :: Text -> Header
 parseHeader line = 
-  (T.takeWhile p line, T.strip $ T.tail
-   $ T.dropWhile p line)
+  Header (T.takeWhile p line)
+         (T.strip $ T.tail $ T.dropWhile p line)
     where p = (\c -> c /= ':')
 
-parseHeaders :: [Text] -> [(Text, Text)]
+parseHeaders :: [Text] -> [Header]
 parseHeaders = map parseHeader
 
-parseHttp :: Text -> ((Text, Text, [(Text, Text)]), [(Text, Text)], [Text])
+parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text])
 parseHttp text = 
   let
     lines = T.splitOn (T.pack "\r\n") text
diff --git a/Views.hs b/Views.hs
index 47d81e5..9d2594e 100644
--- a/Views.hs
+++ b/Views.hs
@@ -1,5 +1,7 @@
 module Views where
 
+import System.IO
+
 import Request
 import Response
 
@@ -7,4 +9,12 @@ 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
+  return $ HtmlResponse 200 "<i>hello</i>"
+
+renderTemplate name = do
+  template <- readTemplate name
+  return $ HtmlResponse 200 template
+
+readTemplate name = do
+  handle <- openFile ("templates/" ++ name) ReadMode
+  hGetContents handle
\ No newline at end of file