From fb7e450d917ec87202f9de019238b78c1b645328 Mon Sep 17 00:00:00 2001 From: Andrew Date: Fri, 27 Nov 2020 17:40:04 +0400 Subject: Added basic HTTP types --- .gitignore | 3 ++- Http.hs | 7 ++++++- Main.hs | 19 +++++-------------- Request.hs | 5 ++++- Response.hs | 5 +++-- Router.hs | 9 ++------- Utils.hs | 28 +++++++++++++++++----------- Views.hs | 12 +++++++++++- 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 "404 Not Found" 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 "index" helloGet req = - return $ HtmlResponse 200 "hello" \ No newline at end of file + 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 -- cgit v1.2.3