HTTP availability check in Haskell (with some redirect handling)

http-check.hs

import Control.Monad
import Prelude hiding (catch)
import Control.Exception
import Control.Concurrent.ParallelIO
import qualified Control.Concurrent.ParallelIO.Local as Local
import Network.HTTP
import Network.Stream (ConnError(..), Result)
import System.IO
import Data.List

-- Mostly written by @thoferon. 

data Website = Website { websiteId  :: String
                       , websiteUrl :: String
                       } deriving (Show)

data SiteResponse = HTTPSuccess |
                    HTTPError |
                    HTTPRedirect String |
                    NetworkError deriving (Show)

checkWebsite :: Website -> IO SiteResponse
checkWebsite (Website _ url) = checkUrl url 3

checkUrl :: String -> Int -> IO SiteResponse
checkUrl _ 0           = return HTTPError
checkUrl url nRedirect = do
  hPutStrLn stderr $ "Checking URL: "  ++ url
  result <- safeGet
  case handleResponse result of
    HTTPRedirect location -> checkUrl location $ nRedirect - 1
    other -> return other
 
  where safeGet :: IO (Result (Response String))
        safeGet = catch (simpleHTTP $ getRequest url) $ \e -> do
                    return . Left . ErrorMisc $ show (e :: IOError)

handleResponse :: Result (Response String) -> SiteResponse
handleResponse (Left _)     = NetworkError
handleResponse (Right resp) =
    case rspCode resp of
      (2,_,_) -> HTTPSuccess
      (3,_,_) -> handleRedirect
      _ -> HTTPError
  where
    handleRedirect :: SiteResponse
    handleRedirect = case filter ((== HdrLocation) . hdrName) $ rspHeaders resp of
                       (Header _ location:_) -> HTTPRedirect location
                       _ -> HTTPError

main = do
  let sites = [Website "1" "http://example.com", Website "2" "http://foooozzzz", Website "3" "http://google.com"]
  Local.withPool 2 $ \pool -> do
    resps <- Local.parallel pool $ map checkWebsite sites
    print resps