hans-2.4.0.0: web-server/Main.hs
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- Copyright 2014 Galois, Inc.
-- This software is distributed under a standard, three-clause BSD license.
-- Please see the file LICENSE, distributed with this software, for specific
-- terms and conditions.
import Control.Concurrent
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BSC
import Data.Char
import Data.Time
import Data.Version
import Data.Word
import GHC.Stats
import Hans.Address.Mac
import Hans.Address.IP4
import Hans.Device.Tap
import Hans.DhcpClient
import Hans.Layer.Dns(DnsException)
import Hans.NetworkStack hiding (close)
import qualified Hans.NetworkStack as Hans
import Network.HTTP.Base
import Network.HTTP.Headers
import Network.HTTP.Stream
import Network.Stream
import System.Exit
import System.Info
import System.Locale
import Text.Blaze.Html5 as H hiding (map)
import Text.Blaze.Html5.Attributes(href)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Internal(string)
instance Stream Socket where
readLine s = loop ""
where loop acc =
do bstr <- recvBytes s 1
if | BS.null bstr -> return (Left ErrorClosed)
| BS.head bstr == 10 -> return (Right (acc ++ "\n"))
| otherwise -> loop (acc ++ BSC.unpack bstr)
readBlock s x = loop (fromIntegral x) BS.empty
where loop 0 acc = return (Right (BSC.unpack acc))
loop x acc =
do bstr <- recvBytes s x
if | BS.length bstr == x -> loop 0 (acc `BS.append` bstr)
| BS.length bstr == 0 -> return (Left ErrorClosed)
| otherwise -> loop (x - BS.length bstr)
(acc `BS.append` bstr)
writeBlock s str = loop (BSC.pack str)
where loop x | BS.null x = return (Right ())
| otherwise =
do amt <- sendBytes s x
loop (BS.drop amt x)
close s = Hans.close s
closeOnEnd _ _ = return ()
data ServerState = ServerState {
startTime :: String
, responseCount :: MVar Word64
, lastHosts :: MVar [(IP4, Maybe String)]
}
main :: IO ()
main =
do startTime <- formatTime defaultTimeLocale "%c" `fmap` getZonedTime
responseCount <- newMVar 0
lastHosts <- newMVar []
startServer ServerState { .. }
initEthernetDevice :: NetworkStack -> IO Mac
initEthernetDevice ns =
do let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x89
Just dev <- openTapDevice "tap6"
addDevice ns mac (tapSend dev) (tapReceiveLoop dev)
return mac
startServer :: ServerState -> IO ()
startServer state =
do ns <- newNetworkStack
mac <- initEthernetDevice ns
deviceUp ns mac
putStrLn ("Starting server on device " ++ show mac)
ipMV <- newEmptyMVar
dhcpDiscover ns mac (putMVar ipMV)
ipaddr <- takeMVar ipMV
putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr)
lsock <- listen ns undefined 80 `catch` handler
forever $ do
sock <- accept lsock
putStrLn "Accepted socket."
forkIO (handleClient sock state)
forkIO (addHost ns (sockRemoteHost sock) (lastHosts state))
return ()
where
handler ListenError{} =
do putStrLn ("Unable to listen on port 80\n")
threadDelay (5 * 1000000)
exitFailure
handleClient :: Socket -> ServerState -> IO ()
handleClient sock state =
do mreq <- receiveHTTP sock
case mreq of
Left err -> putStrLn ("ReqERROR: " ++ show err)
Right req ->
do body <- buildBody req state
putStrLn "Built response"
let lenstr = show (length body)
keepAlive = [ mkHeader HdrConnection "keep-alive"
| hdr <- retrieveHeaders HdrConnection req
, map toLower (hdrValue hdr) == "keep-alive" ]
conn | null keepAlive = [ mkHeader HdrConnection "Close" ]
| otherwise = keepAlive
resp = Response {
rspCode = (2,0,0)
, rspReason = "OK"
, rspHeaders = mkHeader HdrContentLength lenstr
: mkHeader HdrContentType "text/html"
: conn
, rspBody = body
}
respondHTTP sock resp
if null keepAlive
then Hans.close sock
else handleClient sock state
buildBody :: Request String -> ServerState -> IO String
buildBody req state =
do numReqs <- modifyMVar (responseCount state) (\ x -> return (x + 1, x))
prevHosts <- readMVar (lastHosts state)
putStrLn ("prevHosts: " ++ show prevHosts ++ "\n")
return $ renderHtml $
docTypeHtml $ do
H.head (title "HaLVM Test Server")
body $ do
h1 "Hi!"
p $ do "I'm a HaLVM. Technically I'm " >> string compilerName
" version " >> string (showVersion compilerVersion)
", ported to run on Xen. I started running on "
string (startTime state) >> ". You didn't know there was a "
"HaLVM standard time, did you? Well, there is. Really."
p $ do "I have responded to " >> (string (show numReqs)) >> " "
"requests since I started, not including yours."
p $ do "I am using: "
ul $ do
li $ hans >> " to talk to you over TCP."
li $ do http >> " (modified to use the " >> network_hans
" shim) to understand your request and respond to it."
li $ do blaze >> " (which built out of the box) to generate this "
"pretty HTML."
li $ do "... and a host of other libraries to do other, more "
"standard, things."
p $ do "Here are the last 5 hosts that I did something for:"
ol $ forM_ prevHosts $ \ x -> li (renderHost x)
where
hans, http, blaze, network_hans :: Html
hans = a ! href "http://hackage.haskell.org/package/hans" $ "HaNS"
http = a ! href "http://hackage.haskell.org/package/HTTP" $ "HTTP"
blaze = a ! href "http://hackage.haskell.org/package/blaze-html"$"blaze-html"
network_hans = a ! href "http://github.com/GaloisInc/network-hans" $
"network-hans"
renderHost :: (IP4, Maybe String) -> Html
renderHost (addr, Nothing) = string (show addr)
renderHost (addr, Just n) = string (n ++ " (" ++ show addr ++ ")")
addHost :: NetworkStack -> IP4 -> MVar [(IP4, Maybe String)] -> IO ()
addHost ns addr hostsMV =
do putStrLn ("addHost " ++ show addr)
entry <- catch (name `fmap` getHostByAddr ns addr) handleDnsError
list <- takeMVar hostsMV
putStrLn ("list: " ++ show list)
case lookup addr list of
Just _ -> putMVar hostsMV list >> putStrLn "put old list"
Nothing -> putMVar hostsMV (take 5 ((addr, entry) : list )) >> putStrLn "put new list"
where
name = Just . hostName
handleDnsError :: DnsException -> IO (Maybe String)
handleDnsError e = print e >> return Nothing