Initial commit

1 files changed, 75 insertions, 0 deletions

diff --git a/src/Http.hs b/src/Http.hs
new file mode 100644
index 0000000..f486920
--- /dev/null
+++ b/src/Http.hs
@@ -0,0 +1,75 @@
+module Http (runServer) where
+
+import qualified Cache as C
+import Common (maybeAt, splitOn)
+import qualified Html as H
+import Intro
+import qualified Mail as M
+import Network.Socket (HostName, ServiceName, Socket, socketToHandle)
+import qualified Queue as Q
+import System.IO (Handle, IOMode (ReadWriteMode), hClose, hGetLine, hPutStrLn)
+import qualified Tcp
+import qualified Template as T
+import Text.Read (readMaybe)
+
+runServer :: Maybe HostName -> ServiceName -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+runServer host port cache queue = Tcp.runServer host port (sockHandler cache queue)
+
+sockHandler :: C.CacheM -> Q.QueueM M.Mail -> Socket -> IO ()
+sockHandler cache queue s = do
+  handle <- socketToHandle s ReadWriteMode
+  requestHandler handle cache queue
+
+requestHandler :: Handle -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+requestHandler h cache queue = do
+  line <- hGetLine h
+  case route line of
+    ("GET", []) -> showInbox h cache
+    ("GET", ["poll", s]) -> showPolled h queue s
+    ("GET", ["mail", n]) -> case (readMaybe n :: Maybe Int) of
+      Just n' -> showMail h cache n'
+      Nothing -> showNotFound h
+    _ -> showNotFound h
+  hClose h
+
+showNotFound :: Handle -> IO ()
+showNotFound h = do
+  replyHtml h 404 [H.p ["Page not found"]]
+
+showInbox :: Handle -> C.CacheM -> IO ()
+showInbox h cache = do
+  inbox <- C.getInbox cache
+  replyHtml h 200 (T.inbox inbox)
+
+showMail :: Handle -> C.CacheM -> Int -> IO ()
+showMail h cache idx = do
+  mail <- maybeAt idx <$> C.getInbox cache
+  case mail of
+    Just mail' -> replyHtml h 200 (T.mail mail')
+    Nothing -> showNotFound h
+
+showPolled :: Handle -> Q.QueueM M.Mail -> String -> IO ()
+showPolled h queue s = do
+  mail <- Q.pullWith (\m -> m.to == [s]) queue
+  replyHtml h 200 (T.mail mail)
+
+route :: String -> (String, [String])
+route x = case words x of
+  [m, p, "HTTP/1.1"] -> (m, splitOn (== '/') p)
+  _ -> ("GET", [])
+
+replyHtml :: Handle -> Int -> [String] -> IO ()
+replyHtml h s body = do
+  let page = H.html body
+  hPutStrLn h $ "HTTP/1.1 " ++ status s
+  hPutStrLn h "content-type: text/html"
+  hPutStrLn h $ "content-length: " ++ show (length page)
+  hPutStrLn h ""
+  hPutStrLn h page
+  hPutStrLn h ""
+
+status :: Int -> String
+status s = case s of
+  200 -> "200 OK"
+  404 -> "404 NOT FOUND"
+  _ -> "500 INTERNAL SERVER ERROR"