1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
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"
|
