From 1cc6cfef971ccb3c1d70f2a5570e445556e4f6fb Mon Sep 17 00:00:00 2001 From: Andrew Date: Fri, 27 Nov 2020 17:50:54 +0400 Subject: Changed directory structure --- Http.hs | 12 -------- Main.hs | 12 ++++---- Request.hs | 13 --------- Response.hs | 17 ------------ Router.hs | 15 ---------- Utils.hs | 83 ------------------------------------------------------- Views.hs | 20 -------------- Web/Http.hs | 12 ++++++++ Web/Request.hs | 13 +++++++++ Web/Response.hs | 17 ++++++++++++ Web/Router.hs | 15 ++++++++++ Web/Utils.hs | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ Web/Views.hs | 20 ++++++++++++++ haskell-web.cabal | 2 +- 14 files changed, 167 insertions(+), 167 deletions(-) delete mode 100644 Http.hs delete mode 100644 Request.hs delete mode 100644 Response.hs delete mode 100644 Router.hs delete mode 100644 Utils.hs delete mode 100644 Views.hs create mode 100644 Web/Http.hs create mode 100644 Web/Request.hs create mode 100644 Web/Response.hs create mode 100644 Web/Router.hs create mode 100644 Web/Utils.hs create mode 100644 Web/Views.hs diff --git a/Http.hs b/Http.hs deleted file mode 100644 index f8da91f..0000000 --- a/Http.hs +++ /dev/null @@ -1,12 +0,0 @@ -module 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/Main.hs b/Main.hs index ced8f22..86bc37e 100644 --- a/Main.hs +++ b/Main.hs @@ -1,11 +1,11 @@ module Main where -import Response -import Request -import Router -import Views -import Utils -import Http +import Web.Response +import Web.Request +import Web.Router +import Web.Views +import Web.Utils +import Web.Http table = [ Route indexGet "/" GET , Route helloGet "/hello" GET ] diff --git a/Request.hs b/Request.hs deleted file mode 100644 index ad63909..0000000 --- a/Request.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Request where - -import 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/Response.hs b/Response.hs deleted file mode 100644 index be347c1..0000000 --- a/Response.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Response where - -data Response - = HtmlResponse Int String -- Код возврата, содержимое HTML - | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML - deriving Show - -notFoundResponse = HtmlResponse 404 "404 Not Found" - -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/Router.hs b/Router.hs deleted file mode 100644 index 17ee11c..0000000 --- a/Router.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Router where - -import Response -import Request -import 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/Utils.hs b/Utils.hs deleted file mode 100644 index ba6fbac..0000000 --- a/Utils.hs +++ /dev/null @@ -1,83 +0,0 @@ -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) - -import 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/Views.hs b/Views.hs deleted file mode 100644 index 9d2594e..0000000 --- a/Views.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Views where - -import System.IO - -import Request -import Response - -indexGet (Request query url method) = - return $ HtmlResponse 200 "index" - -helloGet req = - return $ HtmlResponse 200 "hello" - -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 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 "404 Not Found" + +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 "index" + +helloGet req = + return $ HtmlResponse 200 "hello" + +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 diff --git a/haskell-web.cabal b/haskell-web.cabal index a1a49db..e37184c 100644 --- a/haskell-web.cabal +++ b/haskell-web.cabal @@ -12,7 +12,7 @@ build-type: Simple executable haskell-web main-is: Main.hs other-modules: - Http, Request, Response, Router, Utils, Views + Web.Http, Web.Request, Web.Response, Web.Router, Web.Utils, Web.Views -- other-extensions: build-depends: base >=4.14 && <4.15, text, http-types, bytestring -- cgit v1.2.3