module Network.MiniHTTP.Server
(
WebMonad
, WebState(..)
, getRequest
, getPayload
, getPOST
, getGET
, getReply
, setReply
, setHeader
, setCookie
, errorPage
, handleConditionalRequest
, handleHandleToSource
, handleRangeRequests
, handleDecoration
, handleFromFilesystem
, serveHTTP
, serveHTTPS
, DispatchMatch(..)
, dispatchOnURL
) where
import Prelude hiding (foldl, catch)
import Control.Concurrent.STM
import Control.Exception (catch)
import Control.Monad.State.Strict
import qualified Data.Binary.Put as P
import qualified Data.ByteString as B
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Internal (c2w, w2c)
import Data.Char (chr)
import Data.Int (Int64)
import qualified Data.Map as Map
import Data.Maybe (isNothing, isJust, fromJust, catMaybes, maybe)
import Data.String (fromString)
import Data.Time.Clock.POSIX
import System.FilePath (combine, splitDirectories, joinPath, takeExtension)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import System.Posix
import qualified System.Posix.Signals as Signal
import qualified OpenSSL.Session as SSL
import qualified Network.Connection as C
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.MiniHTTP.Marshal
import Network.MiniHTTP.MimeTypesParse
import Network.MiniHTTP.HTTPConnection
import qualified Network.MiniHTTP.URL as URL
data WebState =
WebState { wsRequest :: Request
, wsBody :: Maybe Source
, wsMimeTypes :: Map.Map B.ByteString MediaType
, wsReply :: Reply
, wsSource :: Maybe Source
, wsHandle :: Maybe Handle
, wsAction :: Maybe (IO ())
}
type WebMonad = StateT WebState IO
getRequest :: WebMonad Request
getRequest = get >>= return . wsRequest
getReply :: WebMonad Reply
getReply = get >>= return . wsReply
getPayload :: WebMonad (Maybe Source)
getPayload = get >>= return . wsBody
getPOST :: Int
-> WebMonad (Map.Map B.ByteString B.ByteString)
getPOST maxBytes = do
msource <- getPayload
maybe (return Map.empty) (\source -> do
mbs <- liftIO $ sourceToBS maxBytes source
maybe (return Map.empty) (\bs -> do
maybe (return Map.empty) return $ URL.parseArguments bs) mbs) msource
getGET :: WebMonad (Map.Map B.ByteString B.ByteString)
getGET = liftM (URL.rurlArguments . reqUrl) getRequest
setReply :: Int -> WebMonad ()
setReply code = do
s <- get
put $ s { wsAction = Nothing, wsSource = Nothing, wsHandle = Nothing,
wsReply = Reply 1 1 code (statusToMessage code) $
emptyHeaders {httpContentLength = Just 0} }
setHeader :: (Headers -> Headers) -> WebMonad ()
setHeader f = do
reply <- getReply
let h = replyHeaders reply
s <- get
put $ s { wsReply = reply { replyHeaders = f h } }
setCookie :: Cookie -> WebMonad ()
setCookie newcookie@(Cookie { cookieName = n }) = do
reply <- getReply
let h = replyHeaders reply
sets = httpSetCookie h
sets' = if any (\cookie -> cookieName cookie == n) sets
then map (\cookie -> if cookieName cookie == n then newcookie else cookie) sets
else newcookie : sets
s <- get
put $ s { wsReply = reply { replyHeaders = h { httpSetCookie = sets' } } }
handleConditionalRequest :: WebMonad ()
handleConditionalRequest = do
req <- getRequest
reply <- getReply
let metag = httpETag $ replyHeaders reply
mmtime = httpLastModified $ replyHeaders reply
case httpIfMatch $ reqHeaders req of
Just (Left ()) -> when (isNothing $ metag) $ setReply 412
Just (Right tags) ->
case metag of
Nothing -> setReply 412
Just (False, etag) -> when (not $ elem etag tags) $ setReply 412
Just (True, _) -> setReply 412
Nothing -> return ()
case httpIfNoneMatch $ reqHeaders req of
Just (Left ()) -> when (isJust $ metag) $ setReply 412
Just (Right tags) ->
case metag of
Nothing -> return ()
Just tag -> when (elem tag tags) $ setReply 412
Nothing -> return ()
case httpIfModifiedSince $ reqHeaders req of
Just rmtime -> case mmtime of
Just mtime -> when (mtime <= rmtime) $ setReply 304
Nothing -> return ()
Nothing -> return ()
case httpIfUnmodifiedSince $ reqHeaders req of
Just rmtime -> case mmtime of
Just mtime -> when (rmtime <= mtime) $ setReply 412
Nothing -> return ()
Nothing -> return ()
handleHandleToSource :: WebMonad ()
handleHandleToSource = do
reply <- getReply
mhandle <- liftM wsHandle get
case mhandle of
Just handle -> do
source <- lift $ hSource (0, (fromJust $ httpContentLength $ replyHeaders reply) 1) handle
get >>= \s -> put $ s { wsHandle = Nothing, wsSource = Just source }
Nothing -> return ()
satisfiableRanges :: Int64 -> [Range] -> [Range]
satisfiableRanges contentLength = catMaybes . map f where
f (RangeFrom a)
| a < contentLength = Just $ RangeOf a $ contentLength 1
| otherwise = Nothing
f (RangeOf a b)
| a < contentLength = Just $ RangeOf a $ min b contentLength
| otherwise = Nothing
f (RangeSuffix a)
| a > 0 && contentLength > 0 = Just $ RangeOf (contentLength a) (contentLength 1)
| otherwise = Nothing
handleRangeRequests :: WebMonad ()
handleRangeRequests = do
mhandle <- get >>= return . wsHandle
req <- getRequest
reply <- getReply
case mhandle of
Nothing -> return ()
Just handle ->
case httpContentLength $ replyHeaders reply of
Nothing -> handleHandleToSource
Just contentLength -> do
setHeader (\h -> h { httpAcceptRanges = True })
case httpRange $ reqHeaders req of
Nothing -> handleHandleToSource
Just ranges -> do
let ranges' = satisfiableRanges contentLength ranges
case ranges' of
[] -> do
setReply 416
setHeader (\h -> h { httpContentRange = Just (Nothing, Just contentLength) })
[RangeOf a b] -> do
s <- get
source <- lift $ hSource (a, b) handle
put $ s { wsReply = (wsReply s) { replyStatus = 206
, replyMessage = "Partial Content" }
, wsHandle = Nothing
, wsSource = Just source }
setHeader (\h -> h { httpContentRange = Just (Just (a, b), Just contentLength)})
setHeader (\h -> h { httpContentLength = Just ((b a) + 1)})
_ -> return ()
handleDecoration :: WebMonad ()
handleDecoration = setHeader (\h -> h { httpServer = Just "Network.MiniHTTP" })
handleFinal :: StateT WebState IO ()
handleFinal = do
s <- get
case wsSource s of
Nothing -> do setHeader (\h -> h { httpContentLength = Just 0 })
s <- get
put $ s { wsSource = Just nullSource }
_ -> return ()
s <- get
req <- getRequest
if reqMethod req == HEAD
then do
setHeader $ \h -> h { httpContentLength = Just 0
, httpTransferEncoding = [] }
put $ s { wsSource = Just nullSource }
else return ()
handleFromFilesystem :: FilePath
-> WebMonad ()
handleFromFilesystem docroot = do
req <- getRequest
when (not $ reqMethod req `elem` [GET, HEAD]) $
fail "Can only handle GET and HEAD from the filesystem"
let path = map w2c $ B.unpack $ URL.rurlPath $ reqUrl req
path' = takeWhile (/= chr 0) path
elems = splitDirectories path'
elems' = filter (\x -> x /= ".." && x /= "/") elems
ext = takeExtension path'
filepath = combine docroot $ joinPath elems'
mimeTypes <- get >>= return . wsMimeTypes
s <- get
r <- lift $ catch
(do fd <- openFd filepath ReadOnly Nothing (OpenFileFlags False False True False False)
stat <- getFdStatus fd
let size = fromIntegral $ fileSize stat
mtime = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
handle <- fdToHandle fd
return $ Just $
s { wsHandle = Just handle
, wsSource = Nothing
, wsReply = Reply 1 1 200 "Ok" $ emptyHeaders
{ httpLastModified = Just mtime
, httpContentLength = Just size
, httpContentType = Map.lookup (B.pack $ map c2w ext) mimeTypes } } )
(const $ return Nothing)
case r of
Just x -> put x
Nothing -> errorPage "File not found"
pipeline :: Map.Map B.ByteString MediaType
-> WebMonad ()
-> Request
-> Maybe Source
-> IO (Reply, Source)
pipeline mimetypes action req msource = do
let initState = (WebState req msource mimetypes (Reply 1 1 500 "Server error" emptyHeaders)
Nothing Nothing Nothing)
(_, s) <- catch (
runStateT (do
action
handleFinal) initState)
(\e -> runStateT (do
errorPage $ show e
handleFinal) initState)
return (wsReply s, fromJust $ wsSource s)
readRequest :: C.Connection
-> IO Request
readRequest conn = readIG conn 256 4096 parseRequest >>= return . fromJust
readRequests :: (Request -> Maybe Source -> IO (Reply, IO SourceResult))
-> C.Connection
-> IO ()
readRequests handler conn = do
result <- readRequest conn
body <-
case httpContentLength $ reqHeaders result of
Nothing -> return Nothing
Just n -> connSource n B.empty conn >>= return . Just
(reply, source) <- handler result body
let lowWater = 32 * 1024
atomically $ C.writeAtLowWater lowWater conn $ B.concat $ BL.toChunks $ P.runPut $ putReply reply
success <- if isNothing $ httpContentLength $ replyHeaders reply
then streamSourceChunked lowWater conn source
else streamSource lowWater conn source
if not success
then C.close conn
else do case body of
Nothing -> return ()
Just source -> sourceDrain source
readRequests handler conn
sslHandshake :: SSL.SSL -> IO () -> IO ()
sslHandshake ssl k = SSL.accept ssl >> k
acceptLoop :: (Request -> Maybe Source -> IO (Reply, Source)) -> Socket -> IO ()
acceptLoop handler acceptingSocket = do
(newsock, addr) <- accept acceptingSocket
setSocketOption newsock NoDelay 1
putStrLn $ "Connection from " ++ show addr
c <- C.new (return ()) $ C.baseConnectionFromSocket newsock
C.forkInConnection c $ readRequests handler c
acceptLoop handler acceptingSocket
acceptLoopHTTPS :: SSL.SSLContext
-> (Request -> Maybe Source -> IO (Reply, Source))
-> Socket
-> IO ()
acceptLoopHTTPS ctx handler acceptingSocket = do
(newsock, addr) <- accept acceptingSocket
setSocketOption newsock NoDelay 1
putStrLn $ "Connection from " ++ show addr
ssl <- SSL.connection ctx newsock
c <- C.new (return ()) $ sslToBaseConnection ssl
C.forkInConnection c $ sslHandshake ssl $ readRequests handler c
acceptLoopHTTPS ctx handler acceptingSocket
errorPage :: String -> WebMonad ()
errorPage error = (do
s <- get
source <- liftIO $ bsSource message
put $ s { wsSource = Just source }
setHeader $ \h -> h { httpContentLength = Just $ fromIntegral $ B.length message }
handleDecoration) where
message = head `B.append` errorbs `B.append` tail
head = "<html> <head> <title>Network.MiniHTTP error page</title> <style language=\"text/css\"> #top { height: 1.5em; width: 100%; background-color: #BFD9FF; border-bottom: 3px solid #004FBF; margin-bottom: 2em; padding-left: 1em; font-variant: small-caps; font-size: 2em; padding-top: 0.5em; } body { margin: 0 0 0 0; } #main { margin-left: 4px; } .enbox { padding-left: 2em; background-color: \"#003786\" } h4 { color: #004FBF; } </style> </head> <body> <div id=\"top\">Network.MiniHTTP</div> <div id=\"main\"> <h4>An error occured while processing your request:</h4> <pre class=\"enbox\">"
tail = "</pre> </div> </body> </html>"
errorbs = fromString $ concatMap escape error
escape '<' = "<"
escape '&' = "&"
escape '>' = ">"
escape x = [x]
data DispatchMatch = Exact B.ByteString
| Prefix B.ByteString
deriving (Show, Eq)
dispatchMatch :: B.ByteString -> DispatchMatch -> Bool
dispatchMatch b (Exact m) = b == m
dispatchMatch b (Prefix p) = p `B.isPrefixOf` b
dispatchOnURL :: [(DispatchMatch, WebMonad ())]
-> WebMonad ()
dispatchOnURL paths = do
req <- getRequest
let path = URL.rurlPath $ reqUrl req
case map snd $ filter (dispatchMatch path . fst) paths of
[] -> errorPage "No dispatchers matched requested URL"
x:_ -> x
globalMimeTypes :: Map.Map B.ByteString MediaType
globalMimeTypes = unsafePerformIO $
parseMimeTypesTotal "/etc/mime.types" >>= return . maybe Map.empty id
serve :: Int
-> (Socket -> IO ())
-> IO ()
serve portno acceptLoop = do
acceptingSocket <- socket AF_INET Stream 0
let sockaddr = SockAddrInet (fromIntegral portno) iNADDR_ANY
setSocketOption acceptingSocket ReuseAddr 1
bindSocket acceptingSocket sockaddr
listen acceptingSocket 1
Signal.installHandler Signal.sigPIPE Signal.Ignore Nothing
catch (acceptLoop acceptingSocket)
(const $ sClose acceptingSocket)
serveHTTP :: Int
-> WebMonad ()
-> IO ()
serveHTTP portno action = do
serve portno $ acceptLoop $ pipeline globalMimeTypes action
serveHTTPS :: Int
-> FilePath
-> FilePath
-> WebMonad ()
-> IO ()
serveHTTPS portno public private action = do
ctx <- SSL.context
SSL.contextSetPrivateKeyFile ctx private
SSL.contextSetCertificateFile ctx public
SSL.contextSetDefaultCiphers ctx
goodp <- SSL.contextCheckPrivateKey ctx
when (not goodp) $ fail "Public/private key mismatch"
serve portno $ acceptLoopHTTPS ctx $ pipeline globalMimeTypes action