module Network.Shed.Httpd
( Server
, initServer
, initServerLazy
, Request(..)
, Response(..)
, queryToArguments
, addCache
, noCache
, contentType
) where
import Network.URI
import Network
import System.IO
import Control.Monad
import Control.Concurrent
import Control.Exception as Exc
import qualified Data.List as List
import qualified Data.Char as Char
import Numeric (showHex)
type Server = ()
initServer
:: Int
-> (Request -> IO Response)
-> IO Server
initServer =
initServerMain
(\body -> ([("Content-Length", show (length body))], body))
initServerLazy
:: Int
-> Int
-> (Request -> IO Response)
-> IO Server
initServerLazy chunkSize =
initServerMain
(\body ->
([("Transfer-Encoding", "chunked")],
concatMap (\str -> showHex (length str) $ showString "\r\n" $ str) $
slice chunkSize body ++ [[]]))
slice :: Int -> [a] -> [[a]]
slice n =
map (take n) . takeWhile (not . null) . iterate (drop n)
initServerMain
:: (String -> ([(String, String)], String))
-> Int
-> (Request -> IO Response)
-> IO Server
initServerMain processBody portNo callOut = do
sock <- listenOn (PortNumber $ fromIntegral portNo)
loopIO
(do (h,_nm,_port) <- 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' []
_ -> do print uri
hClose h
_ -> hClose h
return ()
) `finally` sClose sock
where
loopIO m = do m
loopIO m
readHeaders h mode uri hds = do
line <- hGetLine h
case span (/= ':') line of
("\r","") -> sendRequest h mode uri hds
(name,':':rest) -> readHeaders h mode uri (hds ++ [(name,dropWhile Char.isSpace rest)])
_ -> hClose h
message code = show code ++ " " ++
case lookup code longMessages of
Just msg -> msg
Nothing -> "-"
sendRequest h mode uri hds = do
resp <- callOut $ Request { reqMethod = mode
, reqURI = uri
, reqHeaders = hds
, 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")
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")
contentType :: String -> (String,String)
contentType msg = ("Content-Type",msg)
longMessages :: [(Int,String)]
longMessages =
[ (200,"OK")
, (404,"Not Found")
]