module Network.Shed.Httpd
( Server
, initServer
, initServerLazy
, initServerBind
, 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)
import qualified Network as N
import Network.BSD
import Network.Socket
type Server = ()
initServer
:: Int
-> (Request -> IO Response)
-> IO Server
initServer port =
initServerMain
(\body -> ([("Content-Length", show (length body))], body))
(SockAddrInet (fromIntegral port) iNADDR_ANY)
initServerLazy
:: Int
-> Int
-> (Request -> IO Response)
-> IO Server
initServerLazy chunkSize port =
initServerMain
(\body ->
([("Transfer-Encoding", "chunked")],
foldr ($) "" $
map
(\str ->
showHex (length str) . showCRLF .
showString str . showCRLF)
(slice chunkSize body) ++
showString "0" . showCRLF :
showCRLF :
[]))
(SockAddrInet (fromIntegral port) iNADDR_ANY)
showCRLF :: ShowS
showCRLF = showString "\r\n"
slice :: Int -> [a] -> [[a]]
slice n =
map (take n) . takeWhile (not . null) . iterate (drop n)
initServerBind
:: Int
-> HostAddress
-> (Request -> IO Response)
-> IO 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
num <- getProtocolNumber "tcp"
sock <- socket AF_INET Stream num
setSocketOption sock ReuseAddr 1
bindSocket sock sockAddr
listen sock maxListenQueue
loopIO
(do (h,_nm,_port) <- N.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` sClose sock
where
loopIO m = do 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
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")
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")
]