From 1cc6cfef971ccb3c1d70f2a5570e445556e4f6fb Mon Sep 17 00:00:00 2001 From: Andrew Date: Fri, 27 Nov 2020 17:50:54 +0400 Subject: Changed directory structure --- Web/Http.hs | 12 +++++++++ Web/Request.hs | 13 +++++++++ Web/Response.hs | 17 ++++++++++++ Web/Router.hs | 15 +++++++++++ Web/Utils.hs | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Web/Views.hs | 20 ++++++++++++++ 6 files changed, 160 insertions(+) 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 (limited to 'Web') 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 -- cgit v1.2.3