module Network.MiniHTTP.Server
(
Source
, SourceResult(..)
, bsSource
, hSource
, nullSource
, WebMonad
, WebState
, getRequest
, getReply
, setReply
, setHeader
, handleConditionalRequest
, handleHandleToSource
, handleRangeRequests
, handleDecoration
, handleFromFilesystem
, serve
) where
import Prelude hiding (foldl, elem, catch)
import Control.Concurrent.STM
import Control.Monad (liftM)
import Control.Monad.State.Strict
import Control.Exception (catch)
import Data.Foldable
import Data.Word (Word16)
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
import Data.Maybe (isNothing, isJust, fromJust, catMaybes, maybe)
import Data.Time.Clock.POSIX
import Data.IORef
import Data.Int (Int64)
import qualified Data.ByteString as B
import Data.ByteString.Internal (w2c, c2w)
import Data.ByteString.Char8 ()
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import System.IO
import System.Posix
import System.FilePath (combine, splitDirectories, joinPath, takeExtension)
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
import Text.Printf (printf)
import qualified Data.Binary.Put as P
import qualified Data.Binary.Strict.IncrementalGet as IG
import Network.MiniHTTP.Marshal
import qualified Network.MiniHTTP.Connection as C
import Network.MiniHTTP.MimeTypesParse
htons :: Word16 -> Word16
htons x = ((x .&. 255) `shiftL` 8) .|. (x `shiftR` 8)
type Source = IO SourceResult
data SourceResult = SourceError
| SourceEOF
| SourceData B.ByteString
deriving (Show)
bsSource :: B.ByteString -> IO Source
bsSource bs = do
ref <- newIORef $ SourceData bs
return $ do
v <- readIORef ref
writeIORef ref SourceEOF
return v
hSource :: (Int64, Int64)
-> Handle
-> IO Source
hSource (from, to) handle = do
bytesSoFar <- newIORef (from :: Int64)
hSeek handle AbsoluteSeek (fromIntegral from)
return $ do
catch
(do done <- readIORef bytesSoFar
bytes <- B.hGet handle $ min (128 * 1024) (fromIntegral $ (to + 1) done)
if B.length bytes == 0
then do
if to + 1 == done
then return SourceEOF
else return SourceError
else do modifyIORef bytesSoFar ((+) (fromIntegral $ B.length bytes))
return $ SourceData bytes)
(const $ return SourceError)
nullSource :: Source
nullSource = return SourceEOF
data WebState =
WebState { wsRequest :: Request
, 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
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 } }
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 = reqUrl req
path' = B.takeWhile (/= 0) path
path'' = map w2c $ B.unpack path'
elems = splitDirectories path''
elems' = filter (\x -> x /= ".." && x /= "/") elems
ext = takeExtension path''
filepath = combine docroot $ joinPath elems'
mimeTypes <- get >>= return . wsMimeTypes
s <- get
s' <- 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 $ 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 $ s { wsReply = Reply 1 1 404 "Not found" $ emptyHeaders })
put s'
pipeline :: Map.Map B.ByteString MediaType
-> WebMonad ()
-> Request
-> IO (Reply, Source)
pipeline mimetypes action req = do
let initState = (WebState req mimetypes (Reply 1 1 500 "Server error" emptyHeaders)
Nothing Nothing Nothing)
(_, s) <- runStateT (do
action
handleFinal) initState
return (wsReply s, fromJust $ wsSource s)
waitForLowWaterAndEnqueue :: Int
-> C.Connection
-> B.ByteString
-> IO ()
waitForLowWaterAndEnqueue lw conn bs = do
atomically $ do
q <- readTVar $ C.connoutq conn
let size = foldl (\sz bs -> sz + B.length bs) 0 q
if size > lw
then retry
else writeTVar (C.connoutq conn) $ bs Seq.<| q
readRequest :: Socket
-> B.ByteString
-> IO (B.ByteString, Request)
readRequest socket initbs = do
let f result = do
case result of
IG.Failed _ -> fail "Parse failed"
IG.Partial cont -> recv socket 256 >>= (\x -> (f $ cont x))
IG.Finished rest result -> return (rest, result)
f $ IG.runGet parseRequest initbs
readRequests :: (Request -> IO (Reply, IO SourceResult))
-> C.Connection
-> B.ByteString
-> IO ()
readRequests handler conn initbs = do
(rest, result) <- readRequest (C.connsocket conn) initbs
(reply, source) <- handler result
let lowWater = 32 * 1024
stream = do
next <- source
case next of
SourceEOF -> return True
SourceError -> return False
SourceData bs -> waitForLowWaterAndEnqueue lowWater conn bs >> stream
streamChunked = do
next <- source
case next of
SourceEOF -> do
waitForLowWaterAndEnqueue lowWater conn "0\r\n\r\n"
return True
SourceError -> return False
SourceData bs -> do
waitForLowWaterAndEnqueue lowWater conn $ B.pack $ map c2w $
printf "%d\r\n\r\n" $ B.length bs
waitForLowWaterAndEnqueue lowWater conn bs
waitForLowWaterAndEnqueue lowWater conn "\r\n"
streamChunked
waitForLowWaterAndEnqueue (32 * 1024) conn $ B.concat $ BL.toChunks $ P.runPut $ putReply reply
success <- if isNothing $ httpContentLength $ replyHeaders reply
then streamChunked
else stream
if not success
then C.close conn
else readRequests handler conn rest
acceptLoop :: Socket -> (Request -> IO (Reply, Source)) -> IO ()
acceptLoop acceptingSocket handler = do
(newsock, addr) <- accept acceptingSocket
setSocketOption newsock NoDelay 1
putStrLn $ "Connection from " ++ show addr
c <- atomically $ C.new newsock (return ())
C.forkThreads c $ readRequests handler c B.empty
acceptLoop acceptingSocket handler
serve :: Int
-> WebMonad ()
-> IO ()
serve portno action = do
acceptingSocket <- socket AF_INET Stream 0
let sockaddr = SockAddrInet (PortNum $ htons $ fromIntegral portno) iNADDR_ANY
setSocketOption acceptingSocket ReuseAddr 1
bindSocket acceptingSocket sockaddr
listen acceptingSocket 1
mimetypes <- parseMimeTypesTotal "/etc/mime.types" >>= return . maybe Map.empty id
catch (acceptLoop acceptingSocket $ pipeline mimetypes action)
(const $ sClose acceptingSocket)