network-minihttp (empty) → 0.1
raw patch · 8 files changed
+1416/−0 lines, 8 filesdep +basedep +binarydep +binary-strictbuild-type:Customsetup-changed
Dependencies added: base, binary, binary-strict, bytestring, containers, filepath, mtl, network, network-bytestring, old-locale, stm, time, unix
Files
- LICENSE +30/−0
- Network/MiniHTTP/Connection.hs +120/−0
- Network/MiniHTTP/Marshal.hs +735/−0
- Network/MiniHTTP/MimeTypesParse.hs +61/−0
- Network/MiniHTTP/Server.hs +429/−0
- Setup.lhs +3/−0
- examples/fileserver.hs +20/−0
- network-minihttp.cabal +18/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Adam Langley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/MiniHTTP/Connection.hs view
@@ -0,0 +1,120 @@+module Network.MiniHTTP.Connection+ ( Connection+ , new+ , forkThreads+ , close+ , connoutq+ , connsocket+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad++import Data.Maybe (fromJust)+import qualified Data.ByteString as BS+import qualified Data.Sequence as Seq++import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString++data Connection = Connection { connsocket :: Socket+ , connoutq :: TVar (Seq.Seq BS.ByteString)+ , connreaderthread :: TVar (Maybe ThreadId)+ , connwriterthread :: TVar (Maybe ThreadId)+ , conndeath :: IO ()+ , conndead :: TVar Bool }++-- Threading: each connection has two threads: one pumping data out and one+-- reading it in. The failure (by throwing an exception) of either is enough+-- to close the socket and kill the connection. This could happen to both at+-- the same time, in which case they race to set conndead to True.+-- However, we also need to record their ThreadIds in the Connection record+-- so that they can kill each other. It's possible that they could try to+-- kill the connection right away - before the creating thread has recorded+-- the correct ThreadIds in the Connection. Thus, at startup, they both wait+-- for the controlling thread to set conndead to False before doing anything+-- else++new :: Socket -- ^ the socket to make a connection from+ -> IO () -- ^ the action run when the connection fails+ -> STM Connection+new socket deathaction = do+ dead <- newTVar True+ outq <- newTVar Seq.empty+ p1 <- newTVar Nothing+ p2 <- newTVar Nothing++ let conn = Connection socket outq p1 p2 deathaction dead+ return conn++forkThreads :: Connection -- ^ the connection to fork the threads for+ -> IO () -- ^ the action which reads from the socket+ -> IO ()+forkThreads conn readeraction = do+ reader <- forkIO $ waitForReadySignal conn $+ connectionThreadWrapper conn connwriterthread $+ readeraction+ writer <- forkIO $ waitForReadySignal conn $+ connectionThreadWrapper conn connreaderthread $+ seqToSocket (connoutq conn) (connsocket conn)+ -- update the thread ids in the Connection and set the ready flag+ atomically (writeTVar (connreaderthread conn) (Just reader) >>+ writeTVar (connwriterthread conn) (Just writer) >>+ writeTVar (conndead conn) False)+ return ()++-- | Wait for conndead to be set to False on the given connection, then run+-- the given action+waitForReadySignal :: Connection -> IO a -> IO a+waitForReadySignal conn action = do+ atomically (do dead <- readTVar (conndead conn)+ if dead == True then retry else return ())+ action++-- | Wrap a connection thread so that, when the thread dies, it races to set+-- the dead flag. If it does so, it closes the socket and kills the other+-- thread+connectionThreadWrapper :: Connection -> (Connection -> TVar (Maybe ThreadId)) -> IO a -> IO a+connectionThreadWrapper conn otherthread action = do+ finally action+ (do isDead <- atomically (do dead <- readTVar (conndead conn)+ when (not dead) $ writeTVar (conndead conn) True+ return dead)+ when (not isDead) (do t <- atomically (readTVar $ otherthread conn)+ killThread $ fromJust t+ sClose (connsocket conn)+ conndeath conn))++-- | Close a connection+close :: Connection -> IO ()+close = sClose . connsocket++-- | Atomically take elements from the end of the given sequence and write them+-- to the given socket. Throw an exception when the write fails+seqToSocket :: TVar (Seq.Seq BS.ByteString) -- ^ data is removed from the end+ -> Socket -- ^ the socket to write to+ -> IO ()+seqToSocket q sock = do+ -- Atomically remove an element from the end of the sequence+ bs <- atomically (do q' <- readTVar q+ (bs, rest) <-+ case Seq.viewr q' of+ Seq.EmptyR -> retry+ rest Seq.:> head -> return (head, rest)+ writeTVar q rest+ return bs)+ -- Write the data to the socket+ writea sock bs+ seqToSocket q sock++-- | Write a given number of bytes to a socket.+writea :: Socket -> BS.ByteString -> IO ()+writea sock bytes+ | BS.null bytes = return ()+ | otherwise = do+ n <- send sock bytes+ if n == BS.length bytes+ then return ()+ else writea sock $ BS.drop n bytes
+ Network/MiniHTTP/Marshal.hs view
@@ -0,0 +1,735 @@+{-# OPTIONS_GHC -fno-monomorphism-restriction+ -fno-warn-missing-signatures #-}+-- | This module serialises and deserialises HTTP headers. It contains Haskell+-- representations of request and replies and can transform them to, and from,+-- the HTTP wire format.+module Network.MiniHTTP.Marshal+ ( Request(..)+ , Reply(..)+ , Range(..)+ , Headers(..)+ , emptyHeaders+ , statusToMessage+ , Method(..)+ , MediaType+ , putRequest+ , putReply+ , parseRequest+ , parseReply+ ) where++import Prelude hiding (putChar)+import Control.Monad (when)+import GHC.Exts()+import Data.Time (UTCTime(..))+import Data.Time.Format (formatTime)+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime)+import Data.Int (Int64)+import Data.Maybe (isJust, maybe)+import Data.List (foldl')+import System.Locale (TimeLocale(..))+import qualified Data.Map as Map+import Control.Applicative ((<|>), liftA, liftA2, (*>))+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Binary.Put as P+import qualified Data.Binary.Strict.Get as G+import qualified Data.Binary.Strict.Class as C+import qualified Data.Binary.Strict.ByteSet as BSet++import Debug.Trace (trace)++debug x = trace (show x) x++-- | A HTTP request+data Request =+ Request { reqMethod :: Method+ , reqUrl :: B.ByteString+ , reqMajor :: Int+ , reqMinor :: Int+ , reqHeaders :: Headers+ } deriving (Show)++-- | A HTTP reply+data Reply =+ Reply { replyMajor :: Int+ , replyMinor :: Int+ , replyStatus :: Int+ , replyMessage :: String+ , replyHeaders :: Headers+ } deriving (Show)++-- | A HTTP range+data Range = RangeFrom Int64 -- ^ everything from the given byte onwards+ | RangeOf Int64 Int64 -- ^ the bytes in the given range, inclusive+ | RangeSuffix Int64 -- ^ the final n bytes+ deriving (Show)++-- | HTTP headers, see RFC 2616 section 14+data Headers =+ Headers { httpAccept :: Maybe [(MediaType, Int)]+ , httpAcceptCharset :: Maybe [(String, Int)]+ , httpAcceptEncoding :: Maybe [(String, Int)]+ , httpAcceptLanguage :: Maybe [(String, Int)]+ , httpAcceptRanges :: Bool+ , httpAge :: Maybe Int64+ , httpAllow :: Maybe [Method]+ , httpAuthorization :: Maybe B.ByteString+ , httpConnectionClose :: Bool+ , httpConnection :: [String]+ , httpContentEncodings :: [String]+ , httpContentLanguage :: Maybe [String]+ , httpContentLength :: Maybe Int64+ , httpContentLocation :: Maybe B.ByteString+ , httpContentRange :: Maybe (Maybe (Int64, Int64), Maybe Int64)+ , httpContentType :: Maybe MediaType+ , httpDate :: Maybe UTCTime+ , httpETag :: Maybe (Bool, B.ByteString)+ , httpExpires :: Maybe UTCTime+ , httpHost :: Maybe B.ByteString+ , httpIfMatch :: Maybe (Either () [B.ByteString])+ , httpIfModifiedSince :: Maybe UTCTime+ , httpIfNoneMatch :: Maybe (Either () [(Bool, B.ByteString)])+ , httpIfRange :: Maybe (Either B.ByteString UTCTime)+ , httpIfUnmodifiedSince :: Maybe UTCTime+ , httpKeepAlive :: Maybe Int+ , httpLastModified :: Maybe UTCTime+ , httpLocation :: Maybe B.ByteString+ , httpPragma :: Maybe [(String, Maybe String)]+ , httpProxyAuthenticate :: Maybe B.ByteString+ , httpProxyAuthorization :: Maybe B.ByteString+ , httpRange :: Maybe [Range]+ , httpReferer :: Maybe B.ByteString+ , httpRetryAfter :: Maybe Int64+ , httpServer :: Maybe B.ByteString+ , httpTrailer :: Maybe [String]+ , httpTransferEncoding :: [String]+ , httpUserAgent :: Maybe B.ByteString+ , httpWWWAuthenticate :: Maybe B.ByteString+ , httpOtherHeaders :: Map.Map B.ByteString B.ByteString+ } deriving (Show)++emptyHeaders :: Headers+emptyHeaders =+ Headers Nothing Nothing Nothing Nothing+ False Nothing Nothing Nothing False [] [] Nothing Nothing+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing+ Nothing [] Nothing Nothing Map.empty++-- | The list of valid methods, see RFC 2616 section 5.1+data Method = OPTIONS+ | GET+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | CONNECT+ deriving (Ord, Enum, Show, Eq)++type MediaType = ((String, String), [(String, String)])++-- | A mapping from status code to message. Taken from Johan Tibell's Hydra+-- package+reasonPhrases :: Map.Map Int String+reasonPhrases = Map.fromList+ [(100, "Continue")+ ,(101, "Switching Protocols")+ ,(200, "OK")+ ,(201, "Created")+ ,(202, "Accepted")+ ,(203, "Non-Authoritative Information")+ ,(204, "No Content")+ ,(205, "Reset Content")+ ,(206, "Partial Content")+ ,(300, "Multiple Choices")+ ,(301, "Moved Permanently")+ ,(302, "Found")+ ,(303, "See Other")+ ,(304, "Not Modified")+ ,(305, "Use Proxy")+ ,(307, "Temporary Redirect")+ ,(400, "Bad Request")+ ,(401, "Unauthorized")+ ,(402, "Payment Required")+ ,(403, "Forbidden")+ ,(404, "Not Found")+ ,(405, "Method Not Allowed")+ ,(406, "Not Acceptable")+ ,(407, "Proxy Authentication Required")+ ,(408, "Request Time-out")+ ,(409, "Conflict")+ ,(410, "Gone")+ ,(411, "Length Required")+ ,(412, "Precondition Failed")+ ,(413, "Request Entity Too Large")+ ,(414, "Request-URI Too Large")+ ,(415, "Unsupported Media Type")+ ,(416, "Requested range not satisfiable")+ ,(417, "Expectation Failed")+ ,(500, "Internal Server Error")+ ,(501, "Not Implemented")+ ,(502, "Bad Gateway")+ ,(503, "Service Unavailable")+ ,(504, "Gateway Time-out")+ ,(505, "HTTP Version not supported")+ ]++-- | Convert a status code to a message (e.g. 200 -> "OK")+statusToMessage :: Int -> String+statusToMessage status = Map.findWithDefault "Unknown" status reasonPhrases++--------------------------------------------------------------------------------+-- These are the byte sets that we'll use for parsing.++char = C.word8 . c2w+urlSet = BSet.full `BSet.difference` (BSet.singleton 0x20)+upAlphas = BSet.range (c2w 'A') (c2w 'Z')+loAlphas = BSet.range (c2w 'a') (c2w 'z')+alphas = upAlphas `BSet.union` loAlphas+digits = BSet.range (c2w '0') (c2w '9')+chars = BSet.range 0 127+ctls = BSet.range 0 31 `BSet.union` BSet.singleton 127+hs = BSet.fromList [32, 9]+texts = (chars `BSet.difference` ctls) `BSet.union` hs+hexes = BSet.range (c2w 'a') (c2w 'f') `BSet.union`+ BSet.range (c2w 'A') (c2w 'F') `BSet.union`+ digits+separators = BSet.fromList $ map c2w "()<>@,;:\\\"/[]?={} \t"+ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\")+qdtexts = texts `BSet.difference` (BSet.fromList $ map c2w "\"\\")++--------------------------------------------------------------------------------+-- Parsing functions++toString = map w2c . B.unpack++lws = do+ C.optional crlf+ C.spanOf1 $ BSet.member hs++token = C.spanOf1 $ BSet.member (texts `BSet.difference` (ctls `BSet.union` separators))+qvalue = qOne <|> qFractional+qOne = do+ char '1'+ (((char '.') >> C.many (char '0') >> return ()) <|> return ())+ return 1000++qFractional = do+ char '0'+ r <- (((char '.') >> C.spanOf (BSet.member digits)) <|> return "")+ if B.null r+ then return 0+ else return $ read $ toString r ++ replicate (3 - B.length r) '0'++comment = do+ char '('+ comment <- C.many ((C.spanOf $ BSet.member ctexts) <|> quotedPair <|> comment) >>= return . B.concat+ char ')'+ return comment++quotedPair = (char '\\') >> (C.getWord8 >>= return . B.singleton)++quotedString = do+ char '"'+ text <- C.many ((C.spanOf1 $ BSet.member qdtexts) <|> quotedPair) >>= return . B.concat+ char '"'+ return text++-- | RFC 2616 2.1, #rule+list p = do+ let f = C.optional lws *> char ',' *> C.optional lws *> p+ v <- p+ rest <- C.many f+ return $ v : rest++crlf = C.word8 13 >> C.word8 10 >> return ()++headerQualityTaggedList parseElement = do+ let acceptParams = do+ char ';'+ C.optional lws+ C.string "q="+ q <- qvalue+ C.many $ acceptExtension+ return q+ acceptExtension = do+ char ';'+ token+ C.optional (char '=' >> (token <|> quotedString))+ listElement = do+ mr <- parseElement+ params <- C.optional acceptParams+ case params of+ Nothing -> return (mr, 1000)+ Just x -> return (mr, x)+ list listElement++stringToken = liftA toString token++mediaType = liftA2 (,) ty params where+ ty = liftA2 (,) stringToken (char '/' *> stringToken)+ params = C.many (char ';' *> (liftA2 (,) notq (char '=' *> (stringToken <|> (liftA toString quotedString)))))+ notq = do+ s <- stringToken+ if s == "q"+ then fail ""+ else return s++-- | Parse an RFC1123 date+date :: (C.BinaryParser m) => m UTCTime+date = do+ C.optional (token *> char ',' *> C.optional lws)+ day <- int64+ lws+ monthstr <- token+ lws+ year <- int64+ lws+ hour <- int64+ char ':'+ min <- int64+ char ':'+ sec <- int64+ lws+ zone <- token++ month <-+ case monthstr of+ "Jan" -> return 1+ "Feb" -> return 2+ "Mar" -> return 3+ "Apr" -> return 4+ "May" -> return 5+ "Jun" -> return 6+ "Jul" -> return 7+ "Aug" -> return 8+ "Sep" -> return 9+ "Oct" -> return 10+ "Nov" -> return 11+ "Dec" -> return 12+ _ -> fail ""+++ (hoffset, moffset) <-+ case zone of+ "UT" -> return (0, 0)+ "UTC" -> return (0, 0)+ "GMT" -> return (0, 0)+ "EST" -> return (-5, 0)+ "EDT" -> return (-4, 0)+ "CST" -> return (-6, 0)+ "CDT" -> return (-5, 0)+ "MST" -> return (-7, 0)+ "MDT" -> return (-6, 0)+ "PST" -> return (-8, 0)+ "PDT" -> return (-7, 0)+ x -> return (sign * hours, sign * mins) where+ (signchar:rest) = toString x+ n = read rest+ (hours, mins) = (n `div` 100, n `mod` 100)+ sign = case signchar of+ '+' -> (-1)+ _ -> 1++ let yday = fromGregorian (fromIntegral year) month (fromIntegral day)+ time = timeOfDayToTime $ TimeOfDay (fromIntegral $ hour + hoffset) (fromIntegral $ min + moffset) (fromIntegral sec)+ utc = UTCTime yday time++ return utc++-- | Parse a zero, or positive, int64+int64 :: (C.BinaryParser c) => c Int64+int64 = C.spanOf1 (BSet.member digits) >>= return . readOrZero . toString++readOrZero "" = 0+readOrZero x = read x++--------------------------------------------------------------------------------+-- Parsing functions for each header type++headerAccept req = do+ accepts <- headerQualityTaggedList mediaType+ return $ req { httpAccept = Just accepts }++headerAcceptCharset req = do+ charsets <- headerQualityTaggedList (token >>= return . toString)+ return $ req { httpAcceptCharset = Just charsets }++headerAcceptEncoding req = do+ encodings <- headerQualityTaggedList (token >>= return . toString)+ return $ req { httpAcceptEncoding = Just encodings }++headerAcceptLanguage req = do+ langs <- headerQualityTaggedList (token >>= return . toString)+ return $ req { httpAcceptLanguage = Just langs }++headerAcceptRanges req = do+ v <- C.optional $ C.string "bytes"+ case v of+ Nothing -> return req+ Just _ -> return $ req { httpAcceptRanges = True }++headerAge req = do+ v <- int64+ return $ req { httpAge = Just v }++headerAllow req = do+ methods <- list (C.spanOf (BSet.member upAlphas) >>= parseMethod)+ return $ req { httpAllow = Just methods }++headerAuth req = do+ remaining <- C.remaining+ d <- C.getByteString remaining+ return $ req { httpAuthorization = Just d }++headerConnection req = do+ tokens <- list (token >>= return . toString)+ return $ req { httpConnection = tokens,+ httpConnectionClose = "close" `elem` tokens }++headerContentEncoding req = do+ tokens <- list (token >>= return . toString)+ return $ req { httpContentEncodings = tokens }++headerContentLanguage req = do+ tokens <- list (token >>= return . toString)+ return $ req { httpContentLanguage = Just tokens }++headerContentLength req = do+ v <- int64+ return $ req { httpContentLength = Just v }++headerContentLocation req = do+ remaining <- C.remaining+ d <- C.getByteString remaining+ return $ req { httpContentLocation = Just d }++headerContentRange req = do+ C.string "bytes "+ a <- (char '*' *> return Nothing) <|> (liftA Just (liftA2 (,) int64 (char '-' *> int64)))+ char '/'+ b <- (char '*' *> return Nothing) <|> (liftA Just int64)+ return $ req { httpContentRange = Just (a, b) }++headerContentType req = do+ ct <- mediaType+ return $ req { httpContentType = Just ct }++etag = do+ weakness <- C.optional $ C.string "W/"+ etag <- quotedString+ return (isJust weakness, etag)++headerETag req = do+ etag >>= \tag -> return $ req { httpETag = Just tag }++headerDate req = date >>= \date -> return $ req { httpDate = Just date }+headerExpires req = date >>= \date -> return $ req { httpExpires = Just date }+headerHost req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpHost = Just x }++headerIfMatch req =+ (char '*' *> return (Left ())) <|> (liftA Right $ list quotedString) >>=+ \a -> return $ req { httpIfMatch = Just a }++headerIfModifiedSince req = date >>= \date -> return $ req { httpIfModifiedSince = Just date }++headerIfNoneMatch req =+ (char '*' *> return (Left ())) <|> (liftA Right $ list etag) >>=+ \a -> return $ req { httpIfNoneMatch = Just a }++headerIfRange req = (liftA Left quotedString) <|> (liftA Right date) >>=+ \a -> return $ req { httpIfRange = Just a }++headerIfUnmodifiedSince req = date >>= \date -> return $ req { httpIfUnmodifiedSince = Just date }+headerKeepAlive req = int64 >>= \v -> return $ req { httpKeepAlive = Just $ fromIntegral v }+headerLastModified req = date >>= \date -> return $ req { httpLastModified = Just date }+headerLocation req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpLocation = Just x }++headerPragma req =+ list (liftA2 (,) stringToken (C.optional $ char '=' *> (liftA toString (token <|> quotedString)))) >>=+ \a -> return $ req { httpPragma = Just a }++headerProxyAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthenticate = Just x }+headerProxyAuthorization req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthorization = Just x }++-- | Check that a list of ranges are syntatically valid+checkRanges :: [Range] -> Maybe [Range]+checkRanges ranges = r where+ r = if any invalid ranges+ then Nothing+ else Just ranges+ invalid (RangeOf a b) = a > b+ invalid _ = False++headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges $ debug a } where+ f = a <|> b <|> c where+ a = char '-' *> liftA RangeSuffix int64+ b = int64 >>= (\start -> char '-' *> liftA (RangeOf start) int64)+ c = int64 >>= (\start -> char '-' *> return (RangeFrom start))++headerReferer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpReferer = Just x }+headerRetryAfter req = int64 >>= \i -> return $ req { httpRetryAfter = Just i }+headerServer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpServer = Just x }+headerTransferEncoding req = list stringToken >>= \xs -> return $ req { httpTransferEncoding = xs }+headerTrailer req = list stringToken >>= \xs -> return $ req { httpTrailer = Just xs }+headerUserAgent req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpUserAgent = Just x }+headerWWWAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpWWWAuthenticate = Just x }++--------------------------------------------------------------------------------+-- Top level parsing functions++messageHeader = do+ name <- token+ char ':'+ C.optional lws+ value <- C.spanOf $ BSet.member texts+ crlf++ return (name, value)++requestLine = do+ method <- C.spanOf $ BSet.member upAlphas+ C.word8 0x20+ url <- C.spanOf $ BSet.member urlSet+ C.word8 0x20+ C.string "HTTP/"+ major <- C.spanOf $ BSet.member digits+ char '.'+ minor <- C.spanOf $ BSet.member digits+ crlf+++ return (method, url, (readOrZero $ toString major) :: Int+ , (readOrZero $ toString minor) :: Int)++replyLine = do+ C.string "HTTP/"+ major <- C.spanOf $ BSet.member digits+ char '.'+ minor <- C.spanOf $ BSet.member digits+ char ' '+ status <- C.spanOf $ BSet.member digits+ char ' '+ message <- C.spanOf $ BSet.member texts+ crlf++ return (readOrZero $ toString major, readOrZero $ toString minor,+ readOrZero $ toString status, toString message)++headerParsers = Map.fromList+ [ ("Accept", headerAccept)+ , ("Accept-Charset", headerAcceptCharset)+ , ("Accept-Encoding", headerAcceptEncoding)+ , ("Accept-Language", headerAcceptLanguage)+ , ("Accept-Ranges", headerAcceptRanges)+ , ("Age", headerAge)+ , ("Allow", headerAllow)+ , ("Authorization", headerAuth)+ , ("Connection", headerConnection )+ , ("Content-Encoding", headerContentEncoding)+ , ("Content-Language", headerContentLanguage)+ , ("Content-Length", headerContentLength)+ , ("Content-Location", headerContentLocation)+ , ("Content-Range", headerContentRange)+ , ("Content-Type", headerContentType)+ , ("ETag", headerETag)+ , ("Date", headerDate)+ , ("Expires", headerExpires)+ , ("Host", headerHost)+ , ("If-Match", headerIfMatch)+ , ("If-Modified-Since", headerIfModifiedSince)+ , ("If-None-Match", headerIfNoneMatch)+ , ("If-Range", headerIfRange)+ , ("If-Unmodified-Since", headerIfUnmodifiedSince)+ , ("Keep-Alive", headerKeepAlive)+ , ("Last-Modified", headerLastModified)+ , ("Location", headerLocation)+ , ("Pragma", headerPragma)+ , ("Proxy-Authenticate", headerProxyAuthenticate)+ , ("Proxy-Authorization", headerProxyAuthorization)+ , ("Range", headerRange)+ , ("Referer", headerReferer)+ , ("Retry-After", headerRetryAfter)+ , ("Server", headerServer)+ , ("Transfer-Encoding", headerTransferEncoding)+ , ("Trailer", headerTrailer)+ , ("User-Agent", headerUserAgent)+ , ("WWW-Authenticate", headerWWWAuthenticate)+ ]++parseMethod :: (Monad m) => B.ByteString -> m Method+parseMethod strmethod =+ case strmethod of+ "OPTIONS" -> return OPTIONS+ "GET" -> return GET+ "HEAD" -> return HEAD+ "POST" -> return POST+ "PUT" -> return PUT+ "DELETE" -> return DELETE+ "TRACE" -> return TRACE+ "CONNECT" -> return CONNECT+ _ -> fail "Bad method"++parseRequest :: (C.BinaryParser m) => m Request+parseRequest = do+ (strmethod, url, major, minor) <- requestLine+ method <- parseMethod strmethod+ headers <- parseHeaders++ return $ Request method url major minor headers++parseReply :: (C.BinaryParser m) => m Reply+parseReply = do+ (major, minor, status, message) <- replyLine+ headers <- parseHeaders++ return $ Reply major minor status message headers++parseHeaders = do+ headers <- C.many $ messageHeader+ crlf++ let req = emptyHeaders+ req' = foldl' tryHeader req headers+ tryHeader req (header, value) =+ case Map.lookup header headerParsers of+ Nothing -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }+ Just p -> case G.runGet (p req) value of+ (Left _, _) -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }+ (Right req', _) -> req'++ return req'++--------------------------------------------------------------------------------+-- Serialisation functions++putString = P.putByteString . B.pack . map c2w+putChar = P.putWord8 . c2w++putShow = putString . show++putQualityList :: (a -> P.Put) -> [(a, Int)] -> P.Put+putQualityList _ [] = return ()+putQualityList f ((v, q):xs) = do+ f v+ when (q /= 1000) $ do+ P.putByteString ";q=0."+ putQuality q+ putChar ','+ putQualityList f xs++putQuality x+ | x `mod` 10 == 0 = putQuality $ div x 10+ | otherwise = putString $ show x++putHeaderM :: Maybe a -> B.ByteString -> (a -> P.Put) -> P.Put+putHeaderM Nothing _ _ = return ()+putHeaderM (Just x) h f = P.putByteString h >> P.putByteString ": " >> f x >> P.putByteString "\r\n"++putHeaderML :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> P.Put+putHeaderML a b c = putHeaderM a b (mapM_ c)++putHeaderL :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put+putHeaderL [] _ _ = return ()+putHeaderL xs h f = P.putByteString h >> P.putByteString ": " >> mapM_ f xs >> P.putByteString "\r\n"++putContentRange (Just (a, b), Just c) = putShow a >> putChar '-' >> putShow b >> putChar '/' >> putShow c+putContentRange (Just (a, b), Nothing) = putShow a >> putChar '-' >> putShow b >> P.putByteString "/*"+putContentRange (Nothing, Just c) = P.putByteString "*/" >> putShow c+putContentRange (Nothing, Nothing) = P.putByteString "*/*"++putList :: Char -> (a -> P.Put) -> [a] -> P.Put+putList _ _ [] = return ()+putList sep f (x:xs) = f x >> mapM_ (\x -> putChar sep >> f x) xs++putMediaType ((ty, subty), opts) = do+ putString ty+ putChar '/'+ putString subty++ let f (a, b) = putChar ';' >> putString a >> putChar '=' >> putString b+ mapM_ f opts++putQuoted :: B.ByteString -> P.Put+putQuoted s = putChar '"' >> f s >> putChar '"' where+ f s+ | B.null s = return ()+ | otherwise = P.putByteString left >> f right where+ (left, right) = B.span (/= (c2w) '"') s++timeLocale = TimeLocale {wDays = [("Sunday","Sun"),("Monday","Mon"),("Tuesday","Tue"),("Wednesday","Wed"),("Thursday","Thu"),("Friday","Fri"),("Saturday","Sat")], months = [("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr"),("May","May"),("June","Jun"),("July","Jul"),("August","Aug"),("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")], intervals = [("year","years"),("month","months"),("day","days"),("hour","hours"),("min","mins"),("sec","secs"),("usec","usecs")], amPm = ("AM","PM"), dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", dateFmt = "%m/%d/%y", timeFmt = "%H:%M:%S", time12Fmt = "%I:%M:%S %p"}++putDate = putString . formatTime timeLocale "%a, %d %b %Y %H:%M:%S GMT"+putETag (weakness, tag) = (if weakness then P.putByteString "W/" else return ()) >> putQuoted tag+putETagList = either (const $ putChar '*') $ putList ',' putQuoted+putWETagList = either (const $ putChar '*') $ putList ',' putETag+putPragma (key, mvalue) = putString key >> maybe (return ()) putString mvalue++putRange (RangeOf a b) = putShow a >> putChar '-' >> putShow b+putRange (RangeSuffix a) = putChar '-' >> putShow a+putRange (RangeFrom a) = putShow a >> putChar '-'++putHeaders :: Headers -> P.Put+putHeaders headers = do+ putHeaderM (httpAccept headers) "Accept" $ putQualityList putMediaType+ putHeaderM (httpAcceptCharset headers) "Accept-Charset" $ putQualityList putString+ putHeaderM (httpAcceptEncoding headers) "Accept-Encoding" $ putQualityList putString+ putHeaderM (httpAcceptLanguage headers) "Accept-Language" $ putQualityList putString+ when (httpAcceptRanges headers) $ P.putByteString "Accept-Ranges: bytes\r\n"+ putHeaderM (httpAge headers) "Age" putShow+ putHeaderML (httpAllow headers) "Allow" putShow+ putHeaderM (httpAuthorization headers) "Authorization" P.putByteString+ putHeaderL (httpConnection headers ++ if httpConnectionClose headers then ["close"] else [])+ "Connection" putString+ putHeaderL (httpContentEncodings headers) "Content-Encoding" putString+ putHeaderML (httpContentLanguage headers) "Content-Language" putString+ putHeaderM (httpContentLength headers) "Content-Length" putShow+ putHeaderM (httpContentLocation headers) "Content-Location" P.putByteString+ putHeaderM (httpContentRange headers) "Content-Range" putContentRange+ putHeaderM (httpContentType headers) "Content-Type" putMediaType+ putHeaderM (httpDate headers) "Date" putDate+ putHeaderM (httpETag headers) "ETag" putETag+ putHeaderM (httpExpires headers) "Expires" putDate+ putHeaderM (httpHost headers) "Host" P.putByteString+ putHeaderM (httpIfMatch headers) "If-Match" putETagList+ putHeaderM (httpIfModifiedSince headers) "If-Modified-Since" putDate+ putHeaderM (httpIfNoneMatch headers) "If-None-Match" putWETagList+ putHeaderM (httpIfRange headers) "If-Range" $ either putQuoted putDate+ putHeaderM (httpIfUnmodifiedSince headers) "If-Unmodified-Since" putDate+ putHeaderM (httpKeepAlive headers) "Keep-Alive" putShow+ putHeaderM (httpLastModified headers) "Last-Modified" putDate+ putHeaderM (httpLocation headers) "Location" P.putByteString+ putHeaderML (httpPragma headers) "Pragma" putPragma+ putHeaderM (httpProxyAuthenticate headers) "Proxy-Authenticate" P.putByteString+ putHeaderM (httpProxyAuthorization headers) "Proxy-Authorization" P.putByteString+ putHeaderML (httpRange headers) "Range" putRange+ putHeaderM (httpReferer headers) "Referer" P.putByteString+ putHeaderM (httpRetryAfter headers) "Retry-After" putShow+ putHeaderM (httpServer headers) "Server" P.putByteString+ putHeaderL (httpTransferEncoding headers) "Transfer-Encoding" putString+ putHeaderML (httpTrailer headers) "Trailer" putString+ putHeaderM (httpUserAgent headers) "User-Agent" P.putByteString+ putHeaderM (httpWWWAuthenticate headers) "WWW-Authenticate" P.putByteString+ mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v) $+ Map.toList $ httpOtherHeaders headers++putRequest :: Request -> P.Put+putRequest (Request method url major minor headers) = do+ putShow method >> putChar ' ' >> P.putByteString url >> putChar ' '+ P.putByteString "HTTP/"+ putShow major >> putChar '.' >> putShow minor >> P.putByteString "\r\n"+ putHeaders headers+ P.putByteString "\r\n"++putReply :: Reply -> P.Put+putReply (Reply major minor status message headers) = do+ P.putByteString "HTTP/" >> putShow major >> putChar '.' >> putShow minor+ putChar ' ' >> putShow status >> putChar ' '+ putString message >> P.putByteString "\r\n"+ putHeaders headers+ P.putByteString "\r\n"
+ Network/MiniHTTP/MimeTypesParse.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-- | This module parses the /etc/mime.types file, commonly found on UNIX+-- systems. This file provides a mapping from file extension to+-- MIME type.+module Network.MiniHTTP.MimeTypesParse+ ( parseMimeTypes+ , parseMimeTypesTotal+ ) where++import Prelude hiding (catch)+import Control.Applicative+import Control.Exception (catch)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import qualified Data.ByteString as B+import Data.ByteString.Internal (w2c)+import qualified Data.Binary.Strict.Get as G+import qualified Data.Binary.Strict.Class as C+import qualified Data.Binary.Strict.ByteSet as BSet++import Network.MiniHTTP.Marshal (MediaType)++lws = BSet.fromList [9, 32]+newline = BSet.singleton 10+notNewline = BSet.complement newline+others = BSet.complement (lws `BSet.union` newline)+otherNotSlash = others `BSet.difference` BSet.singleton 47++line = do+ ty <- C.spanOf1 $ BSet.member otherNotSlash+ C.word8 47+ subty <- C.spanOf1 $ BSet.member otherNotSlash+ C.spanOf1 $ BSet.member lws+ ext <- C.spanOf1 $ BSet.member others+ exts <- C.many $ C.spanOf (BSet.member lws) >> C.spanOf1 (BSet.member others)+ optional (C.spanOf (BSet.member lws) >> C.word8 35 >> C.spanOf (BSet.member notNewline))+ C.word8 10+ return $ Just ((ty, subty), ext : exts)++blankLine = C.spanOf (BSet.member lws) >> C.optional (C.word8 35 >> C.spanOf (BSet.member notNewline)) >> C.word8 10 >> return Nothing++file = C.many (blankLine <|> line <|> (C.spanOf (BSet.member notNewline) >> C.word8 10 >> return Nothing))++toMap ents = Map.fromList elems where+ ents' = catMaybes ents+ elems = concatMap (\((ty, subty), exts) -> zip exts $ repeat ((toString ty, toString subty), [])) ents'+ toString = map w2c . B.unpack++-- | Parse the given filename as a mime.types file and return a map from file+-- extension to mime type.+parseMimeTypes :: String -> IO (Map.Map B.ByteString MediaType)+parseMimeTypes filename = do+ contents <- B.readFile filename+ case G.runGet file contents of+ (Right results, _) -> return $ toMap results+ (Left err, _) -> fail err++-- | Same as @parseMimeTypes@, but never throw an exception, return a Nothing+-- instead.+parseMimeTypesTotal :: String -> IO (Maybe (Map.Map B.ByteString MediaType))+parseMimeTypesTotal filename = catch (parseMimeTypes filename >>= return . Just) (const $ return Nothing)
+ Network/MiniHTTP/Server.hs view
@@ -0,0 +1,429 @@+-- | This module contains functions for writing webservers. These servers+-- process requests in a state monad pipeline and several useful actions are+-- provided here in. See examples/fileserver.hs for an example of how to use+-- this module.+module Network.MiniHTTP.Server+ ( -- * Sources+ Source+ , SourceResult(..)+ , bsSource+ , hSource+ , nullSource++ -- * The processing monad+ , WebMonad+ , WebState+ , getRequest+ , getReply+ , setReply+ , setHeader++ -- * WebMonad actions+ , handleConditionalRequest+ , handleHandleToSource+ , handleRangeRequests+ , handleDecoration+ , handleFromFilesystem++ -- * Running the server+ , 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++-- | This assumes a little endian system because I can't find a nice way to probe+-- the endianness+htons :: Word16 -> Word16+htons x = ((x .&. 255) `shiftL` 8) .|. (x `shiftR` 8)++-- | A source is a stream of data, like a lazy data structure, but without+-- some of the dangers that such entail. A source returns a @SourceResult@+-- each time you evaluate it.+type Source = IO SourceResult++data SourceResult = SourceError -- ^ error - please don't read this source again+ | SourceEOF -- ^ end of data+ | SourceData B.ByteString -- ^ some data+ deriving (Show)++-- | Construct a source from a ByteString+bsSource :: B.ByteString -> IO Source+bsSource bs = do+ ref <- newIORef $ SourceData bs+ return $ do+ v <- readIORef ref+ writeIORef ref SourceEOF+ return v++-- | Construct a source from a Handle+hSource :: (Int64, Int64) -- ^ the first and last byte to include+ -> Handle -- ^ the handle to read from+ -> 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)++-- | A source with no data (e.g. /dev/null)+nullSource :: Source+nullSource = return SourceEOF++-- | Processing a request involve running a number of actions in a StateT monad+-- where the state for that monad is this record. This contains both a+-- @Source@ and a @Handle@ element. Often something will fill in the @Handle@+-- and expect later processing to convert it to a @Source@. Somehow, you have+-- to end up with a @Source@, however.+data WebState =+ WebState { wsRequest :: Request -- ^ the original request+ -- | the system mime types db, mapping file extensions+ , wsMimeTypes :: Map.Map B.ByteString MediaType+ , wsReply :: Reply -- ^ the current reply+ , wsSource :: Maybe Source -- ^ the current source+ , wsHandle :: Maybe Handle -- ^ the current handle+ -- | an action to be performed before sending the reply+ , wsAction :: Maybe (IO ())+ }++-- | The processing monad+type WebMonad = StateT WebState IO++-- | Return the request+getRequest :: WebMonad Request+getRequest = get >>= return . wsRequest++-- | Return the current reply+getReply :: WebMonad Reply+getReply = get >>= return . wsReply++-- | Set the current reply to be a reply with the given status code, the+-- default message for that status code, an empty body and an empty set of+-- headers.+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} }++-- | Set a header in the current reply. Because of the way records work, you use+-- this function like this:+--+-- > setHeader $ \h -> h { httpSomeHeader = Just value }+setHeader :: (Headers -> Headers) -> WebMonad ()+setHeader f = do+ reply <- getReply+ let h = replyHeaders reply+ s <- get+ put $ s { wsReply = reply { replyHeaders = f h } }+++-- | This handles the If-*Matches and If-*Modified conditional headers. It takes+-- its information from the Last-Modified and ETag headers of the current+-- reply. Note that, for the purposes of ETag matching, a reply without+-- an ETag header is considered not to exist from the point of view of,+-- say, If-Matches: *.+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 ()++-- | If the current state includes a Handle, this turns it into a Source+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 ()++-- | Given the length of the resource, filter any unsatisfiable ranges and+-- convert them all into RangeOf form.+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++-- | This handles Range requests and also translates from Handles to Sources.+-- If the WebMonad has a Handle at this point, then we can construct sources+-- from any subrange of the file. (We also assume that Content-Length is+-- correctly set.)+--+-- See RFC 2616, section 14.35+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)})+ -- We don't support multiple ranges+ _ -> return ()++-- | At the moment, this just adds the header Server: Network.MiniHTTP+handleDecoration :: WebMonad ()+handleDecoration = setHeader (\h -> h { httpServer = Just "Network.MiniHTTP" })++-- | If a source is missing, install a null source. If this was a HEAD request,+-- remove the current source and set the content length to 0+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 ()++-- | This is a very simple handler which deals with requests by returning the+-- requested file from the filesystem. It sets a Handle in the state and sets+-- the Content-Type, Content-Length and Last-Modified headers+handleFromFilesystem :: FilePath -- ^ the root of the filesystem to serve from+ -> WebMonad ()+handleFromFilesystem docroot = do+ req <- getRequest+ when (not $ reqMethod req `elem` [GET, HEAD]) $+ fail "Can only handle GET and HEAD from the filesystem"++ -- stopping directory traversal needs to be done a little carefully.+ -- Hopefully this is all correct+ let path = reqUrl req+ -- First, make sure that there aren't any NULs in the path+ path' = B.takeWhile (/= 0) path+ path'' = map w2c $ B.unpack path'+ elems = splitDirectories path''+ -- Remove any '..'+ 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)++-- | Block until the given queue has less than the given number of bytes in it+-- then enqueue a new ByteString.+waitForLowWaterAndEnqueue :: Int -- ^ the max number of bytes in the queue before we enqueue anything+ -> C.Connection -- ^ the connection to write to+ -> B.ByteString -- ^ the data to enqueue+ -> 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++-- | Read a single request from a socket+readRequest :: Socket+ -> B.ByteString -- ^ data which has already been read from the socket+ -> 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++-- | Loop, reading and processing requests+readRequests :: (Request -> IO (Reply, IO SourceResult))+ -> C.Connection+ -> B.ByteString -- ^ previously read data+ -> 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 -- ^ the port number to listen on+ -> WebMonad () -- ^ the processing action+ -> IO ()+serve portno action = do+ -- Switch these two lines to use IPv6 (which works for IPv4 clients too)+ --acceptingSocket <- socket AF_INET6 Stream 0+ --let sockaddr = SockAddrInet6 (PortNum $ htons $ fromIntegral portno) 0 iN6ADDR_ANY 0++ 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)
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ examples/fileserver.hs view
@@ -0,0 +1,20 @@+-- | This is a very simple fileserver HTTP server which serves from the current+-- directory. It will handle If-Modified-Since and Range requests etc. It+-- doesn't do directory indexes yet, so GETting '/' will give a 404+module Main where++import Network.MiniHTTP.Server++main = serve 4112 $ do+ handleFromFilesystem "."+ handleConditionalRequest+ handleRangeRequests+ handleDecoration++-- If you wanted to process some URLs differently, you would do something like:+-- req <- getRequest+-- if iWantToHandle $ reqUrl req+-- then xyx+-- else handleFromFilesystem "."+-- handleConditionalRequest+-- ...
+ network-minihttp.cabal view
@@ -0,0 +1,18 @@+name: network-minihttp+version: 0.1+license: BSD3+license-file: LICENSE+author: Adam Langley <agl@imperialviolet.org>+description: A very minimal webserver+synopsis: A very minimal webserver+category: Network+build-depends: base, containers, bytestring>=0.9, network-bytestring>=0.1.1.2, network>=2.1, stm>=2.1, binary>=0.4, binary-strict>=0.3, filepath>=1.1.0.0, mtl>=1.1.0.0, unix>=2.3.0.0, time>=1.1.2.0, old-locale>=1.0.0.0+stability: provisional+tested-with: GHC == 6.8.2+exposed-modules: Network.MiniHTTP.Server,+ Network.MiniHTTP.Marshal+ Network.MiniHTTP.MimeTypesParse+other-modules: Network.MiniHTTP.Connection+extra-source-files: examples/fileserver.hs+ghc-options: -Wall -fno-warn-name-shadowing+extensions: OverloadedStrings