apps/Main.hs

   1 import Network
   2 import Network.Socket
   3 import Network.HTTP
   4 import Network.HTTP.Stream
   5 import System.IO
   6 import Control.Monad
   7 import Control.Arrow
   8 import Control.Category
   9 import Prelude hiding (id,(.))
  10 import Text.XHtml.Transitional
  11 import Control.Concurrent
  12
  13 getHogName = "Hog"
  14 getHogVersion = "0.1.0"
  15 getFullName = getHogName ++ " " ++ getHogVersion
  16
  17 data Family
  18     = AF_UNSPEC           -- unspecified
  19     | AF_LANA
  20     deriving (Eq, Ord, Read, Show)
  21
  22 type RequestHandler = Request String -> IO (Response String)
  23
  24 --main = runHttpServer defaultIndexDoc
  25 main = runHttpServer hellowWorldHandler
  26
  27 hellowWorldHandler :: RequestHandler
  28 hellowWorldHandler _ =
  29     return $ successResponse $ prettyHtml helloWorldDoc
  30
  31 successResponse :: String -> Response String
  32 successResponse  s =
  33     Response   (2,0,0) "" [] s
  34
  35 helloWorldDoc :: Html
  36 helloWorldDoc =
  37     header << thetitle << (getFullName ++ " running!")
  38            Text.XHtml.Transitional.+++
  39                body << h1 << (getFullName ++ " running!")
  40
  41 --defaultIndexDoc :: Html
  42 --defaultIndexDoc = hopReadFile "/var/www/index.html" >>= return . stringToHtml
  43 --do
  44 --    c <- hopReadFile "/var/www/index.html"
  45 --    return $ stringToHtml liftM c
  46
  47 hopReadFile :: String -> IO String
  48 hopReadFile filename = readFile filename
  49
  50 runHttpServer :: RequestHandler -> IO ()
  51 runHttpServer r =
  52     withSocketsDo $ do
  53       sock <- socket AF_LANA Stream 0
  54       setSocketOption sock ReuseAddr 1
  55       bindSocket sock $ SockAddrInet 8080 iNADDR_ANY
  56       listen sock 8080
  57       forever $ acceptConnection sock $ handleHttpConnection r
  58
  59 acceptConnection :: Socket -> (Handle -> IO ()) -> IO ()
  60 acceptConnection s k =
  61      Network.accept s >>= \(h,_,_) -> forkIO (k h) >> return ()
  62
  63 instance Stream Handle where
  64     readLine   h   = hGetLine h >>= \ l -> return $ Right (l ++ "\n")
  65     readBlock  h n = replicateM n (hGetChar h) >>= return . Right
  66     writeBlock h s = mapM_ (hPutChar h) s >>= return . Right
  67     close          = hClose
  68
  69 handleHttpConnection :: RequestHandler -> Handle -> IO ()
  70 handleHttpConnection r c =
  71     runKleisli
  72     (receiveRequest >>> handleRequest r >>> handleResponse) c >>
  73     Network.HTTP.Stream.close c
  74     where
  75       receiveRequest  = Kleisli Network.HTTP.Stream.receiveHTTP
  76       handleRequest r = right (Kleisli r)
  77       handleResponse  = Kleisli (print ||| Network.HTTP.Stream.respondHTTP c)
  78