Tag Archives: httpd

httpd.hs

This is my attempt to write something in Haskell. So, taking inspiration from rephttpd and in an effort to learn monads, I’ve written following HTTP server, which I’ll keep improvising and use as testbed for my Haskell fantasies…:)

-- HTTP Server
-- Author: Ashish SHUKLA <members.fsf.org!wahjava>
import System.IO
import Network.BSD
import Network.Socket
import Data.Char
import Control.Monad.State.Lazy
import System.Posix.Files
import System.FilePath
import Data.Map as M
import System.Posix.Process

import System.Directory (getDirectoryContents)

import Control.Concurrent (forkIO)

import Data.ByteString as B (hGetContents, hPut)

data HttpRequest = HttpRequest { httpMethod :: String
                               , httpPath :: String
                               , httpRequestVersion :: String
                               , httpRequestHeaders :: [(String, String)]
                               }
                 deriving (Show)
data HttpResponse = HttpResponse { httpCode :: Integer
                                 , httpResponseVersion :: String
                                 , httpResponseHeaders :: [(String, String)]
                                 , httpData :: Maybe (Handle -> IO ())
                                 }

instance Show HttpResponse where
    show h = ("HTTP Code: " ++ ((show . httpCode) h) ++
              "HTTP Headers:\n" ++ ((show . httpResponseHeaders) h) ++ "HTTP Data: " ++
              (case (httpData h) of
                 Just x -> "Something"
                 Nothing -> "Nothing"))

emptyHttpRequest = HttpRequest "" "" "" []

documentRoot = "/usr/share/doc/ghc/libraries"

serverName = "httpd"

mimeMap = M.fromList [ (".txt", "text/plain")
                     , (".html", "text/html")
                     , (".jpg", "image/jpeg")
                     , (".gif", "image/gif")
                     , (".png", "image/png")
                     , (".js", "text/javascript")
                     , (".css", "text/css")
                     , (".pdf", "application/pdf") ]

lookupMimeType :: FilePath -> String
lookupMimeType fp = case (M.lookup (takeExtension fp) mimeMap) of
                      Just x -> x
                      Nothing -> "application/octet-stream"

httpStatusCodeString :: Integer -> String
httpStatusCodeString 200 = "OK"
httpStatusCodeString 404 = "File not found"

bindAddress = SockAddrInet6 8080 0 iN6ADDR_ANY 0

ltrim :: (Char -> Bool) -> [Char] -> [Char]
ltrim ch [] = []
ltrim ch (x:xs) | ch x = (ltrim ch xs)
                | otherwise = (x:xs)

rtrim :: (Char -> Bool) -> [Char] -> [Char]
rtrim ch [] = []
rtrim ch x  = reverse (ltrim ch (reverse x))

splitHeaders :: String -> (String, String)
splitHeaders string = let (h,v) = span (/= ':') string
                      in  (h, (rtrim isSpace (ltrim isSpace  (tail v))))

putResponse :: Handle -> HttpResponse -> IO ()
putResponse h response = do hPutStrLn h $ ((httpResponseVersion response) ++ " " ++ show (httpCode response) ++ " " ++ ((httpStatusCodeString . httpCode) response) ++ "\r")
                            mapM printHeaders (keys (httpResponseHeaders response))
                            hPutStrLn h $ "\r"
                            case (httpData response) of
                              Just fn -> fn h
                              Nothing -> return ()
    where printHeaders k = hPutStrLn h $ (k ++ ": " ++
                                          (case (Prelude.lookup k (httpResponseHeaders response)) of
                                               Just x -> x
                                               Nothing -> "") ++ "\r")
          keys :: [(String, String)] -> [String]
          keys headers = (fst . unzip) $ headers

processGET :: Handle -> HttpRequest -> IO Bool
processGET handle req = let path = documentRoot ++ (httpPath req)
                        in  fileExist (path) >>=
                            fileOutput path >>
                            (hFlush handle) >>
                            return  ((Prelude.lookup "Connection" (httpRequestHeaders req)) /= Just "Close")
    where fileOutput path True = getFileStatus path >>=
                                    (\h -> if isDirectory h
                                           then dirModule path handle req
                                           else withBinaryFile path ReadMode (http200 path (httpRequestVersion req) ))
          fileOutput path False = http404 (httpRequestVersion req)
          http200 fp hv h = do filelen <- hFileSize h
                               putResponse handle (HttpResponse 200
                                                                 hv
                                                                 [ ("Content-Type", (lookupMimeType fp))
                                                                 , ("Server", serverName)
                                                                 , ("Content-Length", (show filelen)) ]
                                                                 (Just $ printFile h))
          http404 hv = putResponse handle (HttpResponse 404
                                                        hv
                                                        [ ("Content-Type", "text/plain")
                                                        , ("Content-Length", ((show . length . httpStatusCodeString) 404)) ]
                                                        (Just (\h -> hPutStrLn h (httpStatusCodeString 404))))
          printFile fh hh = (B.hGetContents fh) >>=
                            (B.hPut hh) >>
                            (hPutStr hh "\r\n\r\n") >>
                            (hClose fh)

dirModule :: FilePath -> Handle -> HttpRequest -> IO ()
dirModule path handle req = putResponse handle (HttpResponse 200
                                                             (httpRequestVersion req)
                                                             [ ("Content-Type", "text/html")
                                                             , ("Server", serverName) ]
                                                             (Just $ printDir path (httpPath req)))
    where printDir :: FilePath -> FilePath -> Handle -> IO ()
          printDir path vdir h = (hPutStrLn h $ "<html><head><title>Directory listing of " ++ path ++ "</title></head><body><table>") >>
                            (getDirectoryContents path) >>= (mapM_ (printDirEntry h vdir path)) >>
                            (hPutStrLn h $ "</table></body></html>")
          printDirEntry :: Handle -> FilePath -> FilePath -> FilePath -> IO ()
          printDirEntry h base path file = (getFileStatus $ path ++ (pathSeparator:file)) >>=
                (\s -> hPutStrLn h $ "<tr><td><a href=\"" ++ base ++ file ++ (if isDirectory s then pathSeparator:[] else "") ++ "\">" ++ file ++ "</a></td></tr>")

handleSocket :: (Socket, SockAddr) -> IO ()
handleSocket (sock, addr) = do h <- socketToHandle sock ReadWriteMode
                               processRequest' h
                               hClose h
    where handleSocket' h = do req <- get
                               line <- lift $ hGetLine h
                               lift $ putStrLn $ line
                               let w = words $ line
                               put $ req { httpMethod = (w !! 0)
                                         , httpPath = (w !! 1)
                                         , httpRequestVersion = (w !! 2) }
                               handleSocket'' h >>= return
          handleSocket'' h = do r <- get
                                l <- lift $ hGetLine h
                                if (l == "\r")
                                   then return r
                                   else let (k, v) = splitHeaders $ l
                                        in do put $ r { httpRequestHeaders = (k,v):(httpRequestHeaders r) } --M.insert k v (httpRequestHeaders r) }
                                              handleSocket'' h >>= return
          processRequest' h = do req <- evalStateT (handleSocket' h) emptyHttpRequest
                                 result <- processGET h req
                                 if result
                                    then processRequest' h
                                    else hClose h >> return ()

main = do ssock <- socket AF_INET6 Stream 0
          setSocketOption ssock ReuseAddr 1
          bindSocket ssock bindAddress
          listen ssock 5
          acceptForever ssock handleSocket
          sClose ssock
       where acceptForever s h = (accept s >>= (forkIO . h) >>= (putStrLn . ((++) "Forked thread ") . show) >> (acceptForever s h))