Added networking

6 files changed, 84 insertions, 24 deletions

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/Web/Views.hs b/Views.hs
index 6619d09..54cd844 100644
--- a/Web/Views.hs
+++ b/Views.hs
@@ -1,4 +1,4 @@
-module Web.Views where
+module Views where
 
 import System.IO
 import qualified Data.Text as T
@@ -7,11 +7,11 @@ import Data.Text (Text)
 import Web.Request
 import Web.Response
 
-indexGet (Request query url method) =
-  return $ HtmlResponse 200 (T.pack "<strong>index</strong>")
+indexGet :: Request -> IO Response
+indexGet req = renderTemplate "index.html"
 
-helloGet req =
-  return $ HtmlResponse 200 (T.pack "<i>hello</i>")
+helloGet :: Request -> IO Response
+helloGet req = renderTemplate "hello.html"
 
 renderTemplate :: String -> IO Response
 renderTemplate name = do
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/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