Changed directory structure

6 files changed, 160 insertions, 0 deletions

diff --git a/Web/Http.hs b/Web/Http.hs
new file mode 100644
index 0000000..92cb043
--- /dev/null
+++ b/Web/Http.hs
@@ -0,0 +1,12 @@
+module Web.Http where
+
+import Data.Text (Text)
+
+data Header = Header Text Text
+  deriving Show
+
+data Method = GET | PUT | POST
+  deriving (Show, Eq)
+
+data QueryPair = QueryPair Text Text
+  deriving Show
diff --git a/Web/Request.hs b/Web/Request.hs
new file mode 100644
index 0000000..38f91b5
--- /dev/null
+++ b/Web/Request.hs
@@ -0,0 +1,13 @@
+module Web.Request where
+
+import Web.Http
+
+-- Request query url method
+data Request = Request [QueryPair] String Method
+  deriving Show
+
+getQuery (Request query _ _) = query
+
+getUrl (Request _ url _) = url
+
+getMethod (Request _ _ method) = method
\ No newline at end of file
diff --git a/Web/Response.hs b/Web/Response.hs
new file mode 100644
index 0000000..b08efb9
--- /dev/null
+++ b/Web/Response.hs
@@ -0,0 +1,17 @@
+module Web.Response where
+
+data Response
+  = HtmlResponse Int String -- Код возврата, содержимое HTML
+  | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML
+  deriving Show
+
+notFoundResponse = HtmlResponse 404 "<strong>404 Not Found</strong>"
+
+getStatusCode (HtmlResponse code _) = code
+getStatusCode (TextResponse code _ _) = code
+
+getContentType (HtmlResponse _ _) = "text/html"
+getContentType (TextResponse _ contentType _) = contentType
+
+getContent (HtmlResponse _ content) = content
+getContent (TextResponse _ _ content) = content
\ No newline at end of file
diff --git a/Web/Router.hs b/Web/Router.hs
new file mode 100644
index 0000000..af5bd96
--- /dev/null
+++ b/Web/Router.hs
@@ -0,0 +1,15 @@
+module Web.Router where
+
+import Web.Response
+import Web.Request
+import Web.Http
+
+-- Route callback url method
+data Route = Route (Request -> IO Response) String Method
+
+resolve :: [Route] -> Request -> IO Response
+resolve [] _ = return notFoundResponse
+resolve (Route callback routeUrl _ : routerTable) req @ (Request _ url _) =
+  if url == routeUrl then
+    callback req
+  else resolve routerTable req
diff --git a/Web/Utils.hs b/Web/Utils.hs
new file mode 100644
index 0000000..3449f21
--- /dev/null
+++ b/Web/Utils.hs
@@ -0,0 +1,83 @@
+module Web.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)
+
+import Web.Http
+
+-- Query string parser
+
+decodeUrl :: Text -> Text
+decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
+
+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 QueryPair
+    parsePair s
+      | T.any ((==) '=') s = Just (QueryPair 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 (:)) []
+
+getMethod :: Text -> Method
+getMethod s
+  | s == (T.pack "POST") = POST
+  | s == (T.pack "PUT")  = PUT
+  | otherwise            = GET
+
+parseFirstLine :: Text -> (Method, Text)
+parseFirstLine l = (getMethod methodT, url)
+  where [methodT, url, _] = T.words l
+
+parseHeader :: Text -> Header
+parseHeader line = 
+  Header (T.takeWhile p line)
+         (T.strip $ T.tail $ T.dropWhile p line)
+    where p = (\c -> c /= ':')
+
+parseHeaders :: [Text] -> [Header]
+parseHeaders = map parseHeader
+
+parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [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/Web/Views.hs b/Web/Views.hs
new file mode 100644
index 0000000..b6ae013
--- /dev/null
+++ b/Web/Views.hs
@@ -0,0 +1,20 @@
+module Web.Views where
+
+import System.IO
+
+import Web.Request
+import Web.Response
+
+indexGet (Request query url method) =
+  return $ HtmlResponse 200 "<strong>index</strong>"
+
+helloGet req =
+  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