From 46d7f5d2d88a62ed2c77514c33d97e25d737881c Mon Sep 17 00:00:00 2001 From: Andrew Date: Fri, 27 Nov 2020 20:51:21 +0400 Subject: Added networking --- Main.hs | 58 +++++++++++++++++++++++++++++++++++++++++++++---------- Routes.hs | 14 ++++++++++++++ Views.hs | 25 ++++++++++++++++++++++++ Web/Response.hs | 4 ++-- Web/Utils.hs | 12 +++++++----- Web/Views.hs | 25 ------------------------ haskell-web.cabal | 10 ++++++++-- 7 files changed, 104 insertions(+), 44 deletions(-) create mode 100644 Routes.hs create mode 100644 Views.hs delete mode 100644 Web/Views.hs diff --git a/Main.hs b/Main.hs index 3ebb7d1..56fa613 100644 --- a/Main.hs +++ b/Main.hs @@ -1,17 +1,55 @@ -module Main where +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 (decodeUtf8, encodeUtf8) + +import Network.Socket +import Network.Socket.ByteString (recv, sendAll) +import Web.Utils import Web.Response -import Web.Request import Web.Router -import Web.Views -import Web.Utils -import Web.Http - -table = [ Route indexGet (T.pack "/") GET - , Route helloGet (T.pack "/hello") GET ] +import Routes +main :: IO () main = do - response <- resolve table (Request [] (T.pack "/hello") GET) - print $ formResponse response \ No newline at end of file + print "Server launched" + runTCPServer Nothing "3000" talk + where + talk s = do + msg <- recv s 1024 + -- print msg + print "Got request" + unless (S.null msg) $ do + let (request, _, _) = parseHttp $ decodeUtf8 msg + response <- resolve routesTable $ request + sendAll s $ encodeUtf8 (formResponse response) + + +-- 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) diff --git a/Routes.hs b/Routes.hs new file mode 100644 index 0000000..3dbb3aa --- /dev/null +++ b/Routes.hs @@ -0,0 +1,14 @@ +module Routes where + +import qualified Data.Text as T + +import Web.Response +import Web.Request +import Web.Router +import Web.Utils +import Web.Http + +import Views + +routesTable = [ Route indexGet (T.pack "/") GET + , Route helloGet (T.pack "/hello") GET ] \ No newline at end of file diff --git a/Views.hs b/Views.hs new file mode 100644 index 0000000..54cd844 --- /dev/null +++ b/Views.hs @@ -0,0 +1,25 @@ +module Views where + +import System.IO +import qualified Data.Text as T +import Data.Text (Text) + +import Web.Request +import Web.Response + +indexGet :: Request -> IO Response +indexGet req = renderTemplate "index.html" + +helloGet :: Request -> IO Response +helloGet req = renderTemplate "hello.html" + +renderTemplate :: String -> IO Response +renderTemplate name = do + template <- readTemplate name + return $ HtmlResponse 200 template + +readTemplate :: String -> IO Text +readTemplate name = do + handle <- openFile ("templates/" ++ name) ReadMode + contents <- hGetContents handle + return $ T.pack contents diff --git a/Web/Response.hs b/Web/Response.hs index 9bc2179..3c393ad 100644 --- a/Web/Response.hs +++ b/Web/Response.hs @@ -23,8 +23,8 @@ getContent (TextResponse _ _ content) = content formResponse :: Response -> Text formResponse (HtmlResponse code html) = - T.unlines + T.strip $ T.unlines $ map T.pack [ "HTTP/1.1 " ++ getStatus code , "Content-Type: text/html; charset=utf-8" - , "Connection: keep-alive" + , "Connection: close" , "" ] ++ [html] diff --git a/Web/Utils.hs b/Web/Utils.hs index 4e9082b..97bc512 100644 --- a/Web/Utils.hs +++ b/Web/Utils.hs @@ -9,6 +9,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text (Text) import Web.Http +import Web.Request -- Query string parser @@ -44,14 +45,14 @@ parseQs url = rev :: [a] -> [a] rev = foldl (flip (:)) [] -getMethod :: Text -> Method -getMethod s +parseMethod :: Text -> Method +parseMethod s | s == (T.pack "POST") = POST | s == (T.pack "PUT") = PUT | otherwise = GET parseFirstLine :: Text -> (Method, Text) -parseFirstLine l = (getMethod methodT, url) +parseFirstLine l = (parseMethod methodT, url) where [methodT, url, _] = T.words l parseHeader :: Text -> Header @@ -63,7 +64,8 @@ parseHeader line = parseHeaders :: [Text] -> [Header] parseHeaders = map parseHeader -parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text]) +-- parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text]) +parseHttp :: Text -> (Request, [Header], [Text]) parseHttp text = let lines = T.splitOn (T.pack "\r\n") text @@ -80,7 +82,7 @@ parseHttp text = (method, url) = parseFirstLine fl (path, query) = parseQs url in - ((method, path, query), parseHeaders headers, rest2) + ((Request query path method), parseHeaders headers, rest2) -- HTTP Status Codes statusCodes = diff --git a/Web/Views.hs b/Web/Views.hs deleted file mode 100644 index 6619d09..0000000 --- a/Web/Views.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Web.Views where - -import System.IO -import qualified Data.Text as T -import Data.Text (Text) - -import Web.Request -import Web.Response - -indexGet (Request query url method) = - return $ HtmlResponse 200 (T.pack "index") - -helloGet req = - return $ HtmlResponse 200 (T.pack "hello") - -renderTemplate :: String -> IO Response -renderTemplate name = do - template <- readTemplate name - return $ HtmlResponse 200 template - -readTemplate :: String -> IO Text -readTemplate name = do - handle <- openFile ("templates/" ++ name) ReadMode - contents <- hGetContents handle - return $ T.pack contents diff --git a/haskell-web.cabal b/haskell-web.cabal index e37184c..4141764 100644 --- a/haskell-web.cabal +++ b/haskell-web.cabal @@ -12,9 +12,15 @@ build-type: Simple executable haskell-web main-is: Main.hs other-modules: - Web.Http, Web.Request, Web.Response, Web.Router, Web.Utils, Web.Views + Web.Http + , Web.Request + , Web.Response + , Web.Router + , Web.Utils + , Views + , Routes -- other-extensions: build-depends: - base >=4.14 && <4.15, text, http-types, bytestring + base >=4.14 && <4.15, text, http-types, bytestring, network -- hs-source-dirs: default-language: Haskell2010 -- cgit v1.2.3