-----------------------------------------------------------------------------
-- |
-- Module      :  TinyHTTP
-- Copyright   :  (c) Don Stewart 2006
-- License     :  BSD3-style (see LICENSE)
-- 
-- Maintainer  :  dons@cse.unsw.edu.au
-- Stability   :  stable
-- Portability :  portable
--
-- Minimal HTTP functionality
--
-----------------------------------------------------------------------------

module TinyHTTP (
    Proxy, getStatus,
    module Network.URI
  ) where

import Network
import Network.URI hiding (authority)
import Control.Monad.Error 

import Data.List        (findIndex)
import Data.Maybe

import System.IO

userAgent :: String
userAgent = "urlcheck/0.1 (http://www.cse.unsw.edu.au/~dons/urlcheck)"

getStatus :: URI -> Proxy -> IO (Either String Int)
getStatus uri proxy = chase uri 5
  where
    chase _ 0 = return (Left "Too many redirects.")
    chase u n = do
        s <- getURI u proxy
        case status s of
            n | n `elem` [301,302,303,307] -> case redirect s of
                    Right u' -> chase u' (n-1)
                    Left err -> return (Left err)
            200 -> return (Right 200)
            n   -> return (Right n)

        -- Parse the HTTP response code in format: HTTP/1.1 200 Success.
    status   h = (read . (!!1) . words . (!!0)) h :: Int

    redirect h
          | Just loc <- getHeader "Location" h = case parseURI loc of
                Nothing -> do
                    let furl = fullUrl loc
                    case parseURI furl of
                        Nothing -> fail "Invalid redirect"
                        Just u  -> return u
                Just u  -> return u
          | otherwise = fail "No Location header found in 3xx response."

    fullUrl loc = case uriAuthority uri of
            Nothing -> error "No authority string."
            Just a  -> uriScheme uri ++ "//" ++ (uriRegName a) ++ loc


getHeader :: String -> [String] -> Maybe String
getHeader _   []     = Nothing
getHeader hdr (_:hs) = lookup hdr $ concatMap mkassoc hs
    where
      removeCR   = takeWhile (/='\r')
      mkassoc s  = case findIndex (==':') s of
                    Just n  -> [(take n s, removeCR $ drop (n+2) s)]
                    Nothing -> []

getURI :: URI -> Proxy -> IO [String]
getURI uri proxy = readNBytes 1024 proxy uri request ""
    where
      request  | Nothing <- proxy =
                   ["HEAD " ++ absPath ++ " HTTP/1.1",
                   "Host: " ++ host,
                   "User-Agent: " ++ userAgent,
                   "Connection: close", ""]
               | otherwise       =
                   ["HEAD " ++ show uri ++ " HTTP/1.0", ""]

      absPath = case uriPath uri ++ uriQuery uri ++ uriFragment uri of
                   url@('/':_) -> url
                   url         -> '/':url

      host = case uriAuthority uri of
                Nothing -> error "getURI: No authority string."
                Just u  -> uriRegName u

readNBytes :: Int -> Proxy -> URI -> [String] -> String -> IO [String]
readNBytes n proxy uri headers body = withSocketsDo $ do
    h <- connectTo host (PortNumber (fromInteger port))
    mapM_ (\s -> hPutStr h (s ++ "\r\n")) headers
    hPutStr h body
    hFlush h
    s <- lines `fmap` hGetN n h
    hClose h
    return s
  where
    (host, port) = fromMaybe (authority uri, 80) proxy

    hGetN :: Int -> Handle -> IO String
    hGetN i h | i `seq` h `seq` False = undefined -- strictify
    hGetN 0 _ = return []
    hGetN i h = do eof <- hIsEOF h
                   if eof then return []
                          else liftM2 (:) (hGetChar h) (hGetN (i-1) h)

type Proxy = Maybe (String, Integer)

authority :: URI -> String
authority = uriRegName . maybe (error "authority") id . uriAuthority