Minimal proxy server in Haskell

basic-proxy.hs

#!/usr/bin/env stack
{- stack
  --resolver lts-7.3
  --install-ghc
  runghc
  --package base
  --package bytestring
  --package dns
  --package http-client
  --package http-types
  --package wai
  --package warp
  -- -hide-all-packages
-}

-- Proxy server that explicitly performs a dns lookup of the target hostname
-- for every request, in order to allow load balancing via dns. License: WTFPL.
--
-- Copyright 2016 Ruud van Asseldonk
--
-- Everyone is permitted to copy and distribute verbatim or modified
-- copies of this license document, and changing it is allowed as long
-- as the name is changed.
--
--            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
--   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
--
--  0. You just DO WHAT THE FUCK YOU WANT TO.

{-# LANGUAGE OverloadedStrings #-}

import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Char8 (pack)
import Network.DNS.Lookup as Dns
import Network.DNS.Resolver as Dns
import Network.DNS.Types as Dns
import Network.HTTP.Client as HttpClient
import Network.HTTP.Types.Status (badGateway502)
import Network.Wai as Wai
import Network.Wai.Handler.Warp as Warp

target :: Dns.Domain
target = "example.nl"

listenPort :: Int
listenPort = 8000

translateRequest :: Wai.Request -> String -> HttpClient.Request
translateRequest request ipString = HttpClient.defaultRequest {
  HttpClient.host = pack ipString,
  HttpClient.method = Wai.requestMethod request,
  HttpClient.path = Wai.rawPathInfo request,
  HttpClient.queryString = Wai.rawQueryString request
}

translateResponse :: HttpClient.Response ByteString -> Wai.Response
translateResponse response =
  let
    status = HttpClient.responseStatus response
    headers = HttpClient.responseHeaders response
    body = HttpClient.responseBody response
  in
    responseLBS status headers body

proxyApp :: Dns.Resolver -> HttpClient.Manager -> Wai.Application
proxyApp resolver manager request respond = do
  dnsResult <- Dns.lookupA resolver target
  case dnsResult of
    Left _ ->
      respond $ Wai.responseLBS badGateway502 [] "failed to resolve target dns"
    Right [] ->
      respond $ Wai.responseLBS badGateway502 [] "dns lookup found no ip"
    Right (ip : _more) -> do -- Note: could also round-robin throug dns entries.
      let proxiedRequest = translateRequest request $ show ip
      response <- HttpClient.httpLbs proxiedRequest manager
      respond $ translateResponse response

main :: IO ()
main = do
  rs <- Dns.makeResolvSeed Dns.defaultResolvConf
  manager <- HttpClient.newManager HttpClient.defaultManagerSettings
  Dns.withResolver rs $ \ resolver ->
    Warp.run listenPort $ proxyApp resolver manager