diff options
| -rw-r--r-- | Main.hs | 13 | ||||
| -rw-r--r-- | Request.hs | 1 | ||||
| -rw-r--r-- | Response.hs | 1 | ||||
| -rw-r--r-- | Router.hs | 11 | ||||
| -rw-r--r-- | Utils.hs | 75 | ||||
| -rw-r--r-- | Views.hs | 10 | ||||
| -rw-r--r-- | net/Client.hs | 30 | ||||
| -rw-r--r-- | net/Server.hs | 65 |
8 files changed, 192 insertions, 14 deletions
@@ -2,7 +2,9 @@ module Main where import System.IO import Response +import Request import Router +import Views renderTemplate name = do template <- readTemplate name @@ -12,14 +14,9 @@ readTemplate name = do handle <- openFile ("templates/" ++ name) ReadMode hGetContents handle -route url method - | url == "/" = renderTemplate "index.html" - | url == "/hello" = renderTemplate "hello.html" - -table = [ - Route -] +table = [ Route indexGet "/" "GET" + , Route helloGet "/hello" "GET" ] main = do - response <- route "/hello" "GET" + response <- resolve table (Request "query" "/jopa" "GET") print $ getContent response
\ No newline at end of file @@ -1,5 +1,6 @@ module Request where +-- Request query url method data Request = Request String String String getQuery (Request query _ _) = query diff --git a/Response.hs b/Response.hs index f33777d..7b99005 100644 --- a/Response.hs +++ b/Response.hs @@ -4,6 +4,7 @@ data Response = HtmlResponse Int String -- Код возврата, содержимое HTML | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML +notFoundResponse = HtmlResponse 404 "<strong>404 Not Found</strong>" getStatusCode (HtmlResponse code _) = code getStatusCode (TextResponse code _ _) = code @@ -4,6 +4,7 @@ import Control.Exception import Response import Request +-- Route callback url method data Route = Route (Request -> IO Response) String String data RouterError = RouteNotFound @@ -11,11 +12,9 @@ data RouterError = RouteNotFound instance Exception RouterError -getResponse [] _ = throw RouteNotFound -getResponse (Route callback routeUrl _ : routerTable) req @ (Request _ url _) = +resolve :: [Route] -> Request -> IO Response +resolve [] _ = return notFoundResponse +resolve (Route callback routeUrl _ : routerTable) req @ (Request _ url _) = if url == routeUrl then callback req - else getResponse routerTable req - -router table req = - + else resolve routerTable req diff --git a/Utils.hs b/Utils.hs new file mode 100644 index 0000000..94ad0fb --- /dev/null +++ b/Utils.hs @@ -0,0 +1,75 @@ +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) + +-- Query string parser + +decodeUrl :: Text -> Text +decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8 + +parseQs :: Text -> (Text, [(Text, Text)]) +parseQs url = + let + decoded = decodeUrl url + path = T.takeWhile (\c -> c /= '?') decoded + rest = T.dropWhile (\c -> c /= '?') decoded + + parsePair :: Text -> Maybe (Text, Text) + parsePair s + | T.any ((==) '=') s = Just (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 (:)) [] + +parseFirstLine :: Text -> (Text, Text) +parseFirstLine l = (method, url) + where [method, url, _] = T.words l + +parseHeader :: Text -> (Text, Text) +parseHeader line = + (T.takeWhile p line, T.strip $ T.tail + $ T.dropWhile p line) + where p = (\c -> c /= ':') + +parseHeaders :: [Text] -> [(Text, Text)] +parseHeaders = map parseHeader + +parseHttp :: Text -> ((Text, Text, [(Text, Text)]), [(Text, Text)], [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 new file mode 100644 index 0000000..47d81e5 --- /dev/null +++ b/Views.hs @@ -0,0 +1,10 @@ +module Views where + +import Request +import Response + +indexGet (Request query url method) = + return $ HtmlResponse 200 "<strong>index</strong>" + +helloGet req = + return $ HtmlResponse 200 "<i>hello</i>"
\ No newline at end of file diff --git a/net/Client.hs b/net/Client.hs new file mode 100644 index 0000000..863df6e --- /dev/null +++ b/net/Client.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +-- Echo client program +module Main (main) where + +import qualified Control.Exception as E +import qualified Data.ByteString.Char8 as C +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) + +main :: IO () +main = runTCPClient "127.0.0.1" "3000" $ \s -> do + sendAll s "Hello, world!" + msg <- recv s 1024 + putStr "Received: " + C.putStrLn msg + +-- from the "network-run" package. +runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPClient host port client = withSocketsDo $ do + addr <- resolve + E.bracket (open addr) close client + where + resolve = do + let hints = defaultHints { addrSocketType = Stream } + head <$> getAddrInfo (Just hints) (Just host) (Just port) + open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + connect sock $ addrAddress addr + return sock + diff --git a/net/Server.hs b/net/Server.hs new file mode 100644 index 0000000..0e53330 --- /dev/null +++ b/net/Server.hs @@ -0,0 +1,65 @@ +-- Echo server program +module Main (main) where + +import Control.Concurrent (forkFinally) +import qualified Control.Exception as E +import Control.Monad (unless, forever, void) + +import qualified Data.ByteString as S +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) + +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) + +join :: String -> [String] -> String +join delim [] = "" +join delim (s : []) = s +join delim (s : rest) = + s ++ delim ++ join delim rest + +packStr :: String -> S.ByteString +packStr = encodeUtf8 . T.pack + +(+++) = S.append + +response = join "\n" + [ "HTTP/1.1 200 OK" + , "Content-Type: text/html; charset=utf-8" + , "Connection: keep-alive" + , "" + , "<i>PRIVET</i>" + ] + +main :: IO () +main = runTCPServer Nothing "3000" talk + where + talk s = do + msg <- recv s 1024 + print msg + unless (S.null msg) $ do + sendAll s (packStr response) + talk s + +-- from the "network-run" package. +runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPServer mhost port server = withSocketsDo $ do + addr <- resolve + E.bracket (open addr) close loop + where + resolve = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + head <$> getAddrInfo (Just hints) mhost (Just port) + open addr = do + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + withFdSocket sock $ setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock + loop sock = forever $ do + (conn, _peer) <- accept sock + void $ forkFinally (server conn) (const $ gracefulClose conn 5000) |