diff options
Diffstat (limited to 'app/Web')
| -rw-r--r-- | app/Web/Http.hs | 12 | ||||
| -rw-r--r-- | app/Web/Request.hs | 15 | ||||
| -rw-r--r-- | app/Web/Response.hs | 30 | ||||
| -rw-r--r-- | app/Web/Router.hs | 17 | ||||
| -rw-r--r-- | app/Web/Utils.hs | 153 |
5 files changed, 227 insertions, 0 deletions
diff --git a/app/Web/Http.hs b/app/Web/Http.hs new file mode 100644 index 0000000..92cb043 --- /dev/null +++ b/app/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/app/Web/Request.hs b/app/Web/Request.hs new file mode 100644 index 0000000..71dc421 --- /dev/null +++ b/app/Web/Request.hs @@ -0,0 +1,15 @@ +module Web.Request where + +import Data.Text (Text) + +import Web.Http + +-- Request query url method +data Request = Request [QueryPair] Text Method + deriving Show + +getQuery (Request query _ _) = query + +getUrl (Request _ url _) = url + +getMethod (Request _ _ method) = method
\ No newline at end of file diff --git a/app/Web/Response.hs b/app/Web/Response.hs new file mode 100644 index 0000000..3c393ad --- /dev/null +++ b/app/Web/Response.hs @@ -0,0 +1,30 @@ +module Web.Response where + +import qualified Data.Text as T +import Data.Text (Text) + +import Web.Utils + +data Response + = HtmlResponse Int Text -- Код возврата, содержимое HTML + | TextResponse Int Text Text -- Код возврата, Content-Type, содержимое HTML + deriving Show + +notFoundResponse = HtmlResponse 404 (T.pack "<strong>404 Not Found</strong>") + +getStatusCode (HtmlResponse code _) = code +getStatusCode (TextResponse code _ _) = code + +getContentType (HtmlResponse _ _) = (T.pack "text/html") +getContentType (TextResponse _ contentType _) = contentType + +getContent (HtmlResponse _ content) = content +getContent (TextResponse _ _ content) = content + +formResponse :: Response -> Text +formResponse (HtmlResponse code html) = + T.strip $ T.unlines + $ map T.pack [ "HTTP/1.1 " ++ getStatus code + , "Content-Type: text/html; charset=utf-8" + , "Connection: close" + , "" ] ++ [html] diff --git a/app/Web/Router.hs b/app/Web/Router.hs new file mode 100644 index 0000000..5e014d9 --- /dev/null +++ b/app/Web/Router.hs @@ -0,0 +1,17 @@ +module Web.Router where + +import Data.Text (Text) + +import Web.Response +import Web.Request +import Web.Http + +-- Route callback url method +data Route = Route (Request -> IO Response) Text 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/app/Web/Utils.hs b/app/Web/Utils.hs new file mode 100644 index 0000000..97bc512 --- /dev/null +++ b/app/Web/Utils.hs @@ -0,0 +1,153 @@ +module Web.Utils (parseQs, parseHttp, getStatus) 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 +import Web.Request + +-- 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 (:)) [] + +parseMethod :: Text -> Method +parseMethod s + | s == (T.pack "POST") = POST + | s == (T.pack "PUT") = PUT + | otherwise = GET + +parseFirstLine :: Text -> (Method, Text) +parseFirstLine l = (parseMethod 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 -> (Request, [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 + ((Request query path method), parseHeaders headers, rest2) + +-- HTTP Status Codes +statusCodes = + [ (100, "Continue"), + (101, "Switching Protocols"), + (102, "Processing"), + (200, "OK"), + (201, "Created"), + (202, "Accepted"), + (203, "Non Authoritative Information"), + (204, "No Content"), + (205, "Reset Content"), + (206, "Partial Content"), + (207, "Multi Status"), + (226, "IM Used"), + (300, "Multiple Choices"), + (301, "Moved Permanently"), + (302, "Found"), + (303, "See Other"), + (304, "Not Modified"), + (305, "Use Proxy"), + (307, "Temporary Redirect"), + (308, "Permanent Redirect"), + (400, "Bad Request"), + (401, "Unauthorized"), + (402, "Payment Required"), + (403, "Forbidden"), + (404, "Not Found"), + (405, "Method Not Allowed"), + (406, "Not Acceptable"), + (407, "Proxy Authentication Required"), + (408, "Request Timeout"), + (409, "Conflict"), + (410, "Gone"), + (411, "Length Required"), + (412, "Precondition Failed"), + (413, "Request Entity Too Large"), + (414, "Request URI Too Long"), + (415, "Unsupported Media Type"), + (416, "Requested Range Not Satisfiable"), + (417, "Expectation Failed"), + (418, "I'm a teapot"), + (421, "Misdirected Request"), + (422, "Unprocessable Entity"), + (423, "Locked"), + (424, "Failed Dependency"), + (426, "Upgrade Required"), + (428, "Precondition Required"), + (429, "Too Many Requests"), + (431, "Request Header Fields Too Large"), + (449, "Retry With"), + (451, "Unavailable For Legal Reasons"), + (500, "Internal Server Error"), + (501, "Not Implemented"), + (502, "Bad Gateway"), + (503, "Service Unavailable"), + (504, "Gateway Timeout"), + (505, "HTTP Version Not Supported"), + (507, "Insufficient Storage"), + (510, "Not Extended") ] + +getStatus :: Int -> String +getStatus code = findStatus statusCodes + where + findStatus ((codeCheck, stat) : rest) + | codeCheck == code = show code ++ " " ++ stat + | otherwise = findStatus rest + findStatus [] = "500 Internal Server Error" |