Static web server with a bit of error handling

Question

I am looking for a review on this code, which is a simple static web server, with a small bit of error handling. It's feeling a bit "messy" / "imperative" at the moment, so advice would be welcome.

import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString as B
import Data.List
import Control.Concurrent
import Control.Exception (SomeException, try)
import qualified Data.Map.Strict as Map
import System.FilePath.Posix
import System.Directory (doesFileExist)
import Text.Printf

port = 8080
incomingBufferSize = 16384
mimeTypes = Map.fromList [
    (".htm", "text/html"),
    (".html", "text/html"),
    (".js", "application/javascript"),
    (".css", "text/css"),
    (".png", "image/png"),
    (".jpg", "image/jpeg"),
    (".jpeg", "image/jpeg")
  ]
defaultMime = "application/octet-stream"
headerOkText = "HTTP/1.1 200 OK\r\nContent-Type: %s\r\n\r\n"
header404 = "HTTP/1.1 404\r\n\r\n"
header500 = "HTTP/1.1 500\r\n\r\n"

main = do
  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bind sock $ SockAddrInet port iNADDR_ANY
  listen sock sOMAXCONN
  mainLoop sock

mainLoop :: Socket -> IO ()
mainLoop sock = do
  (conn, _) <- accept sock
  forkIO $ handle conn
  mainLoop sock

handle :: Socket -> IO ()
handle conn = do
  incoming <- recv conn incomingBufferSize
  let unsafeLocation = extractLocation incoming
  if isSafeLocation unsafeLocation then
    do
      fileContents <- try $ response unsafeLocation
      send conn $ contentsOr500 fileContents
  else
    send conn $ C.pack header404
  close conn
  where
    extractLocation = C.unpack . C.tail . head . tail . C.split ' '
    isSafeLocation location = not $ ".." `isInfixOf` location

contentsOr500 :: Either SomeException B.ByteString -> B.ByteString
contentsOr500 (Left _) = C.pack header500
contentsOr500 (Right contents) = contents

response :: String -> IO (B.ByteString)
response requestedLocation = do
  exists <- doesFileExist requestedLocation
  if exists then
    do
      file <- B.readFile requestedLocation
      return $ fullResponse file $ takeExtension requestedLocation
    else
      return $ C.pack header404

fullResponse :: B.ByteString -> String -> B.ByteString
fullResponse contents extension = C.pack headerWithMime `B.append` contents
  where
    headerWithMime = printf headerOkText $ mimeForExtension extension
    mimeForExtension = flip (Map.findWithDefault defaultMime) mimeTypes

Babra Cunningham · Accepted Answer · 2017-03-10 18:44:47Z

1

My initial reaction to this code is that it would be clearer if you bring some functions outside main = do.

One of the great things about Haskell is it's explicit type system and safety; your code doesn't leverage this as there are no function type declarations.

answered Mar 10, 2017 at 18:44

Babra Cunningham

2443 silver badges12 bronze badges

\$\begingroup\$ I have made a few more functions with explicit function type declarations in my answer at codereview.stackexchange.com/a/157462/34049 . Although, because of type inference, does it actually make it more safe? \$\endgroup\$

Michal Charemza
– Michal Charemza

2017-03-10 19:31:02 +00:00
Commented Mar 10, 2017 at 19:31

Add a comment |

Michal Charemza · Accepted Answer · 2017-03-10 19:28:24Z

Below is my attempt at a tidy up, featuring

No more do notation, all explicit >>= and >>
Pattern matching over if
Tried not using where, but named functions at the root level
Split things out into a few more functions
Specifically, moved more things into non-IO functions
Even more specifically, made the core handler of "receive request" >> "process request" >> "send response" part of the code much clearer, by making sure there is only one call to send in the code
Moving constants to the bottom, and imperative-style code to the top
Making all imports explicit

import Prelude hiding (readFile)

import Control.Concurrent (forkIO)
import Control.Exception (SomeException, try)
import Data.ByteString (ByteString, append, readFile)
import Data.ByteString.Char8 (pack, unpack)
import Data.List (isInfixOf)
import Data.List.Split (splitOn)
import Data.Map.Strict (findWithDefault, fromList)
import Network.Socket (
  Family(AF_INET), SockAddr(SockAddrInet), Socket, SocketOption(ReuseAddr), SocketType(Stream), 
  iNADDR_ANY, sOMAXCONN,
  accept, bind, close, listen, setSocketOption, socket
  )
import Network.Socket.ByteString (recv, send)
import System.Directory (doesFileExist)
import System.FilePath.Posix (takeExtension)
import Text.Printf (printf)

---------------
-- IO functions

main :: IO ()
main = socket AF_INET Stream 0 >>= \sock ->
       setSocketOption sock ReuseAddr 1 >> 
       bind sock (SockAddrInet port iNADDR_ANY) >>
       listen sock sOMAXCONN >>
       mainLoop sock

mainLoop :: Socket -> IO ()
mainLoop sock = accept sock >>= forkIO . handle . fst >> mainLoop sock

handle :: Socket -> IO ()
handle conn = recv conn incomingBufferSize >>=
              response . extractPath . unpack >>=
              send conn >>
              close conn

response :: String -> IO ByteString
response path = (isSafePath path) &&& (doesFileExist path) >>= responseForPath path

responseForPath :: String -> Bool -> IO ByteString
responseForPath _    False = return $ pack header404
responseForPath path True  = try (readFile path) >>= 
                             return . fullHttpResponseOr500 (mimeForPath path)

-- Short circuit && that accepts pure + IO action
(&&&) :: Bool -> IO Bool -> IO Bool
False &&& _         = return False
True  &&& bIOAction = bIOAction

-------------------
-- Non IO functions

fullHttpResponseOr500 :: String -> Either SomeException ByteString -> ByteString
fullHttpResponseOr500 _    (Left  _)        = pack header500
fullHttpResponseOr500 mime (Right contents) = fullHttpResponse mime contents

fullHttpResponse :: String -> ByteString -> ByteString
fullHttpResponse = append . pack . printf headerOk

extractPath :: String -> String
extractPath = tail . head . tail . splitOn " "

mimeForPath :: String -> String
mimeForPath path = findWithDefault defaultMime (takeExtension path) mimeTypes

isSafePath :: String -> Bool
isSafePath = not . isInfixOf ".."

------------
-- Constants

port = 8080
incomingBufferSize = 16384
mimeTypes = fromList [
    (".html", "text/html"),
    (".jpeg", "image/jpeg")
  ]
defaultMime = "application/octet-stream"
headerOk = "HTTP/1.1 200 OK\r\nContent-Type: %s\r\n\r\n"
header404 = "HTTP/1.1 404\r\n\r\n"
header500 = "HTTP/1.1 500\r\n\r\n"

Stack Exchange Network

Static web server with a bit of error handling

2 Answers 2

You must log in to answer this question.

Hot Network Questions

Static web server with a bit of error handling

2 Answers 2

You must log in to answer this question.

Related

Hot Network Questions