diff --git a/Network/MiniHTTP/Client.hs b/Network/MiniHTTP/Client.hs new file mode 100644 --- /dev/null +++ b/Network/MiniHTTP/Client.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains a very basic HTTP client. At the moment, it doesn't +-- even handle redirects for you. +-- +-- Note that, in order to use SSL, you need to have the root CA certificates +-- in a PEM file in @/etc/ssh/certs.pem@ and you need to have wrapped your +-- main function in 'OpenSSL.withOpenSSL' +module Network.MiniHTTP.Client + ( fetchBasic + , connection + , transport + , request + ) where + +import Control.Monad (when) +import Control.Concurrent.STM +import Control.Exception (handle, throwIO) + +import qualified Data.Binary.Put as P +import qualified Data.ByteString as B +import Data.ByteString.Internal (w2c) +import qualified Data.ByteString.Lazy as BL +import Data.Maybe (isNothing) +import Data.String + +import qualified Network.Connection as C +import qualified Network.DNS.Client as DNS +import qualified Network.DNS.Types as DNS +import Network.MiniHTTP.Marshal +import Network.MiniHTTP.HTTPConnection +import qualified Network.MiniHTTP.URL as URL +import Network.Socket + +import System.IO.Unsafe (unsafePerformIO) + +import qualified OpenSSL.Session as SSL +import qualified OpenSSL.X509 as X509 + + +readReply :: C.Connection -> IO (Maybe (Reply, Maybe Source)) +readReply conn = do + r <- readIG conn 256 4096 parseReply + case r of + Nothing -> return Nothing + Just reply -> + case httpContentLength $ replyHeaders reply of + Nothing -> + if "chunked" `elem` (httpTransferEncoding $ replyHeaders reply) + then do + source <- connChunkedSource conn + return $ Just (reply, Just source) + else do + source <- connEOFSource conn + return $ Just (reply, Just source) + Just n -> do + source <- connSource n B.empty conn + return $ Just (reply, Just source) + +-- | A lower level HTTP client, but it allows you to perform POSTs etc +request :: C.Connection -- ^ the connection to use + -> Request -- ^ a request to serialise + -> Maybe Source -- ^ a possible payload (for POSTs etc) + -> IO (Maybe (Reply, Maybe Source)) +request conn req msource = do + let requestBytes = B.concat $ BL.toChunks $ P.runPut $ putRequest req + atomically $ C.write conn requestBytes + let lowWater = 32 * 1024 + + case msource of + (Just source) -> do + success <- if isNothing $ httpContentLength $ reqHeaders req + then streamSourceChunked lowWater conn source + else streamSource lowWater conn source + if not success + then return Nothing + else readReply conn + Nothing -> readReply conn + +globalOpenSSLClientContext :: SSL.SSLContext +globalOpenSSLClientContext = unsafePerformIO $ do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx + SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer False False + SSL.contextSetCAFile ctx "/etc/ssl/cert.pem" + return ctx + +-- | Construct a connection to the correct host for the given URL. (i.e. +-- resolve the hostname and create a TCP connection to the correct port). +-- +-- Note that the DNS resolution (if any) doesn't block the whole process. +connection :: URL.URL + -> IO Socket +connection (URL.URL { URL.urlHost = URL.IPv4Literal host, URL.urlPort = port }) = do + sock <- socket AF_INET Stream 0 + connect sock $ SockAddrInet (fromIntegral port) host + return sock + +connection (URL.URL { URL.urlHost = URL.IPv6Literal host, URL.urlPort = port }) = do + sock <- socket AF_INET6 Stream 0 + connect sock $ SockAddrInet6 (fromIntegral port) 0 host 0 + return sock + +connection (URL.URL { URL.urlHost = URL.Hostname hostname, URL.urlPort = port }) = do + r <- DNS.resolve DNS.A $ map w2c $ B.unpack hostname + case r of + Left error -> fail $ show error + Right [] -> fail "DNS returned no A records" + Right (((_, DNS.RRA (haddr:_))):_) -> do + sock <- socket AF_INET Stream 0 + connect sock $ SockAddrInet (fromIntegral port) haddr + return sock + +-- | Setup the transport (i.e. SSL) for the given URL. In the case of a HTTP +-- scheme, this just wraps the socket in a Connection. +transport :: URL.URL -> Socket -> IO C.Connection +transport (URL.URL { URL.urlScheme = URL.HTTP }) sock = + C.new (return ()) $ C.baseConnectionFromSocket sock + +transport (URL.URL { URL.urlScheme = URL.HTTPS, URL.urlHost = URL.Hostname hostname }) sock = do + ssl <- SSL.connection globalOpenSSLClientContext sock + SSL.connect ssl + verified <- SSL.getVerifyResult ssl + when (not verified) $ fail "Failed to verify SSL server certificate" + mcert <- SSL.getPeerCertificate ssl + case mcert of + Nothing -> fail "No server certificate" + Just cert -> do + subjects <- X509.getSubjectName cert True + case "commonName" `lookup` subjects of + Nothing -> fail "No hostname in certificate" + Just h -> do + when (fromString h /= hostname) $ fail $ + "Hostname doesn't match certificate (" ++ + h ++ " vs " ++ show hostname ++ ")" + conn <- C.new (return ()) $ sslToBaseConnection ssl + return conn + +transport _ _ = fail "Cannot create HTTPS connection to an IP address (cannot check certificate)" + +-- | Fetch an HTTP(S) entity. +fetchBasic :: Headers -- ^ the headers to use. This function will set the Host + -- header for you in the case that the URL has a + -- hostname in it. If in doubt, use 'emptyHeaders' + -> URL.URL -- ^ the resource to fetch + -> IO (C.Connection, Reply, Maybe Source) + -- ^ the connection (which you have to close once you are done + -- reading the 'Source', if any), the Reply and a possible + -- payload +fetchBasic headers url = do + sock <- connection url + handle (\e -> sClose sock >> throwIO e) $ do + conn <- transport url sock + let headers' = case URL.urlHost url of + URL.Hostname h -> headers { httpHost = Just h } + _ -> headers + r <- request conn (Request GET (URL.toRelative url) 1 1 headers') Nothing + case r of + Nothing -> C.close conn >> fail "HTTP parse error" + (Just (reply, msource)) -> return (conn, reply, msource) diff --git a/Network/MiniHTTP/Connection.hs b/Network/MiniHTTP/Connection.hs deleted file mode 100644 --- a/Network/MiniHTTP/Connection.hs +++ /dev/null @@ -1,120 +0,0 @@ -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 diff --git a/Network/MiniHTTP/HTTPConnection.hs b/Network/MiniHTTP/HTTPConnection.hs new file mode 100644 --- /dev/null +++ b/Network/MiniHTTP/HTTPConnection.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains many helper functions, as well the code for 'Source', +-- which is a pretty important structure +module Network.MiniHTTP.HTTPConnection + ( -- * Sources, and related functions + Source + , SourceResult(..) + , bsSource + , hSource + , nullSource + , sourceToLBS + , sourceToBS + , connSource + , connChunkedSource + , connEOFSource + , sourceDrain + , streamSource + , streamSourceChunked + + -- * Misc functions + , readIG + , sourceIG + , maybeRead + , sslToBaseConnection + ) where + +import Control.Concurrent.STM +import qualified Control.Exception as Exception +import Control.Monad (liftM) + +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy.Internal as BL +import qualified Data.Binary.Strict.IncrementalGet as IG +import Data.IORef +import Data.Int (Int64) + +import System.IO + +import Text.Printf (printf) + +import System.IO.Unsafe (unsafeInterleaveIO) + +import qualified Network.Connection as C +import Network.Socket as Socket +import Network.MiniHTTP.Marshal (parseChunkHeader) + +import qualified OpenSSL.Session as SSL + +-- | 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 + Exception.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 + +-- | A source which reads from the given 'Connection' until the connection +-- signals end-of-file. +connEOFSource :: C.Connection -> IO Source +connEOFSource conn = do + return $ + catch (liftM SourceData $ C.read conn 1024) (const $ return SourceEOF) + +-- | A source which reads from a 'C.Connection' +connSource :: Int64 -- ^ the number of bytes to read + -> B.ByteString -- ^ a string which is prepended to the output + -> C.Connection -- ^ the connection to read from + -> IO Source +connSource n bs conn = + if fromIntegral (B.length bs) == n + then bsSource bs + else do + ref <- newIORef (False, 0 :: Int64) + return $ do + (doneBS, n') <- readIORef ref + if not doneBS + then do writeIORef ref (True, fromIntegral $ B.length bs) + return $ SourceData bs + else if n' == n + then return SourceEOF + else do bytes <- C.read conn $ min (32 * 1024) $ fromIntegral (n - n') + if B.length bytes == 0 + then return SourceError + else do writeIORef ref (doneBS, n' + (fromIntegral $ B.length bytes)) + return $ SourceData bytes + +-- | A source which reads an HTTP chunked reply from a 'C.Connection' +connChunkedSource :: C.Connection -> IO Source +connChunkedSource conn = do + -- the contents of this reference are the number of bytes remaining in the + -- current chunk. If zero, a chunk headers needs to be read. If < 0, we have + -- hit EOF. If we read the end of a chunk, we always read the trailing \r\n + -- before returning (so one need never consider that case on entry) + ref <- newIORef (0 :: Int64) + let f = do + remainingInThisChunk <- readIORef ref + case remainingInThisChunk of + 0 -> do + m <- readIG conn 16 256 parseChunkHeader + case m of + Nothing -> return SourceError + Just n -> + if n == 0 + then C.reada conn 2 >> writeIORef ref (-1) >> return SourceEOF + else writeIORef ref n >> f + (-1) -> return SourceEOF + remainingInThisChunk -> do + bytes <- C.read conn $ fromIntegral $ min remainingInThisChunk $ 32*1024 + if B.null bytes + then return SourceError + else do + let stillRemaining = remainingInThisChunk - (fromIntegral $ B.length bytes) + if stillRemaining == 0 + then do + C.reada conn 2 -- read \r\n + writeIORef ref 0 + else do + writeIORef ref stillRemaining + return $ SourceData bytes + return f + +-- | Read a source until it returns 'SourceEOF' +sourceDrain :: Source -> IO () +sourceDrain s = do + v <- s + case v of + SourceEOF -> return () + SourceError -> return () + SourceData _ -> sourceDrain s + +-- | Convert a source to a lazy ByteString +sourceToLBS :: Source -> IO BL.ByteString +sourceToLBS s = do + bytes <- s + case bytes of + SourceEOF -> return $ BL.Empty + SourceError -> fail "Error in reading from client" + SourceData bs -> do + rest <- unsafeInterleaveIO $ sourceToLBS s + return $ BL.Chunk bs rest + +-- | Take, at most, the first n bytes from a Source and return a strict +-- ByteString. Returns Nothing on error. (A short read is not an error) +sourceToBS :: Int -> Source -> IO (Maybe B.ByteString) +sourceToBS n source = f 0 where + f soFar = do + s <- source + case s of + SourceEOF -> return $ Just B.empty + SourceError -> return Nothing + SourceData bs -> do + if B.length bs + soFar >= n + then return $ Just $ B.take (n - soFar) bs + else do + rest <- f (soFar + B.length bs) + return $ (rest >>= return . B.append bs) + +-- | Stream a source to a connection while not enqueuing more than lowWater +-- bytes in the outbound queue (not inc the kernel buffer) +streamSource :: Int -> C.Connection -> Source -> IO Bool +streamSource lowWater conn source = do + next <- source + case next of + SourceEOF -> return True + SourceError -> return False + SourceData bs -> do + atomically $ C.writeAtLowWater lowWater conn bs + streamSource lowWater conn source + +-- | Stream a source to a connection, with chunked encoding, while not +-- enqueuing more than lowWater bytes in the outbound queue (not inc the +-- kernel buffer) +streamSourceChunked :: Int -> C.Connection -> Source -> IO Bool +streamSourceChunked lowWater conn source = do + next <- source + case next of + SourceEOF -> do + atomically $ C.writeAtLowWater lowWater conn "0\r\n\r\n" + return True + SourceError -> return False + SourceData bs -> do + atomically $ C.writeAtLowWater lowWater conn $ B.pack $ map c2w $ + printf "%d\r\n\r\n" $ B.length bs + atomically $ C.writeAtLowWater lowWater conn bs + atomically $ C.writeAtLowWater lowWater conn "\r\n" + streamSourceChunked lowWater conn source + +-- | Run an incremental parser from the network +readIG :: C.Connection -- ^ the connection to read from + -> Int -- ^ the block size to use + -> Int -- ^ maximum number of bytes to parse + -> IG.Get a a -- ^ the parser + -> IO (Maybe a) +readIG conn blockSize maxBytes parser = do + let f sofar result + | sofar >= maxBytes = return Nothing + | otherwise = do + case result of + IG.Failed _ -> return Nothing + IG.Partial cont -> C.read conn blockSize >>= \bs -> f (sofar + B.length bs) $ cont bs + IG.Finished rest result -> do + atomically $ C.pushBack conn rest + return $ Just result + C.read conn blockSize >>= f 0 . IG.runGet parser + +-- | Run an incremental parser from a 'Source' +sourceIG :: Source -- ^ the source to read from + -> Int -- ^ the maximum number of bytes to parse + -> IG.Get a a -- ^ the parser + -> IO (Maybe a) +sourceIG source maxBytes parser = do + let f sofar result + | sofar >= maxBytes = return Nothing + | otherwise = + case result of + IG.Failed _ -> return Nothing + IG.Partial cont -> do + s <- source + case s of + SourceError -> return Nothing + SourceEOF -> return Nothing + SourceData bytes -> f (B.length bytes + sofar) $ cont bytes + IG.Finished _ result -> do + return $ Just result + f 0 $ IG.runGet parser B.empty + +maybeRead :: Read a => B.ByteString -> Maybe a +maybeRead s = case reads $ map w2c $ B.unpack s of + [(x, "")] -> Just x + _ -> Nothing + +-- | Convert an SSL connection to a BaseConnection for Network.Connection +sslToBaseConnection :: SSL.SSL -> C.BaseConnection +sslToBaseConnection ssl = C.BaseConnection r w c where + r n = do + bytes <- SSL.read ssl n + return bytes + w bs = SSL.write ssl bs >> return (B.length bs) + c = SSL.shutdown ssl SSL.Unidirectional >> sClose (SSL.sslSocket ssl) diff --git a/Network/MiniHTTP/Marshal.hs b/Network/MiniHTTP/Marshal.hs --- a/Network/MiniHTTP/Marshal.hs +++ b/Network/MiniHTTP/Marshal.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-monomorphism-restriction -fno-warn-missing-signatures #-} +{-# LANGUAGE OverloadedStrings #-} -- | 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. @@ -8,7 +9,9 @@ , Reply(..) , Range(..) , Headers(..) + , Cookie(..) , emptyHeaders + , emptyCookie , statusToMessage , Method(..) , MediaType @@ -16,37 +19,41 @@ , putReply , parseRequest , parseReply + , parseChunkHeader ) 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 Prelude hiding (putChar) + +import Control.Applicative ((<|>), liftA, liftA2, (*>)) +import Control.Monad (when, forM_) + import qualified Data.ByteString as B -import Data.ByteString.Char8 () -import Data.ByteString.Internal (c2w, w2c) +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 qualified Data.Binary.Strict.Class as C +import qualified Data.Binary.Strict.Get as G +import Data.Int (Int64) +import Data.List (intersperse, foldl') +import qualified Data.Map as Map +import Data.Maybe (isJust, maybe) +import Data.String (fromString) +import Data.Time (UTCTime(..)) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Format (formatTime) +import Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime) -import Debug.Trace (trace) +import GHC.Exts() -debug x = trace (show x) x +import System.Locale (TimeLocale(..)) +import qualified Network.MiniHTTP.URL as URL + -- | A HTTP request data Request = Request { reqMethod :: Method - , reqUrl :: B.ByteString + , reqUrl :: URL.RelativeURL , reqMajor :: Int , reqMinor :: Int , reqHeaders :: Headers @@ -77,6 +84,7 @@ , httpAge :: Maybe Int64 , httpAllow :: Maybe [Method] , httpAuthorization :: Maybe B.ByteString + , httpCookie :: [Cookie] , httpConnectionClose :: Bool , httpConnection :: [String] , httpContentEncodings :: [String] @@ -104,6 +112,7 @@ , httpReferer :: Maybe B.ByteString , httpRetryAfter :: Maybe Int64 , httpServer :: Maybe B.ByteString + , httpSetCookie :: [Cookie] , httpTrailer :: Maybe [String] , httpTransferEncoding :: [String] , httpUserAgent :: Maybe B.ByteString @@ -111,13 +120,22 @@ , httpOtherHeaders :: Map.Map B.ByteString B.ByteString } deriving (Show) +-- | A HTTP Cookie. See +data Cookie = Cookie { cookieName :: B.ByteString + , cookieValue :: B.ByteString + , cookiePath :: Maybe String + , cookieDomain :: Maybe String + , cookieExpires :: Maybe UTCTime + , cookieSecure :: Bool + } deriving (Show, Eq, Ord) + emptyHeaders :: Headers emptyHeaders = Headers Nothing Nothing Nothing Nothing - False Nothing Nothing Nothing False [] [] 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 Nothing Nothing Nothing Nothing [] Nothing [] Nothing Nothing Map.empty -- | The list of valid methods, see RFC 2616 section 5.1 @@ -200,7 +218,7 @@ BSet.range (c2w 'A') (c2w 'F') `BSet.union` digits separators = BSet.fromList $ map c2w "()<>@,;:\\\"/[]?={} \t" -ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\") +--ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\") qdtexts = texts `BSet.difference` (BSet.fromList $ map c2w "\"\\") -------------------------------------------------------------------------------- @@ -226,11 +244,12 @@ then return 0 else return $ read $ toString r ++ replicate (3 - B.length r) '0' -comment = do +{-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) @@ -346,6 +365,9 @@ int64 :: (C.BinaryParser c) => c Int64 int64 = C.spanOf1 (BSet.member digits) >>= return . readOrZero . toString +hexInt64 :: (C.BinaryParser c) => c Int64 +hexInt64 = C.spanOf1 (BSet.member hexes) >>= return . readOrZero . ((++) "0x") . toString + readOrZero "" = 0 readOrZero x = read x @@ -466,7 +488,7 @@ invalid (RangeOf a b) = a > b invalid _ = False -headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges $ debug a } where +headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges a } where f = a <|> b <|> c where a = char '-' *> liftA RangeSuffix int64 b = int64 >>= (\start -> char '-' *> liftA (RangeOf start) int64) @@ -480,6 +502,42 @@ 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 } +emptyCookie = Cookie B.empty B.empty Nothing Nothing Nothing False + +mergeCookie a b = + Cookie { cookieName = bs cookieName + , cookieValue = bs cookieValue + , cookiePath = m cookiePath + , cookieDomain = m cookieDomain + , cookieExpires = m cookieExpires + , cookieSecure = cookieSecure a || cookieSecure b } where + bs f = if B.null $ f a then f b else f a + m f = case f a of + Nothing -> f b + x -> x + +cookie = do + name <- C.spanOf1 (/= 0x3d {- '=' -} ) + C.word8 0x3d + value <- C.spanOf1 (/= 0x3b {- ';' -} ) + + options <- C.many $ do + C.word8 0x3b + lws + key <- C.spanOf1 (BSet.member alphas) + let value = C.spanOf1 (/= 0x3b) + case key of + "secure" -> return $ emptyCookie { cookieSecure = True } + "path" -> value >>= \v -> (return $ emptyCookie { cookiePath = Just $ toString v }) + "domain" -> value >>= \v ->(return $ emptyCookie { cookieDomain = Just $ toString v }) + "expires" -> date >>= \v -> (return $ emptyCookie { cookieExpires = Just v}) + _ -> C.spanOf1 (/= 0x3d) >> return emptyCookie + + return $ foldl mergeCookie (emptyCookie { cookieName = name, cookieValue = value }) options + +headerSetCookie req = cookie >>= \c -> return $ req { httpSetCookie = c : httpSetCookie req } +headerCookie req = cookie >>= \c -> return $ req { httpCookie = c : httpCookie req } + -------------------------------------------------------------------------------- -- Top level parsing functions @@ -560,6 +618,8 @@ , ("Trailer", headerTrailer) , ("User-Agent", headerUserAgent) , ("WWW-Authenticate", headerWWWAuthenticate) + , ("Cookie", headerCookie) + , ("Set-Cookie", headerSetCookie) ] parseMethod :: (Monad m) => B.ByteString -> m Method @@ -578,10 +638,13 @@ parseRequest :: (C.BinaryParser m) => m Request parseRequest = do (strmethod, url, major, minor) <- requestLine + uri <- case URL.parseRelative url of + Just uri -> return uri + Nothing -> fail "Failed to parse URL" method <- parseMethod strmethod headers <- parseHeaders - return $ Request method url major minor headers + return $ Request method uri major minor headers parseReply :: (C.BinaryParser m) => m Reply parseReply = do @@ -605,10 +668,18 @@ return req' +parseChunkHeader :: (C.BinaryParser m) => m Int64 +parseChunkHeader = do + length <- hexInt64 + C.optional lws -- not in RFC, due to Yahoo being broken + C.many $ char ';' >> token >> char '=' >> (token <|> quotedString) + crlf + return length + -------------------------------------------------------------------------------- -- Serialisation functions -putString = P.putByteString . B.pack . map c2w +putString = P.putByteString . fromString putChar = P.putWord8 . c2w putShow = putString . show @@ -632,12 +703,43 @@ 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) +putHeaderML a b c = putHeaderM a b (sequence_ . intersperse (P.putByteString ",") . map c) +putHeaderMLE :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> B.ByteString -> P.Put +putHeaderMLE a b c extra = putHeaderM a b (sequence_ . ((:) (P.putByteString extra)) . intersperse (P.putByteString ", ") . map 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" +putHeaderMulti :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put +putHeaderMulti vs name f = forM_ vs $ \v -> do + P.putByteString name + P.putByteString ": " + f v + P.putByteString "\r\n" + +whenMaybe :: Maybe a -> (a -> P.Put) -> P.Put +whenMaybe Nothing _ = return () +whenMaybe (Just x) f = f x + +putCookie :: Cookie -> P.Put +putCookie cookie = do + P.putByteString $ cookieName cookie + P.putWord8 0x3d {- '=' -} + P.putByteString $ cookieValue cookie + + whenMaybe (cookiePath cookie) $ \s -> do + P.putByteString "; path=" + P.putByteString $ fromString s + whenMaybe (cookieDomain cookie) $ \s -> do + P.putByteString "; domain=" + P.putByteString $ fromString s + whenMaybe (cookieExpires cookie) $ \date -> do + P.putByteString "; expires=" + putDate date + when (cookieSecure cookie) $ P.putByteString "; secure" + 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 @@ -707,7 +809,7 @@ putHeaderML (httpPragma headers) "Pragma" putPragma putHeaderM (httpProxyAuthenticate headers) "Proxy-Authenticate" P.putByteString putHeaderM (httpProxyAuthorization headers) "Proxy-Authorization" P.putByteString - putHeaderML (httpRange headers) "Range" putRange + putHeaderMLE (httpRange headers) "Range" putRange "bytes=" putHeaderM (httpReferer headers) "Referer" P.putByteString putHeaderM (httpRetryAfter headers) "Retry-After" putShow putHeaderM (httpServer headers) "Server" P.putByteString @@ -715,12 +817,14 @@ 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) $ + putHeaderMulti (httpSetCookie headers) "Set-Cookie" putCookie + putHeaderMulti (httpSetCookie headers) "Cookie" putCookie + mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v >> P.putByteString "\r\n") $ Map.toList $ httpOtherHeaders headers putRequest :: Request -> P.Put putRequest (Request method url major minor headers) = do - putShow method >> putChar ' ' >> P.putByteString url >> putChar ' ' + putShow method >> putChar ' ' >> P.putByteString (URL.serialiseRelative url) >> putChar ' ' P.putByteString "HTTP/" putShow major >> putChar '.' >> putShow minor >> P.putByteString "\r\n" putHeaders headers diff --git a/Network/MiniHTTP/MimeTypesParse.hs b/Network/MiniHTTP/MimeTypesParse.hs --- a/Network/MiniHTTP/MimeTypesParse.hs +++ b/Network/MiniHTTP/MimeTypesParse.hs @@ -7,18 +7,20 @@ , parseMimeTypesTotal ) where -import Prelude hiding (catch) -import Control.Applicative -import Control.Exception (catch) -import qualified Data.Map as Map -import Data.Maybe (catMaybes) +import Prelude hiding (catch) + +import Control.Applicative +import Control.Exception (catch) + import qualified Data.ByteString as B -import Data.ByteString.Internal (w2c) -import qualified Data.Binary.Strict.Get as G +import Data.ByteString.Internal (w2c) +import qualified Data.Binary.Strict.ByteSet as BSet import qualified Data.Binary.Strict.Class as C -import qualified Data.Binary.Strict.ByteSet as BSet +import qualified Data.Binary.Strict.Get as G +import qualified Data.Map as Map +import Data.Maybe (catMaybes) -import Network.MiniHTTP.Marshal (MediaType) +import Network.MiniHTTP.Marshal (MediaType) lws = BSet.fromList [9, 32] newline = BSet.singleton 10 diff --git a/Network/MiniHTTP/OpenID.hs b/Network/MiniHTTP/OpenID.hs new file mode 100644 --- /dev/null +++ b/Network/MiniHTTP/OpenID.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module contains support for the OpenID authentication standard. See +-- for details of the protocol. At the moment, only the +-- basic v2 authentication is supported. Also, we only support OpenID 2.0 +-- HTML discovery, not Yadis nor XRI. +-- +-- Only DH-SHA1 is used for the cryptography. This used to be SHA256, but +-- Yahoo doesn't support it (boo!) +-- +-- References in this module are to the OpenID v2 spec +-- +module Network.MiniHTTP.OpenID + ( -- * Types + OpenIDDiscovery(..) + , CheckIDType(..) + , Handle + , Key + + -- * Actions + , findKey + , discover + , associate + , checkID + , processCheckIDReply + ) where + +import Control.Monad (liftM) +import Control.Concurrent.STM +import Control.Exception (handle, throwIO) + +import Data.Bits (shiftR, xor, (.&.)) +import qualified Data.Binary.Strict.Class as C +import qualified Data.Binary.Strict.Get as G +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import Data.ByteString.Internal (w2c) +import qualified Data.Map as Map +import Data.Maybe (maybe, fromJust) +import Data.String (IsString(..)) +import Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime) +import Data.Word (Word8, Word32) + +import qualified Network.Connection as C +import Network.Socket (sClose) +import Network.MiniHTTP.Client +import Network.MiniHTTP.HTTPConnection +import Network.MiniHTTP.Marshal +import qualified Network.MiniHTTP.URL as URL + +import System.IO.Unsafe (unsafePerformIO) + +import Text.HTML.TagSoup + +import qualified OpenSSL.EVP.Base64 as Base64 +import qualified OpenSSL.EVP.Digest as Digest +import qualified OpenSSL.BN as BN + +-- | This is the result of Discovery: the OP local identity and the server HTTP +-- endpoint. +data OpenIDDiscovery = + OpenIDDiscovery { discoveryProvider :: URL.URL + , discoveryLocalID :: Maybe String + } deriving (Show, Eq) + +-- | This is the number of bytes of HTML that we'll try and read in order to +-- find the OpenID link elements +discoveryHTMLLimit :: Integral i => i +discoveryHTMLLimit = 4096 + +-- | Use HTML discovery to find the OpenID information for a given URL +discover :: URL.URL -> IO OpenIDDiscovery +discover uri = do + r <- fetchBasic (emptyHeaders { httpRange = Just [RangeOf 0 discoveryHTMLLimit] }) uri + case r of + (conn, _, Nothing) -> do + C.close conn + fail "HTTP server returned no content" + (conn, _, Just source) -> do + let f d@(mprovider, mlocalid) (TagOpen "link" attrs) = maybe d id $ do + rel <- "rel" `lookup` attrs + href <- "href" `lookup` attrs + case rel of + "openid2.provider" -> do + uri <- URL.parse $ fromString href + return (Just uri, mlocalid) + "openid2.local_id" -> return (mprovider, Just href) + _ -> return d + + payload <- sourceToBS 4096 source + C.close conn + case payload of + Nothing -> fail "Error reading HTTP reply" + Just payload -> do + let (mprovider, mlocalid) = + foldl f (Nothing, Nothing) $ map head $ + concatMap (sections (~== ("" :: String))) $ + sections (~== ("" :: String)) $ + parseTags $ map w2c $ B.unpack payload + + case mprovider of + Nothing -> fail "No provider discovered" + Just provider -> return $ OpenIDDiscovery provider mlocalid + +-- | The default DH generator +dhG :: Integer +dhG = 2 +-- | The default DH prime. See appendix B +dhP :: Integer +dhP = 0xDCF93A0B883972EC0E19989AC5A2CE310E1D37717E8D9571BB7623731866E61EF75A2E27898B057F9891C2E27A639C3F29B60814581CD3B2CA3986D2683705577D45C2E7E52DC81C7A171876E5CEA74B1448BFDFAF18828EFD2519F14E45E3826634AF1949E5B535CC829A483B8A76223E5D490A257F05BDFF16F2FB22C583AB + +-- | Encode a URL of URL query key-value pairs into a query string (not +-- including the leading "?"). The string "openid." is prepended to all the +-- key names. See 4.1.2 +postEncode :: Map.Map B.ByteString B.ByteString -> B.ByteString +postEncode = URL.serialiseArguments . Map.mapKeys (B.append "openid.") + +-- | Encode a list of key-value pairs, in order, into the OpenID Key Value +-- format. See 4.1.1. +keyValueEncode :: [(B.ByteString, B.ByteString)] -> B.ByteString +keyValueEncode values = (B.intercalate (B.singleton 10) $ map f values) `B.append` B.singleton 10 where + f (key, value) = key `B.append` + B.singleton 0x3a `B.append` + value + +-- | A map of the default parameters included in all OpenID requests +defaultParams :: Map.Map B.ByteString B.ByteString +defaultParams = Map.fromList [("ns", "http://specs.openid.net/auth/2.0")] + +-- | Convert an Integer to base64(btwoc) form. See 4.2 +integerToBase64btwoc :: Integer -> IO B.ByteString +integerToBase64btwoc i = liftM (Base64.encodeBase64BS . B.drop 4) $ BN.integerToMPI i + +-- | Convert a ByteString in btwoc form to an Integer. See 4.2 +btwocToInteger :: B.ByteString -> IO Integer +btwocToInteger bs = do + let len :: Word32 + len = fromIntegral $ B.length bs + lengthbytes = B.pack $ map (\n -> fromIntegral $ (len `shiftR` n) .&. 0xff) [24, 16, 8, 0] + mpi = lengthbytes `B.append` bs + BN.mpiToInteger mpi + +-- | The type of an OpenID handle. Handles are used to identify sessions +-- between the consumer and OP. +newtype Handle = Handle B.ByteString deriving (Show, Eq) +-- | The type of a key. +newtype Key = Key B.ByteString deriving (Show, Eq) + +-- | This is the cache of association handles. It maps a string (hostname + +-- path of the OP) to a handle, key, expiry time triple. +associateCache :: TVar (Map.Map B.ByteString (Handle, Key, UTCTime)) +associateCache = unsafePerformIO $ newTVarIO Map.empty + +updateTVar :: TVar a -> (a -> a) -> STM () +updateTVar var f = readTVar var >>= writeTVar var . f + +-- | Lookup a key given the hostname of the OP and the handle. Generally used +-- after an indirect request to check a signature from an OP. +findKey :: B.ByteString -> Handle -> STM (Maybe Key) +findKey host (Handle handle) = do + cache <- readTVar associateCache + case Map.lookup host cache of + Nothing -> return Nothing + Just ((Handle handle'), key, _) -> + if handle == handle' + then return $ Just key + else return Nothing + +-- | Perform an association with a discovered OP and return either an error +-- message or a handle, a key and the number of seconds from now when the +-- handle will expire. +-- +-- Internally this uses a cache so 'associate' may not actually involve an +-- HTTP request to the OP. +associate :: OpenIDDiscovery -> IO (Handle, Key) +associate discovery@(OpenIDDiscovery provider _) = do + let cacheKey = fromString $ show provider + currentTime <- getCurrentTime + v <- atomically $ do + cache <- readTVar associateCache + case cacheKey `Map.lookup` cache of + Nothing -> return Nothing + Just v@(_, _, expiry) -> + -- if the key expires in the next five minutes, dump it now + if 300 `addUTCTime` expiry > currentTime + then do writeTVar associateCache $ cacheKey `Map.delete` cache + return Nothing + else return $ Just v + case v of + Just (h, k, _) -> return (h, k) + Nothing -> do + (h, k, secs) <- associateHTTP discovery + let expiry = addUTCTime (fromIntegral secs) currentTime + atomically $ do + updateTVar associateCache (Map.insert cacheKey (h, k, expiry)) + return (h, k) + +-- | Convert a URL to a Host header +urlToHost :: URL.URL -> Maybe B.ByteString +urlToHost (URL.URL {URL.urlHost = URL.Hostname h}) = Just h +urlToHost _ = Nothing + +-- | An implementation of 'associate' which does an actual HTTP lookup +-- everytime. This is wrapped by 'associate', which handles caching of these +-- values. You can call this directly to bypass the cache. +associateHTTP :: OpenIDDiscovery -> IO (Handle, Key, Int) +associateHTTP (OpenIDDiscovery provider _) = do + sock <- connection provider + handle (\e -> sClose sock >> throwIO e) $ do + conn <- transport provider sock + (postbody, x) <- associateRequest + postsource <- bsSource postbody + r <- request conn (Request POST (URL.toRelative provider) 1 1 $ + emptyHeaders { httpHost = urlToHost provider + , httpContentType = Just (("application", "x-www-form-urlencoded"), []) + , httpContentLength = Just $ fromIntegral $ B.length postbody + }) $ Just postsource + case r of + (Just (Reply {replyStatus = 200}, Just source)) -> do + mreplyBytes <- sourceToBS 4096 source + C.close conn + case mreplyBytes of + Nothing -> fail "Error reading reply" + Just replyBytes -> do + case G.runGet (parseKeyValue 10 0x3a) replyBytes of + (Right reply, _) -> processAssociateReply reply x + _ -> fail "Error parsing reply" + _ -> print (fst $ fromJust r) >> fail "Bad HTTP reply code" + +-- | Handle a reply from an associate call. +processAssociateReply :: Map.Map B.ByteString B.ByteString -- ^ reply from the server + -> Integer -- ^ the x value from associateRequest + -> IO (Handle, Key, Int) + -- ^ (handle, key, seconds to expiry) +processAssociateReply reply x = + mapWrapper reply["assoc_handle", "dh_server_public", "enc_mac_key", "expires_in"] $ + \[handle, serverPublic, encKey, expiresStr] -> do + Just sha1 <- Digest.getDigestByName "SHA1" + gy <- btwocToInteger $ Base64.decodeBase64BS serverPublic + let encKey' = Base64.decodeBase64BS encKey + shared = BN.modexp gy x dhP + sharedmpi <- BN.integerToMPI shared + print encKey' + print $ B.length encKey' + let sharedbtwoc = B.drop 4 sharedmpi + sharedkey = Digest.digestBS' sha1 sharedbtwoc + key = B.pack $ B.zipWith (xor) sharedkey encKey' + case maybeRead expiresStr of + Nothing -> fail "Failed to parse expiry" + Just expires -> return (Handle handle, Key key, expires) + + +-- | This creates an associate request and returns the URL query and the value +-- of @x@ +associateRequest :: IO (B.ByteString, Integer) +associateRequest = do + x <- BN.randIntegerUptoNMinusOneSuchThat (/= 0) dhP + let gxmodp = BN.modexp dhG x dhP + encoded <- integerToBase64btwoc gxmodp + + let m = Map.union defaultParams $ Map.fromList extras + extras = [ ("mode", "associate") + , ("assoc_type", "HMAC-SHA1") + , ("session_type", "DH-SHA1") + , ("dh_consumer_public", encoded) + ] + print encoded + return (postEncode m, x) + +-- | A helper function which extracts a number of keys from a list, calling a +-- continuation with those values if all are found and returning a Left if +-- any are missing +mapWrapper :: Map.Map B.ByteString B.ByteString -- ^ the map of values + -> [B.ByteString] -- ^ the required keys + -> ([B.ByteString] -> IO a) -- ^ the continuation + -> IO a -- ^ the result +mapWrapper m keys f = + case mapM (flip Map.lookup m) keys of + Nothing -> fail "Map missing required value" + Just values -> f values + +parseKeyValue :: (C.BinaryParser m) + => Word8 -- ^ byte which breaks 'lines' (e.g. \n) + -> Word8 -- ^ byte which breaks pairs (e.g. ':') + -> m (Map.Map B.ByteString B.ByteString) +parseKeyValue lineBreak pairBreak = do + let parseLine = do + key <- C.spanOf1 (/= pairBreak) + C.word8 pairBreak + value <- C.spanOf1 (/= lineBreak) + if B.isPrefixOf "openid." key + then return (B.drop 7 key, value) + else return (key, value) + line <- parseLine + rest <- C.many (C.word8 lineBreak >> parseLine) + C.optional $ C.word8 lineBreak + donep <- C.isEmpty + if not donep + then fail "Trailing garbage found" + else return $ Map.fromList $ line : rest + +-- | There are two types of checkid calls. +data CheckIDType = CheckIDSetup | CheckIDImmediate deriving (Show, Eq) + +typeToString :: CheckIDType -> B.ByteString +typeToString CheckIDSetup = "checkid_setup" +typeToString CheckIDImmediate = "checkid_immediate" + +-- | Construct a checkid call +checkID :: CheckIDType + -> URL.URL -- ^ claimed id + -> OpenIDDiscovery -- ^ OP-local id + -> Handle -- ^ assoc handle + -> B.ByteString -- ^ return to URL + -> Maybe B.ByteString -- ^ trust realm + -> URL.URL -- ^ URL +checkID ty claimed (OpenIDDiscovery provider mlocalid) (Handle handle) returnTo realm = r where + r = provider { URL.urlArguments = foldl Map.union Map.empty + [ URL.urlArguments provider + , Map.mapKeys (B.append "openid.") defaultParams + , Map.mapKeys (B.append "openid.") $ Map.fromList rest + ] } + common = [ ("mode", typeToString ty) + , ("claimed_id", URL.serialise claimed) + , ("identity", maybe (URL.serialise claimed) fromString mlocalid) + , ("assoc_handle", handle) + , ("return_to", returnTo) + ] + rest = case realm of + Nothing -> common + Just realm -> ("realm", realm) : common + +processCheckIDReply :: Map.Map B.ByteString B.ByteString -- ^ the arguments + -> IO (Either String B.ByteString) +processCheckIDReply args' = do + -- first strip openid. from the front of all the keys + let args = Map.mapKeys (\k -> if "openid." `B.isPrefixOf` k then B.drop 7 k else k) args' + Just sha1 <- Digest.getDigestByName "SHA1" + mapWrapper args ["assoc_handle", "claimed_id", "op_endpoint", "signed", "sig"] $ + \[handle, claimed, endpoint, signed, sig] -> do + mkey <- atomically $ findKey endpoint $ Handle handle + case mkey of + Nothing -> return $ Left "Cannot find assoc key" + Just (Key key) -> do + let signedFields = B.split 0x2c signed + in mapWrapper args signedFields $ \signedValues -> do + let kv = keyValueEncode $ zip signedFields signedValues + mySig = Base64.encodeBase64BS $ Digest.hmacBS sha1 key kv + if mySig == sig + then return $ Right claimed + else return $ Left "OpenID signature verification failed" diff --git a/Network/MiniHTTP/Server.hs b/Network/MiniHTTP/Server.hs --- a/Network/MiniHTTP/Server.hs +++ b/Network/MiniHTTP/Server.hs @@ -1,22 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} -- | 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. +-- provided herein. +-- +-- See @examples/test.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 + ( -- * The processing monad + WebMonad + , WebState(..) , getRequest + , getPayload + , getPOST + , getGET , getReply , setReply , setHeader + , setCookie + , errorPage -- * WebMonad actions , handleConditionalRequest @@ -26,104 +26,60 @@ , handleFromFilesystem -- * Running the server - , serve + , serveHTTP + , serveHTTPS + , DispatchMatch(..) + , dispatchOnURL ) where -import Prelude hiding (foldl, elem, catch) +import Prelude hiding (foldl, catch) -import Control.Concurrent.STM -import Control.Monad (liftM) -import Control.Monad.State.Strict -import Control.Exception (catch) +import Control.Concurrent.STM +import Control.Exception (catch) +import Control.Monad.State.Strict -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.Binary.Put as P import qualified Data.ByteString as B -import Data.ByteString.Internal (w2c, c2w) -import Data.ByteString.Char8 () +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 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) +import Data.Maybe (isNothing, isJust, fromJust, catMaybes, maybe) +import Data.String (fromString) +import Data.Time.Clock.POSIX --- | 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 +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 --- | 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) +import qualified OpenSSL.Session as SSL --- | A source with no data (e.g. /dev/null) -nullSource :: Source -nullSource = return SourceEOF +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 --- | Processing a request involve running a number of actions in a StateT monad +-- | Processing a request involves 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. +-- @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 + , wsBody :: Maybe Source -- ^ the client's payload , wsMimeTypes :: Map.Map B.ByteString MediaType + -- ^ the system mime types db, mapping file extensions , 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 ()) + -- ^ an action to be performed before sending the reply } -- | The processing monad @@ -137,6 +93,25 @@ getReply :: WebMonad Reply getReply = get >>= return . wsReply +-- | Return the client's request payload (if any) +getPayload :: WebMonad (Maybe Source) +getPayload = get >>= return . wsBody + +-- | Get the arguments to a POST request +getPOST :: Int -- ^ max number of bytes to read + -> WebMonad (Map.Map B.ByteString B.ByteString) +getPOST maxBytes = do + -- My kingdom for a MaybeT + 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 + +-- | Get the arguments to a GET request +getGET :: WebMonad (Map.Map B.ByteString B.ByteString) +getGET = liftM (URL.rurlArguments . reqUrl) getRequest + -- | 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. @@ -158,6 +133,16 @@ 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' } } } -- | This handles the If-*Matches and If-*Modified conditional headers. It takes -- its information from the Last-Modified and ETag headers of the current @@ -299,131 +284,197 @@ -- stopping directory traversal needs to be done a little carefully. -- Hopefully this is all correct - let path = reqUrl req + let path = map w2c $ B.unpack $ URL.rurlPath $ 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'' + path' = takeWhile (/= chr 0) path + elems = splitDirectories path' -- Remove any '..' elems' = filter (\x -> x /= ".." && x /= "/") elems - ext = takeExtension path'' + ext = takeExtension path' filepath = combine docroot $ joinPath elems' mimeTypes <- get >>= return . wsMimeTypes s <- get - s' <- lift $ catch + 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 $ 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' + 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 = do - let initState = (WebState req mimetypes (Reply 1 1 500 "Server error" emptyHeaders) +pipeline mimetypes action req msource = do + let initState = (WebState req msource mimetypes (Reply 1 1 500 "Server error" emptyHeaders) Nothing Nothing Nothing) - (_, s) <- runStateT (do + (_, s) <- catch ( + runStateT (do action - handleFinal) initState + handleFinal) initState) + (\e -> runStateT (do + errorPage $ show e + 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 +readRequest :: C.Connection + -> IO Request +readRequest conn = readIG conn 256 4096 parseRequest >>= return . fromJust -- | Loop, reading and processing requests -readRequests :: (Request -> IO (Reply, IO SourceResult)) +readRequests :: (Request -> Maybe Source -> 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 +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 - 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 + atomically $ C.writeAtLowWater lowWater conn $ B.concat $ BL.toChunks $ P.runPut $ putReply reply success <- if isNothing $ httpContentLength $ replyHeaders reply - then streamChunked - else stream + then streamSourceChunked lowWater conn source + else streamSource lowWater conn source if not success then C.close conn - else readRequests handler conn rest + else do case body of + Nothing -> return () + Just source -> sourceDrain source + readRequests handler conn -acceptLoop :: Socket -> (Request -> IO (Reply, Source)) -> IO () -acceptLoop acceptingSocket handler = do +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 <- atomically $ C.new newsock (return ()) - C.forkThreads c $ readRequests handler c B.empty - acceptLoop acceptingSocket handler + c <- C.new (return ()) $ C.baseConnectionFromSocket newsock + C.forkInConnection c $ readRequests handler c + acceptLoop handler acceptingSocket -serve :: Int -- ^ the port number to listen on - -> WebMonad () -- ^ the processing action +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 = " Network.MiniHTTP error page
Network.MiniHTTP

An error occured while processing your request:

"
+  tail = "
" + 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 + +-- | This is an, optional, helper function which you might find useful. The +-- serving fuctions both expect a "WebMonad" action which is called to +-- process each request. In general you have to write that and dispatch based +-- on the client's request. +-- +-- This might save you some work: it tries each of the elements in the list +-- in turn. As soon as one matches it runs the given action to process the +-- request. +dispatchOnURL :: [(DispatchMatch, WebMonad ())] + -- ^ the list of URL prefixes (with '/'!) and their actions + -> 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 -- ^ port number + -> (Socket -> IO ()) -- ^ accept loop -> IO () -serve portno action = do - -- Switch these two lines to use IPv6 (which works for IPv4 clients too) +serve portno acceptLoop = do + -- Switch these two lines to use IPv6 (which works for IPv4 clients too). Not + -- all systems support this --acceptingSocket <- socket AF_INET6 Stream 0 - --let sockaddr = SockAddrInet6 (PortNum $ htons $ fromIntegral portno) 0 iN6ADDR_ANY 0 - + --let sockaddr = SockAddrInet6 (fromIntegral portno) 0 iN6ADDR_ANY 0 acceptingSocket <- socket AF_INET Stream 0 - let sockaddr = SockAddrInet (PortNum $ htons $ fromIntegral portno) iNADDR_ANY + let sockaddr = SockAddrInet (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) + -- Ignore SIGPIPE + Signal.installHandler Signal.sigPIPE Signal.Ignore Nothing + + catch (acceptLoop acceptingSocket) (const $ sClose acceptingSocket) + + +-- | Start an IPv4 HTTP server +serveHTTP :: Int -- ^ the port number to listen on + -> WebMonad () -- ^ the processing action + -> IO () +serveHTTP portno action = do + serve portno $ acceptLoop $ pipeline globalMimeTypes action + +-- | Start an IPv4 HTTPS server. Plese remember to have wrapped your main +-- function in 'OpenSSL.withOpenSSL' otherwise you'll probably crash the +-- process. +serveHTTPS :: Int -- ^ the port number to listen on + -> FilePath -- ^ path to public key (certificate) + -> FilePath -- ^ path to private key + -> WebMonad () -- ^ the processing action + -> 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 diff --git a/Network/MiniHTTP/Session.hs b/Network/MiniHTTP/Session.hs new file mode 100644 --- /dev/null +++ b/Network/MiniHTTP/Session.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Basic session support. Sessions are (currently) just maps of strings to +-- strings which are serialised and sent to the client using a Cookie. +-- Serialised, they should be less than 4K, so the sum of all your strings in +-- the map should be < 3900 bytes to be safe. +-- +-- The cookies are HMACed and encrypted so that the client can't inspect nor +-- alter them. The key is, by default, generated randomly every time the +-- server starts. If you want the cookies to be reusable across restarts or +-- servers you need to set the key yourself. +-- +-- Also, by the default, the cookies are set to expire when the browser +-- session ends. +module Network.MiniHTTP.Session + ( getSession + , putSession + , addSession + , setSessionSecretKey + ) where + +import Control.Concurrent.STM +import Control.Monad (forM_) +import Control.Monad.Trans (liftIO) + +import qualified Data.Map as Map +import qualified Data.Binary.Put as P +import qualified Data.Binary.Strict.Get as G +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 () +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Internal (w2c) +import Data.Word (Word32) + +import Network.MiniHTTP.Server +import Network.MiniHTTP.Marshal + +import System.IO.Unsafe (unsafePerformIO) + +import qualified OpenSSL.EVP.Base64 as Base64 +import qualified OpenSSL.EVP.Cipher as Cipher +import qualified OpenSSL.EVP.Digest as Digest +import OpenSSL.Random (randBytes) + +toString :: B.ByteString -> String +toString = map w2c . B.unpack + +secretKey :: TVar B.ByteString +secretKey = unsafePerformIO $ do + rand <- randBytes 16 + newTVarIO rand + +-- | Set the secret key used to HMAC and encrypt the session cookies. +setSessionSecretKey :: B.ByteString -> STM () +setSessionSecretKey = writeTVar secretKey + +sha256 :: Digest.Digest +Just sha256 = unsafePerformIO $ Digest.getDigestByName "SHA256" +aes128 :: Cipher.Cipher +Just aes128 = unsafePerformIO $ Cipher.getCipherByName "AES128" + +parseMap :: G.Get [(B.ByteString, B.ByteString)] +parseMap = do + emptyp <- G.isEmpty + if emptyp + then return [] + else do + keylen <- varInt32 + key <- G.getByteString keylen + valuelen <- varInt32 + value <- G.getByteString valuelen + rest <- parseMap + rest `seq` (return $ (key, value) : rest) + +putMap :: [(B.ByteString, B.ByteString)] -> P.Put +putMap vs = do + forM_ vs $ \(key, value) -> do + putVarInt32 $ B.length key + P.putByteString key + putVarInt32 $ B.length value + P.putByteString value + +decode :: B.ByteString -> IO (Map.Map B.ByteString B.ByteString) +decode bs = do + secret <- atomically $ readTVar secretKey + let bs' = Base64.decodeBase64BS bs + (mac, bs'') = B.splitAt 32 bs' + if Digest.hmacBS sha256 secret bs'' /= mac + then return Map.empty + else do + let (iv, ciphertext) = B.splitAt 16 bs'' + plaintext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Decrypt ciphertext + case G.runGet parseMap plaintext of + (Left _, _) -> return Map.empty + (Right m, _) -> return $ Map.fromList m + +encode :: Map.Map B.ByteString B.ByteString -> IO B.ByteString +encode map = do + secret <- atomically $ readTVar secretKey + iv <- randBytes 16 + let plaintext = B.concat $ BL.toChunks $ P.runPut $ putMap $ Map.toList map + ciphertext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Encrypt plaintext + let bs = iv `B.append` ciphertext + mac = Digest.hmacBS sha256 secret bs + return $ Base64.encodeBase64BS $ mac `B.append` bs + +-- | Return the current session. If the user didn't present a cookie, or the +-- cookie is invalid, an empty map is returned. +getSession :: WebMonad (Map.Map B.ByteString B.ByteString) +getSession = do + req <- getRequest + case filter (\cookie -> cookieName cookie == "nmhs") $ httpCookie $ reqHeaders req of + [] -> return Map.empty + x:_ -> liftIO $ decode $ cookieValue x + +-- | Set the current session. This alters the headers of the current request, +-- so future actions which reset the headers (like 'setReply') will undo +-- this. +putSession :: Map.Map B.ByteString B.ByteString -> WebMonad () +putSession m = do + v <- liftIO $ encode m + setCookie $ emptyCookie { cookieName = "nmhs" + , cookieValue = v + , cookiePath = Just "/" } + +-- | Add a key value pair to the session +addSession :: B.ByteString -> B.ByteString -> WebMonad () +addSession key value = do + s <- getSession + putSession $ Map.insert key value s + +-- | This puts a generic Integral type, but first it casts to a Word32 because +-- it makes a different when it comes to negative numbers. +varInt32 :: (Integral i) => G.Get i +varInt32 = varIntWord32 >>= return . fromIntegral + +varIntWord32 :: G.Get Word32 +varIntWord32 = do + byte <- G.getWord8 + if byte `testBit` 7 + then do rest <- varIntWord32 + return $ (rest `shiftL` 7) .|. (fromIntegral $ byte .&. 0x7f) + else return $ fromIntegral byte + +-- | This puts a generic Integral type, but first it casts to a Word32 because +-- it makes a difference with negative numbers +putVarInt32 :: (Integral i) => i -> P.Put +putVarInt32 = putVarWord32 . fromIntegral + +putVarWord32 :: Word32 -> P.Put +putVarWord32 value + | value < 128 = P.putWord8 $ fromIntegral value + | otherwise = do + P.putWord8 $ 0x80 .|. (fromIntegral $ value .&. 0x7f) + putVarWord32 $ value `shiftR` 7 diff --git a/Network/MiniHTTP/URL.hs b/Network/MiniHTTP/URL.hs new file mode 100644 --- /dev/null +++ b/Network/MiniHTTP/URL.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-} +-- | This module contains a structure for representing web URLs. We don't try +-- to be a fully general URI parser (so no @mailto:@ etc), but it's a lot +-- better than "Network.URI" for dealing with HTTP(S) +module Network.MiniHTTP.URL + ( URL(..) + , RelativeURL(..) + , Scheme(..) + , Host(..) + , toRelative + , parse + , parseRelative + , parseArguments + , serialise + , serialiseRelative + , serialiseArguments + ) where + +import Control.Applicative(Alternative(..)) +import Control.Exception (handle) +import Control.Monad (when, liftM) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Char8 () +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.Binary.Put as P +import qualified Data.Binary.Strict.Class as C +import qualified Data.Binary.Strict.Get as G +import qualified Data.Binary.Strict.ByteSet as BSet +import Data.Char (toLower) +import Data.List (intersperse) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, catMaybes) +import Data.String (fromString) + +import Foreign +import Foreign.C.Types + +import System.IO.Unsafe (unsafePerformIO) + +import Text.Printf (printf) + +import qualified Network.Socket as S + + +-- | A web URL +data URL = URL { urlScheme :: Scheme + , urlUser :: Maybe B.ByteString + , urlPassword :: Maybe B.ByteString + , urlHost :: Host + , urlPort :: Int -- ^ defaults based on the scheme + , urlPath :: B.ByteString -- ^ does not include leading '/' + , urlArguments :: Map.Map B.ByteString B.ByteString + , urlFragment :: Maybe B.ByteString -- ^ doesn't include '#' + } deriving (Eq) + +instance Show URL where + show = map w2c . B.unpack . serialise + +-- | This is a relative URL. It just copies (and renames) the last three +-- members of URL. However, it's good to keep these two different types of +-- URL apart in the type system. +data RelativeURL = RelativeURL { rurlPath :: B.ByteString -- ^ does not include leading '/' + , rurlArguments :: Map.Map B.ByteString B.ByteString + , rurlFragment :: Maybe B.ByteString + } deriving (Show, Eq) + +-- | The transport layer to be used +data Scheme = HTTP | HTTPS deriving (Show, Eq) + +-- | The host where the resource can be found +data Host = IPv4Literal S.HostAddress + | IPv6Literal S.HostAddress6 + | Hostname B.ByteString + deriving (Show, Eq) + +wrapGet :: G.Get a -> B.ByteString -> Maybe a +wrapGet f bs = + case G.runGet f bs of + (Left _, _) -> Nothing + (Right u, _) -> Just u + +-- | Parse a URL +parse :: B.ByteString -> Maybe URL +parse = wrapGet parseURL + +-- | Parse just an arguments map. Can be useful for POST requests. Warning: it +-- occurs to be that the arguments in a POST request might include unescaped +-- '#' symbols. In a URL that would be illegal, but the parser may need to be +-- reworked for that. +parseArguments :: B.ByteString -> Maybe (Map.Map B.ByteString B.ByteString) +parseArguments = fmap Map.fromList . wrapGet parseKVs + +-- | Parse a relative URL +parseRelative :: B.ByteString -> Maybe RelativeURL +parseRelative = wrapGet parseRelativeURL + +-- | Extract a relative URL from a URL +toRelative :: URL -> RelativeURL +toRelative (URL { urlPath = path, urlArguments = args, urlFragment = frag }) = + RelativeURL path args frag + +foreign import ccall unsafe "inet_ntop" + inet_ntop :: CInt -> Ptr Word32 -> Ptr CChar -> CSize -> IO () + +foreign import ccall unsafe "htonl" + htonl :: Word32 -> IO Word32 + +serialiseIPv4 :: S.HostAddress -> B.ByteString +serialiseIPv4 v4 = unsafePerformIO $ do + alloca $ \ptr -> do + poke ptr v4 + allocaBytes 17 $ \str -> do + inet_ntop (S.packFamily S.AF_INET) ptr str 17 + B.packCString str + +serialiseIPv6 :: S.HostAddress6 -> B.ByteString +serialiseIPv6 (a, b, c, d) = unsafePerformIO $ do + allocaArray 4 $ \ptr -> do + mapM htonl [a,b,c,d] >>= pokeArray ptr + allocaBytes 47 $ \str -> do + inet_ntop (S.packFamily S.AF_INET6) ptr str 47 + B.packCString str + +defaultPort :: Scheme -> Int +defaultPort HTTP = 80 +defaultPort HTTPS = 443 + +doPut :: (a -> P.Put) -> a -> B.ByteString +doPut p = B.concat . BL.toChunks . P.runPut . p + +-- | Convert a URL to a ByteString. It's the same as "show", except for the +-- type of the return. +serialise :: URL -> B.ByteString +serialise = doPut putURL + +serialiseRelative :: RelativeURL -> B.ByteString +serialiseRelative = doPut putRelativeURL + +-- | Serialise just an arguments map. Can be useful for POST requests. +serialiseArguments :: Map.Map B.ByteString B.ByteString -> B.ByteString +serialiseArguments = doPut putArguments + +putURL :: URL -> P.Put +putURL url = do + case urlScheme url of + HTTP -> P.putByteString "http" + HTTPS -> P.putByteString "https" + P.putByteString "://" + + maybe (return ()) P.putByteString $ urlUser url + maybe (return ()) (\x -> P.putWord8 (c2w ':') >> P.putByteString x) $ urlPassword url + when (isJust (urlUser url) || isJust (urlPassword url)) $ P.putWord8 $ c2w '@' + + case urlHost url of + IPv4Literal v4 -> P.putByteString $ serialiseIPv4 v4 + IPv6Literal v6 -> do + P.putWord8 $ c2w '[' + P.putByteString $ serialiseIPv6 v6 + P.putWord8 $ c2w ']' + Hostname h -> P.putByteString h + + when (urlPort url /= defaultPort (urlScheme url)) $ do + P.putWord8 $ c2w ':' + P.putByteString $ fromString $ show $ urlPort url + + putRelativeURL $ toRelative url + +putRelativeURL :: RelativeURL -> P.Put +putRelativeURL rurl = do + P.putWord8 $ c2w '/' + P.putByteString $ encodeString pathSafeChars $ rurlPath rurl + when (not $ Map.null $ rurlArguments rurl) $ do + P.putWord8 $ c2w '?' + putArguments $ rurlArguments rurl + maybe (return ()) P.putByteString $ rurlFragment rurl + +putArguments :: Map.Map B.ByteString B.ByteString -> P.Put +putArguments args = do + let f ("", "") = Nothing + f (k, "") = Just $ P.putByteString $ encodeString safeChars k + f (k, v) = Just $ do + P.putByteString $ encodeString safeChars k + P.putWord8 $ c2w '=' + P.putByteString $ encodeString safeChars v + let vs = flip map (Map.toList args) f + sequence_ $ intersperse (P.putWord8 $ c2w '&') $ catMaybes vs + +digits :: BSet.ByteSet +digits = BSet.range (c2w '0') (c2w '9') + +hexChars :: BSet.ByteSet +hexChars = BSet.fromList $ map c2w "0123456789abcdefABCDEF" + +isHexChar :: Word8 -> Bool +isHexChar = BSet.member hexChars + +-- | The list of unsafe charactors in a URL, from RFC 1738 +unsafeChars :: BSet.ByteSet +unsafeChars = BSet.range 0 0x1f `BSet.union` + BSet.range 0x7f 0xff `BSet.union` + BSet.fromList (map c2w "$&+,/:;=?@ \"<>#%{}[]|\\^~`") + +-- | Bytes which aren't unsafe, are safe. +safeChars :: BSet.ByteSet +safeChars = BSet.complement unsafeChars + +-- | These are the charactors which are safe in a path +pathSafeChars :: BSet.ByteSet +pathSafeChars = safeChars `BSet.union` BSet.singleton (c2w '/') + +-- | Parse a single key, value pair +parseKV :: G.Get (B.ByteString, B.ByteString) +parseKV = do + key <- C.spanOf (\x -> x /= c2w '#' && x /= c2w '=' && x /= c2w '&') + value <- C.optional $ do + C.word8 $ c2w '=' + C.spanOf (\x -> x /= c2w '#' && x /= c2w '&') + + return (decodeString key, decodeString $ fromMaybe "" value) + +-- | Parse a set of URL encoded key, value pairs. +parseKVs :: G.Get [(B.ByteString, B.ByteString)] +parseKVs = do + first <- parseKV + rest <- C.many $ (C.word8 $ c2w '&') >> parseKV + + return $ first : rest + +parseIPv6 :: G.Get B.ByteString +parseIPv6 = do + C.word8 $ c2w '[' + s <- C.spanOf1 (/= c2w ']') + C.word8 $ c2w ']' + + return s + +toString :: B.ByteString -> String +toString = map w2c . B.unpack + +parseRelativeURL :: G.Get RelativeURL +parseRelativeURL = do + emptyp <- C.isEmpty + if emptyp + then return $ RelativeURL "" Map.empty Nothing + else do + C.word8 $ c2w '/' + path <- C.spanOf (\x -> x /= c2w '?' && x /= c2w '#') + margs <- C.optional $ do + C.word8 $ c2w '?' + liftM Map.fromList parseKVs + mfrag <- C.optional $ do + C.word8 $ c2w '#' + rem <- C.remaining + C.getByteString rem + + emptyp <- C.isEmpty + when (not emptyp) $ fail "Trailing garbage" + + return $ RelativeURL path (fromMaybe Map.empty margs) mfrag + +parseURL :: G.Get URL +parseURL = do + scheme' <- C.spanOf1 (/= c2w ':') + scheme <- case map (toLower . w2c) $ B.unpack scheme' of + "http" -> return HTTP + "https" -> return HTTPS + _ -> fail "Unknown scheme" + C.string "://" + + muserpw <- C.optional $ do + user <- C.spanOf (\x -> x /= c2w '@' && x /= c2w ':') + pw <- C.optional $ do + C.word8 $ c2w ':' + C.spanOf (/= c2w '@') + C.word8 $ c2w '@' + return (user, pw) + + host' <- parseIPv6 <|> C.spanOf1 (\x -> x /= c2w ':' && x /= c2w '/') + + mhost <- return $ unsafePerformIO $ handle (const $ return Nothing) $ do + ai <- S.getAddrInfo (Just (S.defaultHints { S.addrFlags = [S.AI_NUMERICHOST] })) + (Just $ toString host') Nothing + case ai of + [] -> return Nothing + ai:_ -> + case S.addrFamily ai of + S.AF_INET -> + case S.addrAddress ai of + (S.SockAddrInet _ host) -> return $ Just $ IPv4Literal host + _ -> return Nothing + S.AF_INET6 -> + case S.addrAddress ai of + (S.SockAddrInet6 _ _ host _) -> return $ Just $ IPv6Literal host + _ -> return Nothing + _ -> return Nothing + + mport <- C.optional $ do + C.word8 $ c2w ':' + s <- C.spanOf1 $ BSet.member digits + case reads $ map w2c $ B.unpack s of + [(x, "")] -> + if x > 0 && x < 65536 + then return x + else fail "Port number out of range" + _ -> fail "Invalid port number" + + rurl <- parseRelativeURL + + let url = URL { urlScheme = scheme + , urlHost = case mhost of + Just h -> h + Nothing -> Hostname host' + , urlPort = case mport of + Just p -> p + Nothing -> defaultPort scheme + , urlPath = rurlPath rurl + , urlArguments = rurlArguments rurl + , urlFragment = rurlFragment rurl + , urlUser = Nothing + , urlPassword = Nothing } + url'' = case muserpw of + Just (user, mpw) -> url { urlUser = Just user + , urlPassword = mpw } + Nothing -> url + + return url'' + +toHexNibble :: Word8 -> Word8 +toHexNibble 0x30 = 0 +toHexNibble 0x31 = 1 +toHexNibble 0x32 = 2 +toHexNibble 0x33 = 3 +toHexNibble 0x34 = 4 +toHexNibble 0x35 = 5 +toHexNibble 0x36 = 6 +toHexNibble 0x37 = 7 +toHexNibble 0x38 = 8 +toHexNibble 0x39 = 9 +toHexNibble 0x41 = 10 +toHexNibble 0x42 = 11 +toHexNibble 0x43 = 12 +toHexNibble 0x44 = 13 +toHexNibble 0x45 = 14 +toHexNibble 0x46 = 15 +toHexNibble 0x61 = 10 +toHexNibble 0x62 = 11 +toHexNibble 0x63 = 12 +toHexNibble 0x64 = 13 +toHexNibble 0x65 = 14 +toHexNibble 0x66 = 15 +toHexNibble _ = error "toHexNibble passed non-hex char" + +toHexByte :: B.ByteString -> Word8 +toHexByte bs = (toHexNibble (bs `B.index` 0) `shiftL` 4) .|. + (toHexNibble (bs `B.index` 1)) + +-- | Replace any % escaped bytes in the given string with their Word8 values. +decodePercents :: B.ByteString -> B.ByteString +decodePercents bs = f (left, right) where + (left, right) = B.span (/= c2w '%') bs + f (left, right) + | B.null right = left + | B.length right >= 3 && + isHexChar (right `B.index` 1) && + isHexChar (right `B.index` 2) = + left `B.append` B.singleton (toHexByte $ B.tail $ B.take 3 right) `B.append` decodeString (B.drop 3 right) + | otherwise = bs + +-- | Replace pluses in the given string with spaces and then perform percent +-- decoding. +decodeString :: B.ByteString -> B.ByteString +decodeString = decodePercents . B.map f where + f 0x2b = 0x20 + f x = x + +-- | Percent encode any unsafe bytes in the given string +encodeString :: BSet.ByteSet -> B.ByteString -> B.ByteString +encodeString safeChars bs = f (left, right) where + (left, right) = B.span (BSet.member safeChars) bs + f (left, right) + | B.null right = left + | otherwise = left `B.append` escaped `B.append` encodeString safeChars right' where + right' = B.tail right + unsafe = B.head right + escaped = B.pack $ map c2w $ printf "%%%X" ((fromIntegral unsafe) :: Int) diff --git a/examples/css/ie.css b/examples/css/ie.css new file mode 100644 --- /dev/null +++ b/examples/css/ie.css @@ -0,0 +1,22 @@ +/* ----------------------------------------------------------------------- + + Blueprint CSS Framework 0.7.1 + http://blueprintcss.googlecode.com + + * Copyright (c) 2007-2008. See LICENSE for more info. + * See README for instructions on how to use Blueprint. + * For credits and origins, see AUTHORS. + * This is a compressed file. See the sources in the 'src' directory. + +----------------------------------------------------------------------- */ + +/* ie.css */ +body {text-align:center;} +.container {text-align:left;} +* html .column {overflow-x:hidden;} +* html legend {margin:-18px -8px 16px 0;padding:0;} +ol {margin-left:2em;} +sup {vertical-align:text-top;} +sub {vertical-align:text-bottom;} +html>body p code {*white-space:normal;} +hr {margin:-8px auto 11px;} diff --git a/examples/css/print.css b/examples/css/print.css new file mode 100644 --- /dev/null +++ b/examples/css/print.css @@ -0,0 +1,29 @@ +/* ----------------------------------------------------------------------- + + Blueprint CSS Framework 0.7.1 + http://blueprintcss.googlecode.com + + * Copyright (c) 2007-2008. See LICENSE for more info. + * See README for instructions on how to use Blueprint. + * For credits and origins, see AUTHORS. + * This is a compressed file. See the sources in the 'src' directory. + +----------------------------------------------------------------------- */ + +/* print.css */ +body {line-height:1.5;font-family:"Helvetica Neue", Helvetica, Arial, sans-serif;color:#000;background:none;font-size:10pt;} +.container {background:none;} +hr {background:#ccc;color:#ccc;width:100%;height:2px;margin:2em 0;padding:0;border:none;} +hr.space {background:#fff;color:#fff;} +h1, h2, h3, h4, h5, h6 {font-family:"Helvetica Neue", Arial, "Lucida Grande", sans-serif;} +code {font:.9em "Courier New", Monaco, Courier, monospace;} +img {float:left;margin:1.5em 1.5em 1.5em 0;} +a img {border:none;} +p img.top {margin-top:0;} +blockquote {margin:1.5em;padding:1em;font-style:italic;font-size:.9em;} +.small {font-size:.9em;} +.large {font-size:1.1em;} +.quiet {color:#999;} +.hide {display:none;} +a:link, a:visited {background:transparent;font-weight:700;text-decoration:underline;} +a:link:after, a:visited:after {content:" (" attr(href) ") ";font-size:90%;} diff --git a/examples/css/screen.css b/examples/css/screen.css new file mode 100644 --- /dev/null +++ b/examples/css/screen.css @@ -0,0 +1,226 @@ +/* ----------------------------------------------------------------------- + + Blueprint CSS Framework 0.7.1 + http://blueprintcss.googlecode.com + + * Copyright (c) 2007-2008. See LICENSE for more info. + * See README for instructions on how to use Blueprint. + * For credits and origins, see AUTHORS. + * This is a compressed file. See the sources in the 'src' directory. + +----------------------------------------------------------------------- */ + +/* reset.css */ +html, body, div, span, object, iframe, h1, h2, h3, h4, h5, h6, p, blockquote, pre, a, abbr, acronym, address, code, del, dfn, em, img, q, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, caption, tbody, tfoot, thead, tr, th, td {margin:0;padding:0;border:0;font-weight:inherit;font-style:inherit;font-size:100%;font-family:inherit;vertical-align:baseline;} +body {line-height:1.5;} +table {border-collapse:separate;border-spacing:0;} +caption, th, td {text-align:left;font-weight:normal;} +table, td, th {vertical-align:middle;} +blockquote:before, blockquote:after, q:before, q:after {content:"";} +blockquote, q {quotes:"" "";} +a img {border:none;} + +/* typography.css */ +body {font-size:75%;color:#222;background:#fff;font-family:"Helvetica Neue", Helvetica, Arial, sans-serif;} +h1, h2, h3, h4, h5, h6 {font-weight:normal;color:#111;} +h1 {font-size:3em;line-height:1;margin-bottom:0.5em;} +h2 {font-size:2em;margin-bottom:0.75em;} +h3 {font-size:1.5em;line-height:1;margin-bottom:1em;} +h4 {font-size:1.2em;line-height:1.25;margin-bottom:1.25em;height:1.25em;} +h5 {font-size:1em;font-weight:bold;margin-bottom:1.5em;} +h6 {font-size:1em;font-weight:bold;} +h1 img, h2 img, h3 img, h4 img, h5 img, h6 img {margin:0;} +p {margin:0 0 1.5em;} +p img {float:left;margin:1.5em 1.5em 1.5em 0;padding:0;} +p img.right {float:right;margin:1.5em 0 1.5em 1.5em;} +a:focus, a:hover {color:#000;} +a {color:#009;text-decoration:underline;} +blockquote {margin:1.5em;color:#666;font-style:italic;} +strong {font-weight:bold;} +em, dfn {font-style:italic;} +dfn {font-weight:bold;} +sup, sub {line-height:0;} +abbr, acronym {border-bottom:1px dotted #666;} +address {margin:0 0 1.5em;font-style:italic;} +del {color:#666;} +pre, code {margin:1.5em 0;white-space:pre;} +pre, code, tt {font:1em 'andale mono', 'lucida console', monospace;line-height:1.5;} +li ul, li ol {margin:0 1.5em;} +ul, ol {margin:0 1.5em 1.5em 1.5em;} +ul {list-style-type:disc;} +ol {list-style-type:decimal;} +dl {margin:0 0 1.5em 0;} +dl dt {font-weight:bold;} +dd {margin-left:1.5em;} +table {margin-bottom:1.4em;width:100%;} +th {font-weight:bold;background:#C3D9FF;} +th, td {padding:4px 10px 4px 5px;} +tr.even td {background:#E5ECF9;} +tfoot {font-style:italic;} +caption {background:#eee;} +.small {font-size:.8em;margin-bottom:1.875em;line-height:1.875em;} +.large {font-size:1.2em;line-height:2.5em;margin-bottom:1.25em;} +.hide {display:none;} +.quiet {color:#666;} +.loud {color:#000;} +.highlight {background:#ff0;} +.added {background:#060;color:#fff;} +.removed {background:#900;color:#fff;} +.first {margin-left:0;padding-left:0;} +.last {margin-right:0;padding-right:0;} +.top {margin-top:0;padding-top:0;} +.bottom {margin-bottom:0;padding-bottom:0;} + +/* grid.css */ +.container {width:950px;margin:0 auto;} +.showgrid {background:url(src/grid.png);} +body {margin:1.5em 0;} +div.span-1, div.span-2, div.span-3, div.span-4, div.span-5, div.span-6, div.span-7, div.span-8, div.span-9, div.span-10, div.span-11, div.span-12, div.span-13, div.span-14, div.span-15, div.span-16, div.span-17, div.span-18, div.span-19, div.span-20, div.span-21, div.span-22, div.span-23, div.span-24 {float:left;margin-right:10px;} +div.last {margin-right:0;} +.span-1 {width:30px;} +.span-2 {width:70px;} +.span-3 {width:110px;} +.span-4 {width:150px;} +.span-5 {width:190px;} +.span-6 {width:230px;} +.span-7 {width:270px;} +.span-8 {width:310px;} +.span-9 {width:350px;} +.span-10 {width:390px;} +.span-11 {width:430px;} +.span-12 {width:470px;} +.span-13 {width:510px;} +.span-14 {width:550px;} +.span-15 {width:590px;} +.span-16 {width:630px;} +.span-17 {width:670px;} +.span-18 {width:710px;} +.span-19 {width:750px;} +.span-20 {width:790px;} +.span-21 {width:830px;} +.span-22 {width:870px;} +.span-23 {width:910px;} +.span-24, div.span-24 {width:950px;margin:0;} +.append-1 {padding-right:40px;} +.append-2 {padding-right:80px;} +.append-3 {padding-right:120px;} +.append-4 {padding-right:160px;} +.append-5 {padding-right:200px;} +.append-6 {padding-right:240px;} +.append-7 {padding-right:280px;} +.append-8 {padding-right:320px;} +.append-9 {padding-right:360px;} +.append-10 {padding-right:400px;} +.append-11 {padding-right:440px;} +.append-12 {padding-right:480px;} +.append-13 {padding-right:520px;} +.append-14 {padding-right:560px;} +.append-15 {padding-right:600px;} +.append-16 {padding-right:640px;} +.append-17 {padding-right:680px;} +.append-18 {padding-right:720px;} +.append-19 {padding-right:760px;} +.append-20 {padding-right:800px;} +.append-21 {padding-right:840px;} +.append-22 {padding-right:880px;} +.append-23 {padding-right:920px;} +.prepend-1 {padding-left:40px;} +.prepend-2 {padding-left:80px;} +.prepend-3 {padding-left:120px;} +.prepend-4 {padding-left:160px;} +.prepend-5 {padding-left:200px;} +.prepend-6 {padding-left:240px;} +.prepend-7 {padding-left:280px;} +.prepend-8 {padding-left:320px;} +.prepend-9 {padding-left:360px;} +.prepend-10 {padding-left:400px;} +.prepend-11 {padding-left:440px;} +.prepend-12 {padding-left:480px;} +.prepend-13 {padding-left:520px;} +.prepend-14 {padding-left:560px;} +.prepend-15 {padding-left:600px;} +.prepend-16 {padding-left:640px;} +.prepend-17 {padding-left:680px;} +.prepend-18 {padding-left:720px;} +.prepend-19 {padding-left:760px;} +.prepend-20 {padding-left:800px;} +.prepend-21 {padding-left:840px;} +.prepend-22 {padding-left:880px;} +.prepend-23 {padding-left:920px;} +div.border {padding-right:4px;margin-right:5px;border-right:1px solid #eee;} +div.colborder {padding-right:24px;margin-right:25px;border-right:1px solid #eee;} +.pull-1 {margin-left:-40px;} +.pull-2 {margin-left:-80px;} +.pull-3 {margin-left:-120px;} +.pull-4 {margin-left:-160px;} +.pull-5 {margin-left:-200px;} +.pull-6 {margin-left:-240px;} +.pull-7 {margin-left:-280px;} +.pull-8 {margin-left:-320px;} +.pull-9 {margin-left:-360px;} +.pull-10 {margin-left:-400px;} +.pull-11 {margin-left:-440px;} +.pull-12 {margin-left:-480px;} +.pull-13 {margin-left:-520px;} +.pull-14 {margin-left:-560px;} +.pull-15 {margin-left:-600px;} +.pull-16 {margin-left:-640px;} +.pull-17 {margin-left:-680px;} +.pull-18 {margin-left:-720px;} +.pull-19 {margin-left:-760px;} +.pull-20 {margin-left:-800px;} +.pull-21 {margin-left:-840px;} +.pull-22 {margin-left:-880px;} +.pull-23 {margin-left:-920px;} +.pull-24 {margin-left:-960px;} +.pull-1, .pull-2, .pull-3, .pull-4, .pull-5, .pull-6, .pull-7, .pull-8, .pull-9, .pull-10, .pull-11, .pull-12, .pull-13, .pull-14, .pull-15, .pull-16, .pull-17, .pull-18, .pull-19, .pull-20, .pull-21, .pull-22, .pull-23, .pull-24 {float:left;position:relative;} +.push-1 {margin:0 -40px 1.5em 40px;} +.push-2 {margin:0 -80px 1.5em 80px;} +.push-3 {margin:0 -120px 1.5em 120px;} +.push-4 {margin:0 -160px 1.5em 160px;} +.push-5 {margin:0 -200px 1.5em 200px;} +.push-6 {margin:0 -240px 1.5em 240px;} +.push-7 {margin:0 -280px 1.5em 280px;} +.push-8 {margin:0 -320px 1.5em 320px;} +.push-9 {margin:0 -360px 1.5em 360px;} +.push-10 {margin:0 -400px 1.5em 400px;} +.push-11 {margin:0 -440px 1.5em 440px;} +.push-12 {margin:0 -480px 1.5em 480px;} +.push-13 {margin:0 -520px 1.5em 520px;} +.push-14 {margin:0 -560px 1.5em 560px;} +.push-15 {margin:0 -600px 1.5em 600px;} +.push-16 {margin:0 -640px 1.5em 640px;} +.push-17 {margin:0 -680px 1.5em 680px;} +.push-18 {margin:0 -720px 1.5em 720px;} +.push-19 {margin:0 -760px 1.5em 760px;} +.push-20 {margin:0 -800px 1.5em 800px;} +.push-21 {margin:0 -840px 1.5em 840px;} +.push-22 {margin:0 -880px 1.5em 880px;} +.push-23 {margin:0 -920px 1.5em 920px;} +.push-24 {margin:0 -960px 1.5em 960px;} +.push-1, .push-2, .push-3, .push-4, .push-5, .push-6, .push-7, .push-8, .push-9, .push-10, .push-11, .push-12, .push-13, .push-14, .push-15, .push-16, .push-17, .push-18, .push-19, .push-20, .push-21, .push-22, .push-23, .push-24 {float:right;position:relative;} +.box {padding:1.5em;margin-bottom:1.5em;background:#E5ECF9;} +hr {background:#ddd;color:#ddd;clear:both;float:none;width:100%;height:.1em;margin:0 0 1.45em;border:none;} +hr.space {background:#fff;color:#fff;} +.clearfix:after, .container:after {content:".";display:block;height:0;clear:both;visibility:hidden;} +.clearfix, .container {display:inline-block;} +* html .clearfix, * html .container {height:1%;} +.clearfix, .container {display:block;} +.clear {clear:both;} + +/* forms.css */ +label {font-weight:bold;} +fieldset {padding:1.4em;margin:0 0 1.5em 0;border:1px solid #ccc;} +legend {font-weight:bold;font-size:1.2em;} +input.text, input.title, textarea, select {margin:0.5em 0;border:1px solid #bbb;} +input.text:focus, input.title:focus, textarea:focus, select:focus {border:1px solid #666;} +input.text, input.title {width:300px;padding:5px;} +input.title {font-size:1.5em;} +textarea {width:390px;height:250px;padding:5px;} +.error, .notice, .success {padding:.8em;margin-bottom:1em;border:2px solid #ddd;} +.error {background:#FBE3E4;color:#8a1f11;border-color:#FBC2C4;} +.notice {background:#FFF6BF;color:#514721;border-color:#FFD324;} +.success {background:#E6EFC2;color:#264409;border-color:#C6D880;} +.error a {color:#8a1f11;} +.notice a {color:#514721;} +.success a {color:#264409;} diff --git a/examples/example.tmpl b/examples/example.tmpl new file mode 100644 --- /dev/null +++ b/examples/example.tmpl @@ -0,0 +1,116 @@ + + + + + + + + + +
+ + +
+

Session support

+ +

Sessions, at the moment, are serialised, encrypted, signed and + stored in cookies on the user's browser. In MiniHTTP they are + availible as a Map with bytestrings as the keys and values.

+ +

Here's the current value of your session:

+ 
{{SESSION:h}}
+ +

You can set a value using the following form:

+ +
+ + +
+ +

Templating

+ +

Templating is up to the user, nothing is built into + MiniHTTP, however this code is using ctemplate, + which is Google's internal templating system. It's pretty basic + compared to other templating systems (which the reader may take to be + a virtue or a deficiency), but it does escaping very well.

+ +

The wrapper still needs a little efficiency work, but is currently + functional (as you can see). Due to ctemplate being a C++ library, you + appear to need to compile anything which uses it; ghci will + fail in glibc.

+ +

OpenID

+ +

My initial test of the code was to write an OpenID consumer. This + involves both server and client HTTP code. It's currently fairly + functional, though incomplete. I only have an account with + MyOpenID.com, so I've not tested it with anything else.

+ +

For the moment, the input must be a valid URL. So don't forget + the http:// at the beginning.

+ +

Once you have logged in, you should see your OpenID in the session + output, above.

+ +
+ + +
+ +

HTTPS support

+ +

Running an HTTPS server is as easy as running an HTTP server (as + long as you have the certificate and private key in the correct + format). However, it's been known to tickle a bug which causes the RTS + to fall into an infinite loop.

+ +

HTTPS client support is comming.

+ +
+
+ + diff --git a/examples/fileserver.hs b/examples/fileserver.hs deleted file mode 100644 --- a/examples/fileserver.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | 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 --- ... diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad.State.Strict + +import qualified Data.ByteString as B +import Data.ByteString.Char8 () +import qualified Data.Map as Map + +import Network.MiniHTTP.Server +import Network.MiniHTTP.Marshal +import Network.MiniHTTP.HTTPConnection +import Network.MiniHTTP.Session +import qualified Network.MiniHTTP.OpenID as OpenID +import qualified Network.MiniHTTP.Session as Session +import qualified Network.MiniHTTP.URL as URL +import qualified Text.CTemplate as T + +import qualified OpenSSL as SSL + +handleFromTemplate :: T.Dictionary -> WebMonad () +handleFromTemplate tmpl = do + Just r <- lift $ T.expand T.DontStrip tmpl + source <- lift $ bsSource r + setReply 200 + s <- get + put $ s { wsSource = Just source } + setHeader $ \h -> h { httpContentLength = Just $ fromIntegral $ B.length r } + +index :: WebMonad () +index = do + session <- getSession + handleFromTemplate $ T.Dictionary "example.tmpl" [("SESSION", T.StringV $ show session)] + setHeader $ \h -> h { httpOtherHeaders = Map.fromList [("Cache-Control", "private")] } + +setSession :: WebMonad () +setSession = do + postValues <- getPOST 1024 + setReply 301 + case Map.lookup "name" postValues of + Nothing -> return () + Just name -> addSession "name" name + setHeader $ \h -> h { httpLocation = Just "/" } + +openIDLogin :: WebMonad () +openIDLogin = do + postValues <- getPOST 1024 + id <- Map.lookup "id" postValues + let Just uri = URL.parse id + discovery <- liftIO $ OpenID.discover uri + (handle, _) <- liftIO $ OpenID.associate discovery + setReply 302 + let url = OpenID.checkID OpenID.CheckIDSetup uri discovery handle "http://localhost.com/openidreturn" Nothing + setHeader (\h -> h { httpLocation = Just $ URL.serialise url }) + +openIDReturn :: WebMonad () +openIDReturn = do + args <- getGET + r <- liftIO $ OpenID.processCheckIDReply args + case r of + Left error -> errorPage error + Right id -> do + setReply 301 + addSession "openid" id + setHeader $ \h -> h { httpLocation = Just "/" } + +handleFile :: WebMonad () +handleFile = do + handleFromFilesystem "css/" + handleConditionalRequest + handleRangeRequests + handleHandleToSource + handleDecoration + +main' :: IO () +main' = serveHTTP 4112 $ dispatchOnURL + [ (Exact "", index), (Exact "setsession", setSession) + , (Exact "openidlogin", openIDLogin), (Exact "openidreturn", openIDReturn) + , (Prefix "", handleFile)] + +main :: IO () +main = SSL.withOpenSSL main' diff --git a/examples/webcat.hs b/examples/webcat.hs new file mode 100644 --- /dev/null +++ b/examples/webcat.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Data.ByteString.Lazy as BL +import Data.String (fromString) + +import qualified Network.Connection as C +import qualified Network.MiniHTTP.Client as Client +import qualified Network.MiniHTTP.URL as URL +import Network.MiniHTTP.Marshal (emptyHeaders) +import Network.MiniHTTP.HTTPConnection (sourceToLBS) + +import OpenSSL (withOpenSSL) + +import System.Environment (getArgs) + +main = withOpenSSL main' + +main' = do + args <- getArgs + case args of + [urlstring] -> do + case URL.parse $ fromString urlstring of + Nothing -> fail "Cannot parse URL" + Just url -> do + (conn, reply, msource) <- Client.fetchBasic emptyHeaders url + print reply + case msource of + Nothing -> C.close conn + Just source -> do + lbs <- sourceToLBS source + BL.putStr lbs + C.close conn + _ -> fail "Please give a URL as the only argument" diff --git a/network-minihttp.cabal b/network-minihttp.cabal --- a/network-minihttp.cabal +++ b/network-minihttp.cabal @@ -1,18 +1,29 @@ name: network-minihttp -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE author: Adam Langley -description: A very minimal webserver -synopsis: A very minimal webserver +description: A ByteString based HTTP(S) library +synopsis: A ByteString based library for writing HTTP(S) servers and clients. +homepage: http://darcs.imperialviolet.org/network-minihttp 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 +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, HsOpenSSL>=0.4.1, network-connection>=0.1, network-dns>=0.1.2, tagsoup>=0.5 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 + Network.MiniHTTP.Marshal, + Network.MiniHTTP.Client, + Network.MiniHTTP.HTTPConnection, + Network.MiniHTTP.OpenID, + Network.MiniHTTP.Session, + Network.MiniHTTP.URL +other-modules: Network.MiniHTTP.MimeTypesParse +extra-source-files: examples/test.hs, + examples/example.tmpl, + examples/css/screen.css, + examples/css/print.css, + examples/css/ie.css + examples/webcat.hs ghc-options: -Wall -fno-warn-name-shadowing extensions: OverloadedStrings +build-type: Simple