-- |
-- Module: Network.Shed.Httpd 
-- Copyright: Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: GHC
--
--
-- A trivial web server.
--
-- This web server promotes a Request to IO Response function
-- into a local web server. The user can decide how to interpret
-- the requests, and the library is intended for implementing Ajax APIs.
--
-- initServerLazy (and assocated refactorings), and Chunking support
-- was written by Henning Thielemann.
-- Handling of POST-based payloads was been written by Brandon Moore.
-- initServerBind support was written by John Van Enk.

module Network.Shed.Httpd 
    ( Server
    , initServer
    , initServerLazy
    , initServerBind
    , Request(..)
    , Response(..)
    , queryToArguments
    , addCache
    , noCache
    , contentType
    ) where

import qualified Network as Network
import qualified Network.Socket as Socket
import Network.URI (URI, parseURIReference, unEscapeString)
import Network.BSD (getProtocolNumber)
import Network.Socket (
          SockAddr(SockAddrInet), iNADDR_ANY,
          bindSocket, setSocketOption, socket)

import Control.Concurrent (forkIO)
import Control.Exception (finally)

import System.IO (Handle, hPutStr, hClose, hGetLine, hGetContents)

import qualified Data.Char as Char
import Numeric (showHex)


type Server = () -- later, we might have a handle for shutting down a server.

{- |
This server transfers documents as one parcel, using the content-length header.
-}

initServer
   :: Int 			-- ^ The port number
   -> (Request -> IO Response) 	-- ^ The functionality of the Server
   -> IO Server			-- ^ A token for the Server
initServer port =
  initServerMain
     (\body -> ([("Content-Length", show (length body))], body))
     (SockAddrInet (fromIntegral port) iNADDR_ANY)

{- |
This server transfers documents in chunked mode
and without content-length header.
This way you can ship infinitely big documents.
It inserts the transfer encoding header for you.
-}
initServerLazy
   :: Int 			-- ^ Chunk size
   -> Int 			-- ^ The port number
   -> (Request -> IO Response) 	-- ^ The functionality of the Server
   -> IO Server			-- ^ A token for the Server
initServerLazy chunkSize port =
  initServerMain
     (\body ->
        ([("Transfer-Encoding", "chunked")],
         foldr ($) "" $
         map
            (\str ->
               showHex (length str) . showCRLF .
               showString str . showCRLF)
            (slice chunkSize body) ++
         -- terminating chunk
         showString "0" . showCRLF :
         -- terminating trailer
         showCRLF :
         []))
     (SockAddrInet (fromIntegral port) iNADDR_ANY)
     
showCRLF :: ShowS
showCRLF = showString "\r\n"

-- cf. Data.List.HT.sliceVertical
slice :: Int -> [a] -> [[a]]
slice n =
  map (take n) . takeWhile (not . null) . iterate (drop n)

{- |
This server transfers documents as one parcel, using the content-length header,
and takes an additional 
-}
initServerBind
   :: Int                               -- ^ The port number
   -> Socket.HostAddress                -- ^ The host address
   -> (Request -> IO Response)          -- ^ The functionality of the Server
   -> IO Server                         -- ^ A token for the Server
initServerBind port addr =
  initServerMain
      (\body -> ([("Content-Length", show (length body))], body)) 
      (SockAddrInet (fromIntegral port) addr)


initServerMain
   :: (String -> ([(String, String)], String))
   -> SockAddr
   -> (Request -> IO Response)
   -> IO Server
initServerMain processBody sockAddr callOut = do
--        installHandler sigPIPE Ignore Nothing    
--        sock  <- listenOn (PortNumber $ fromIntegral portNo)
        num <- getProtocolNumber "tcp"
        sock <- socket Socket.AF_INET Socket.Stream num
        setSocketOption sock Socket.ReuseAddr 1
        bindSocket sock sockAddr
        Socket.listen sock Socket.maxListenQueue

        loopIO  
           (do (h,_nm,_port) <- Network.accept sock
               forkIO $ do 
                 ln <- hGetLine h
                 case words ln of
                   [mode,uri,"HTTP/1.1"] ->
                       case parseURIReference uri of
                         Just uri' -> readHeaders h mode uri' [] Nothing
                         _ -> do print uri 
                                 hClose h
                   _                      -> hClose h
                 return ()
           ) `finally` Socket.sClose sock
  where 
      loopIO m = m >> loopIO m

      readHeaders h mode uri hds clen = do
        line <- hGetLine h
        case span (/= ':') line of
          ("\r","") -> sendRequest h mode uri hds clen
          (name@"Content-Length",':':rest) ->
            readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)]) (Just (read rest))
          (name,':':rest) -> readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)]) clen
          _ -> hClose h	-- strange format

      message code = show code ++ " " ++ 
                     case lookup code longMessages of
                       Just msg -> msg
                       Nothing -> "-"
      sendRequest h mode uri hds clen = do
          reqBody' <- case clen of
            Just l -> fmap (take l) (hGetContents h)
            Nothing -> return ""
          resp <- callOut $ Request { reqMethod = mode
                                    , reqURI    = uri
                                    , reqHeaders = hds
                                    , reqBody   = reqBody'
                                    } 
          let (additionalHeaders, body) =
                processBody $ resBody resp
          writeLines h $
            ("HTTP/1.1 " ++ message (resCode resp)) :
            ("Connection: close") :
            (map (\(hdr,val) -> hdr ++ ": " ++ val) $
                resHeaders resp ++ additionalHeaders) ++
            "" :
            []
          hPutStr h body
          hClose h

writeLines :: Handle -> [String] -> IO ()
writeLines h =
  hPutStr h . concatMap (++"\r\n")

-- | Takes an escaped query, optionally starting with '?', and returns an unescaped index-value list.
queryToArguments :: String -> [(String,String)]
queryToArguments ('?':rest) = queryToArguments rest
queryToArguments input = findIx input
   where
     findIx = findIx' . span (/= '=') 
     findIx' (index,'=':rest) = findVal (unEscapeString index) rest
     findIx' _ = []

     findVal index = findVal' index . span (/= '&')
     findVal' index (value,'&':rest) = (index,unEscapeString value) : findIx rest
     findVal' index (value,[])       = [(index,unEscapeString value)]
     findVal' _ _ = []

data Request = Request 
     { reqMethod  :: String	
     , reqURI     :: URI
     , reqHeaders :: [(String,String)]
     , reqBody    :: String
     }
     deriving Show

data Response = Response
    { resCode	 :: Int
    , resHeaders :: [(String,String)]
    , resBody    :: String
    }
     deriving Show

addCache :: Int -> (String,String)
addCache n = ("Cache-Control","max-age=" ++ show n)

noCache :: (String,String)
noCache = ("Cache-Control","no-cache")

-- examples include "text/html" and "text/plain"

contentType :: String -> (String,String)
contentType msg = ("Content-Type",msg)

------------------------------------------------------------------------------
longMessages :: [(Int,String)]
longMessages = 
    [ (200,"OK")
    , (404,"Not Found")
    ]