tighttp (empty) → 0.0.0.0
raw patch · 17 files changed
+1350/−0 lines, 17 filesdep +basedep +bytestringdep +handle-likesetup-changed
Dependencies added: base, bytestring, handle-like, monads-tf, old-locale, papillon, simple-pipe, time
Files
- LICENSE +27/−0
- Setup.hs +1/−0
- examples/get.hs +21/−0
- examples/gets.hs +35/−0
- examples/post.hs +24/−0
- examples/posts.hs +31/−0
- examples/server.hs +24/−0
- examples/serverp.hs +32/−0
- examples/serverps.hs +44/−0
- examples/servers.hs +37/−0
- src/Network/TigHTTP/Client.hs +120/−0
- src/Network/TigHTTP/HttpTypes.hs +564/−0
- src/Network/TigHTTP/Papillon.hs +134/−0
- src/Network/TigHTTP/Server.hs +88/−0
- src/Network/TigHTTP/Token.hs +19/−0
- src/Network/TigHTTP/Types.hs +30/−0
- tighttp.cabal +119/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ * Neither the name of the Yoshikuni Jujo nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,1 @@+import Distribution.Simple; main = defaultMain
+ examples/get.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE PackageImports #-}++import "monads-tf" Control.Monad.Trans+import Data.Pipe+import System.Environment+import Network+import Network.TigHTTP.Client+import Network.TigHTTP.Types++import qualified Data.ByteString as BS++main :: IO ()+main = do+ addr : pth : _ <- getArgs+ h <- connectTo addr $ PortNumber 80+ r <- request h $ get addr 80 pth+ _ <- runPipe $ responseBody r =$= finally printP (putStrLn "")+ return ()++printP :: MonadIO m => Pipe BS.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BS.putStr s) >> printP)
+ examples/gets.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import System.Environment+import Data.Pipe+import Network+import Network.TigHTTP.Client+import Network.TigHTTP.Types+import Network.PeyoTLS.ReadFile+import "crypto-random" Crypto.Random++import qualified Data.ByteString as BS+import qualified Network.PeyoTLS.Client as P++main :: IO ()+main = do+ addr : pth : _ <- getArgs+ ca <- readCertificateStore [+ "cacert.sample_pem",+ "/etc/ssl/certs/GeoTrust_Global_CA.pem",+ "/etc/ssl/certs/DigiCert_High_Assurance_EV_Root_CA.pem",+ "/etc/ssl/certs/GlobalSign_Root_CA.pem" ]+ h <- connectTo addr $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ (`P.run` g) $ do+ t <- P.open' h addr ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ P.getNames t >>= liftIO . print+ p <- request t $ get addr 443 pth+ void . runPipe $+ responseBody p =$= (printP `finally` liftIO (putStrLn ""))++printP :: MonadIO m => Pipe BS.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BS.putStr s) >> printP)
+ examples/post.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE PackageImports #-}++import Control.Monad+import "monads-tf" Control.Monad.Trans+import System.Environment+import Data.Pipe+import Network+import Network.TigHTTP.Client+import Network.TigHTTP.Types++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ addr : pth : msgs <- getArgs+ let msg = LBS.fromChunks $ map BSC.pack msgs+ h <- connectTo addr $ PortNumber 80+ r <- request h $ post addr 80 pth+ (Just . fromIntegral $ LBS.length msg, msg)+ void . runPipe $ responseBody r =$= (printP `finally` putStrLn "")++printP :: MonadIO m => Pipe BSC.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BSC.putStr s) >> printP)
+ examples/posts.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings, TupleSections, PackageImports #-}++import Control.Applicative+import Control.Monad+import "monads-tf" Control.Monad.Trans+import Data.Pipe+import System.Environment+import Network+import Network.PeyoTLS.Client+import Network.PeyoTLS.ReadFile+import Network.TigHTTP.Client+import Network.TigHTTP.Types+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ addr : pth : msgs <- getArgs+ ca <- readCertificateStore ["cacert.sample_pem"]+ h <- connectTo addr $ PortNumber 443+ g <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ void . (`run` g) $ do+ t <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [] ca+ r <- request t . post addr 443 pth . (Nothing ,) .+ LBS.fromChunks $ map BSC.pack msgs+ runPipe $ responseBody r =$= printP++printP :: MonadIO m => Pipe BSC.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BSC.putStr s) >> printP)
+ examples/server.hs view
@@ -0,0 +1,24 @@+import Control.Monad+import Control.Concurrent+import Data.Pipe+import System.IO+import System.Environment+import Network+import Network.TigHTTP.Server+import Network.TigHTTP.Types++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ as <- getArgs+ soc <- listenOn $ PortNumber 80+ forever $ do+ (h, _, _) <- accept soc+ void . forkIO $ do+ req <- getRequest h+ print $ requestPath req+ putResponse h+ . (response :: LBS.ByteString -> Response Pipe Handle)+ . LBS.fromChunks $ map BSC.pack as
+ examples/serverp.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE PackageImports #-}++import Control.Monad+import "monads-tf" Control.Monad.Trans+import Control.Concurrent+import Data.Pipe+import System.IO+import System.Environment+import Network+import Network.TigHTTP.Server+import Network.TigHTTP.Types++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ as <- getArgs+ soc <- listenOn $ PortNumber 80+ forever $ do+ (h, _, _) <- accept soc+ void . forkIO $ do+ r <- getRequest h+ print $ requestPath r+ void . runPipe $+ requestBody r =$= printP `finally` putStrLn ""+ putResponse h+ . (response :: LBS.ByteString -> Response Pipe Handle)+ . LBS.fromChunks $ map BSC.pack as++printP :: MonadIO m => Pipe BSC.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BSC.putStr s) >> printP)
+ examples/serverps.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import Data.Pipe+import System.IO+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import Network.TigHTTP.Server+import Network.TigHTTP.Types+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ as <- getArgs+ k <- readKey "localhost.sample_key"+ c <- readCertificateChain ["localhost.sample_crt"]+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ void . liftIO . forkIO . (`run` g) $ do+ t <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ Nothing+ r <- getRequest t+ liftIO . print $ requestPath r+ void . runPipe $+ requestBody r =$= (printP `finally` liftIO (putStrLn ""))+ putResponse t+ . (response :: LBS.ByteString ->+ Response Pipe (TlsHandle Handle SystemRNG))+ . LBS.fromChunks $ map BSC.pack as+ hlClose t++printP :: MonadIO m => Pipe BSC.ByteString () m ()+printP = await >>= maybe (return ()) (\s -> liftIO (BSC.putStr s) >> printP)
+ examples/servers.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++import Control.Applicative+import "monads-tf" Control.Monad.State+import Control.Concurrent+import Data.HandleLike+import Data.Pipe+import System.IO+import System.Environment+import Network+import Network.PeyoTLS.Server+import Network.PeyoTLS.ReadFile+import Network.TigHTTP.Server+import Network.TigHTTP.Types+import "crypto-random" Crypto.Random++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS++main :: IO ()+main = do+ as <- getArgs+ k <- readKey "localhost.sample_key"+ c <- readCertificateChain ["localhost.sample_crt"]+ g0 <- cprgCreate <$> createEntropyPool :: IO SystemRNG+ soc <- listenOn $ PortNumber 443+ void . (`runStateT` g0) . forever $ do+ (h, _, _) <- liftIO $ accept soc+ g <- StateT $ return . cprgFork+ void . liftIO . forkIO . (`run` g) $ do+ t <- open h ["TLS_RSA_WITH_AES_128_CBC_SHA"] [(k, c)]+ Nothing+ _ <- getRequest t+ putResponse t+ . (response :: LBS.ByteString -> Response Pipe (TlsHandle Handle SystemRNG))+ . LBS.fromChunks $ map BSC.pack as+ hlClose t
+ src/Network/TigHTTP/Client.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, PackageImports #-}++module Network.TigHTTP.Client (request, get, post) where++import Control.Applicative+import Control.Arrow hiding ((+++))+import Control.Monad+import "monads-tf" Control.Monad.State (lift, MonadTrans)+import Data.Pipe+import Data.Pipe.List+import Numeric++import Network.TigHTTP.HttpTypes+import Data.HandleLike++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBSC++request, httpGet :: (+ PipeClass p, MonadTrans (p () BS.ByteString),+ Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h ) =>+ h -> Request h -> HandleMonad h (Response p h)+request = httpGet+httpGet sv req = do+ putRequest sv req+ src <- hGetHeader sv+ let res = parseResponse src+-- mapM_ (hlDebug sv "critical" . (`BS.append` "\n") . BS.take 100)+-- . catMaybes =<< showResponse sv res+ let res' = putResponseBody sv res+ (httpContent (contentLength <$> responseContentLength res) sv)+ return res'++get :: HostName -> Int -> FilePath -> Request h+get hn pn fp = RequestGet (Path $ BSC.pack fp) (Version 1 1)+ Get {+ getHost = uncurry Host . second Just <$> Just (BSC.pack hn, pn),+ getUserAgent = Just [Product "tighttp" (Just "0.0.0.0")],+ getAccept = Just [Accept ("text", "plain") (Qvalue 1.0)],+ getAcceptLanguage = Just [AcceptLanguage "ja" (Qvalue 1.0)],+ getAcceptEncoding = Just [],+ getConnection = Just [Connection "keep-alive"],+ getCacheControl = Just [MaxAge 0],+ getOthers = []+ }++putResponseBody :: (PipeClass p, HandleLike h) =>+ h -> Response p h -> p () BS.ByteString (HandleMonad h) () -> Response p h+putResponseBody _ res rb = res { responseBody = rb }++httpContent :: (+ PipeClass p, MonadTrans (p () BS.ByteString),+ Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h ) =>+ Maybe Int -> h -> p () BS.ByteString (HandleMonad h) ()+httpContent (Just n) h = yield =<< lift (hlGet h n)+httpContent _ h = getChunked h `onBreak` readRest h++getChunked :: (+ PipeClass p, MonadTrans (p () BS.ByteString),+ Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h ) =>+ h -> p () BS.ByteString (HandleMonad h) ()+getChunked h = do+ (n :: Int) <- lift $ (fst . head . readHex . BSC.unpack) `liftM` hlGetLine h+ lift . hlDebug h "medium" . BSC.pack . (++ "\n") $ show n+ case n of+ 0 -> return ()+ _ -> do r <- lift $ hlGet h n+ "" <- lift $ hlGetLine h+ yield r+ getChunked h++readRest :: HandleLike h => h -> HandleMonad h ()+readRest h = do+ hlDebug h "low" "begin readRest\n"+ (n :: Int) <- (fst . head . readHex . BSC.unpack) `liftM` hlGetLine h+ hlDebug h "medium" . BSC.pack . (++ "\n") $ show n+ case n of+ 0 -> return ()+ _ -> do _ <- hlGet h n+ "" <- hlGetLine h+ readRest h++post :: HandleLike h =>+ HostName -> Int -> FilePath -> (Maybe Int, LBS.ByteString) -> Request h+post hn pn fp (len, pst) = RequestPost (Path $ BSC.pack fp) (Version 1 1)+ Post {+ postHost = uncurry Host . second Just <$> hnpn,+ postUserAgent = Just [Product "tighttp" (Just "0.0.0.0")],+ postAccept = Just [Accept ("text", "plain") (Qvalue 1.0)],+ postAcceptLanguage = Just [AcceptLanguage "ja" (Qvalue 1.0)],+ postAcceptEncoding = Just [],+ postConnection = Just [Connection "keep-alive"],+ postCacheControl = Just [MaxAge 0],+ postContentType = Just $ ContentType Text Plain [],+ postContentLength = cl,+ postTransferEncoding = ch,+ postOthers = [],+ postBody = fromList cnt+ }+ where+ hnpn = Just (BSC.pack hn, pn)+ (cl, ch, cnt) = case len of+ Just l -> (Just $ ContentLength l, Nothing, LBS.toChunks pst)+ _ -> (Nothing, Just Chunked,+ LBS.toChunks . mkChunked $ LBS.toChunks pst)++mkChunked :: [BS.ByteString] -> LBS.ByteString+mkChunked = flip foldr ("0\r\n\r\n") $ \b ->+ LBS.append (LBSC.pack (showHex (BS.length b) "") `LBS.append` "\r\n"+ `LBS.append` LBS.fromStrict b `LBS.append` "\r\n")++hGetHeader :: HandleLike h => h -> HandleMonad h [BS.ByteString]+hGetHeader h = do+ l <- hlGetLine h+ if BS.null l then return [] else (l :) `liftM` hGetHeader h
+ src/Network/TigHTTP/HttpTypes.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE OverloadedStrings, PackageImports #-}++module Network.TigHTTP.HttpTypes (+ Version(..),+ Request(..), RequestType(..), Path(..), Get(..), CacheControl(..),+ Accept(..), AcceptLanguage(..), Qvalue(..),+ Host(..), Product(..), Connection(..),+ Response(..), StatusCode(..), ContentLength(..), contentLength,+ ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),+ TransferEncoding(..),++ parseReq, parseResponse, putRequest, putResponse, (+++),+ myLast, requestBodyLength, postAddBody,++ Post(..),+ putPostBody,+ requestBody,+ requestPath,++ AcceptEncoding(..),+ HostName,+) where++import Control.Applicative+import "monads-tf" Control.Monad.Trans+import Data.Maybe+import Data.Char+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Time+import Data.Pipe+import Data.Pipe.List+import System.Locale++import Network.TigHTTP.Papillon++import Data.HandleLike++type HostName = String++(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString+(+++) = BS.append++(-:-) :: Char -> BS.ByteString -> BS.ByteString+(-:-) = BSC.cons++data Request h+ = RequestGet Path Version Get+ | RequestPost Path Version (Post h)+ | RequestRaw RequestType Path Version [(BS.ByteString, BS.ByteString)]++requestBodyLength :: Request h -> Maybe Int+requestBodyLength (RequestPost _ _ p) = contentLength <$> postContentLength p+requestBodyLength _ = Nothing++postAddBody :: HandleLike h => Request h -> BS.ByteString -> Request h+postAddBody (RequestPost u v p) b = RequestPost u v $ p { postBody = pp }+ where+ pp = fromList [b]+postAddBody r _ = r++putPostBody :: HandleLike h => h -> Request h ->+ Pipe () BS.ByteString (HandleMonad h) () -> Request h+putPostBody _ (RequestPost u v p) pp = RequestPost u v $ p { postBody = pp }+putPostBody _ r _ = r++requestBody :: HandleLike h => Request h -> Pipe () BS.ByteString (HandleMonad h) ()+requestBody (RequestPost _ _ p) = postBody p+requestBody _ = return ()++requestPath :: Request h -> Path+requestPath (RequestGet p _ _) = p+requestPath (RequestPost p _ _) = p+requestPath (RequestRaw _ p _ _) = p++putRequest :: HandleLike h => h -> Request h -> HandleMonad h ()+putRequest sv (RequestGet uri vsn g) = do+ let r = [+ Just $ "GET " +++ showPath uri +++ " " +++ showVersion vsn,+ ("Host: " +++) . showHost <$> getHost g,+ ("User-Agent: " +++) . BSC.unwords .+ map showProduct <$> getUserAgent g,+ ("Accept: " +++) . BSC.intercalate "," .+ map showAccept <$> getAccept g,+ ("Accept-Language: " +++) . BSC.intercalate "," .+ map showAcceptLanguage <$> getAcceptLanguage g,+ ("Accept-Encoding: " +++) . BSC.intercalate "," .+ map showAcceptEncoding <$> getAcceptEncoding g,+ ("Connection: " +++) . BSC.intercalate "," .+ map showConnection <$> getConnection g,+ ("Cache-Control: " +++) . BSC.intercalate "," .+ map showCacheControl <$> getCacheControl g,+ Just ""+ ]+ hlDebug sv "medium" . crlf $ catMaybes r+ hlPut sv . crlf $ catMaybes r+putRequest sv (RequestPost uri vsn p) = do+ let hd = [+ Just $ "POST " +++ showPath uri +++ " " +++ showVersion vsn,+ ("Host: " +++) . showHost <$> postHost p,+ ("User-Agent: " +++) . BSC.unwords . map showProduct <$> postUserAgent p,+ ("Accept: " +++) . BSC.intercalate "," . map showAccept <$> postAccept p,+ ("Accept-Language: " +++) . BSC.intercalate "," .+ map showAcceptLanguage <$> postAcceptLanguage p,+ ("Accept-Encoding: " +++) . BSC.intercalate "," .+ map showAcceptEncoding <$> postAcceptEncoding p,+ ("Connection: " +++) . BSC.intercalate "," .+ map showConnection <$> postConnection p,+ ("Cache-Control: " +++) . BSC.intercalate "," .+ map showCacheControl <$> postCacheControl p,+ ("Content-Type: " +++) . showContentType <$> postContentType p,+ ("Content-Length: " +++) . showContentLength <$> postContentLength p+ ] ++ map (\(k, v) -> Just $ k +++ ": " +++ v) (postOthers p) ++ [+ Just "" ]+ hlPut sv . crlf $ catMaybes hd+ _ <- runPipe $ postBody p =$= putAll sv+ return ()+putRequest sv (RequestRaw rt uri vsn kvs) = do+ let r = [+ Just $ showRequestType rt ++++ " " +++ showPath uri +++ " " +++ showVersion vsn ] +++ map (\(k, v) -> Just $ k +++ ": " +++ v) kvs ++ [ Just "" ]+ hlPut sv . crlf $ catMaybes r++data Get = Get {+ getCacheControl :: Maybe [CacheControl],+ getConnection :: Maybe [Connection],+ getAccept :: Maybe [Accept],+ getAcceptEncoding :: Maybe [AcceptEncoding],+ getAcceptLanguage :: Maybe [AcceptLanguage],+ getHost :: Maybe Host,+ getUserAgent :: Maybe [Product],+ getOthers :: [(BS.ByteString, BS.ByteString)]+ } deriving Show++data Post h = Post {+ postCacheControl :: Maybe [CacheControl],+ postConnection :: Maybe [Connection],+ postTransferEncoding :: Maybe TransferEncoding,+ postAccept :: Maybe [Accept],+ postAcceptEncoding :: Maybe [AcceptEncoding],+ postAcceptLanguage :: Maybe [AcceptLanguage],+ postHost :: Maybe Host,+ postUserAgent :: Maybe [Product],+ postContentLength :: Maybe ContentLength,+ postContentType :: Maybe ContentType,+ postOthers :: [(BS.ByteString, BS.ByteString)],+ postBody :: Pipe () BS.ByteString (HandleMonad h) () }++data RequestType+ = RequestTypeGet+ | RequestTypePost+ | RequestTypeRaw BS.ByteString+ deriving Show++showRequestType :: RequestType -> BS.ByteString+showRequestType RequestTypeGet = "GET"+showRequestType RequestTypePost = "POST"+showRequestType (RequestTypeRaw rt) = rt++data Path = Path BS.ByteString deriving Show++showPath :: Path -> BS.ByteString+showPath (Path uri) = uri++data Version = Version Int Int deriving Show++showVersion :: Version -> BS.ByteString+showVersion (Version vmjr vmnr) =+ "HTTP/" +++ BSC.pack (show vmjr) +++ "." +++ BSC.pack (show vmnr)++parseReq :: HandleLike h => [BS.ByteString] -> Request h+parseReq (h : t) = let+ (rt, uri, v) = parseRequestLine h in+ parseSep rt uri v $ map separate t+ where+ separate i = let (k, csv) = BSC.span (/= ':') i in+ case BS.splitAt 2 csv of+ (": ", v) -> (k, v)+ _ -> error "parse: bad"+parseReq [] = error "parse: bad request"++parseSep :: HandleLike h => RequestType ->+ Path -> Version -> [(BS.ByteString, BS.ByteString)] -> Request h+parseSep RequestTypeGet uri v kvs = RequestGet uri v $ parseGet kvs+parseSep RequestTypePost uri v kvs = RequestPost uri v $ parsePost kvs+parseSep rt uri v kvs = RequestRaw rt uri v kvs++parseRequestLine :: BS.ByteString -> (RequestType, Path, Version)+parseRequestLine rl = let+ [rts, uris, vs] = BSC.words rl+ rt = case rts of+ "GET" -> RequestTypeGet+ "POST" -> RequestTypePost+ _ -> RequestTypeRaw rts in+ (rt, Path uris, parseVersion vs)++parseVersion :: BS.ByteString -> Version+parseVersion httpVns+ | ("HTTP/", vns) <- BS.splitAt 5 httpVns = let+ (vmjrs, dvmnrs) = BSC.span (/= '.') vns in case BSC.uncons dvmnrs of+ Just ('.', vmnrs) -> Version+ (read $ BSC.unpack vmjrs) (read $ BSC.unpack vmnrs)+ _ -> error "parseVersion: bad http version"+parseVersion _ = error "parseVersion: bad http version"++parseGet :: [(BS.ByteString, BS.ByteString)] -> Get+parseGet kvs = Get {+ getHost = parseHost <$> lookup "Host" kvs,+ getUserAgent = map parseProduct . sepTkn <$> lookup "User-Agent" kvs,+ getAccept = map parseAccept . unlist <$> lookup "Accept" kvs,+ getAcceptLanguage =+ map parseAcceptLanguage . unlist <$> lookup "Accept-Language" kvs,+ getAcceptEncoding =+ map parseAcceptEncoding . unlist <$> lookup "Accept-Encoding" kvs,+ getConnection = map parseConnection . unlist <$> lookup "Connection" kvs,+ getCacheControl =+ map parseCacheControl . unlist <$> lookup "Cache-Control" kvs,+ getOthers = filter ((`notElem` getKeys) . fst) kvs+ }++parsePost :: HandleLike h => [(BS.ByteString, BS.ByteString)] -> Post h+parsePost kvs = Post {+ postHost = parseHost <$> lookup "Host" kvs,+ postUserAgent = map parseProduct . sepTkn <$> lookup "User-Agent" kvs,+ postAccept = map parseAccept . unlist <$> lookup "Accept" kvs,+ postAcceptLanguage =+ map parseAcceptLanguage . unlist <$> lookup "Accept-Language" kvs,+ postAcceptEncoding =+ map parseAcceptEncoding . unlist <$> lookup "Accept-Encoding" kvs,+ postConnection = map parseConnection . unlist <$> lookup "Connection" kvs,+ postCacheControl =+ map parseCacheControl . unlist <$> lookup "Cache-Control" kvs,+ postContentType = parseContentType <$> lookup "Content-Type" kvs,+ postContentLength = ContentLength . read . BSC.unpack <$>+ lookup "Content-Length" kvs,+ postTransferEncoding = case lookup "Transfer-Encoding" kvs of+ Just "chunked" -> Just Chunked+ Nothing -> Nothing+ _ -> error "bad Transfer-Encoding",+ postOthers = filter ((`notElem` postKeys) . fst) kvs,+ postBody = return ()+ }++postKeys :: [BS.ByteString]+postKeys = [+ "Host", "User-Agent", "Accept", "Accept-Language", "Accept-Encoding",+ "Connection", "Cache-Control", "Content-Type", "Content-Length",+ "Transfer-Encoding"+ ]++sepTkn :: BS.ByteString -> [BS.ByteString]+sepTkn "" = []+sepTkn psrc+ | Just ('(', src) <- BSC.uncons psrc = let+ (cm, src') = let (c_, s_) = BSC.span (/= ')') src in+ case BSC.uncons s_ of+ Just (')', s__) -> (c_, s__)+ _ -> error "setTkn: bad comment" in+ ('(' -:- cm +++ ")") : sepTkn (BSC.dropWhile isSpace src')+-- sepTkn ('(' : src) = ('(' : cm ++ ")") : sepTkn (dropWhile isSpace src')+-- where+-- (cm, ')' : src') = span (/= ')') src+sepTkn src = tk : sepTkn (BSC.dropWhile isSpace src')+ where+ (tk, src') = BSC.span (not . isSpace) src++getKeys :: [BS.ByteString]+getKeys = [+ "Host", "User-Agent", "Accept", "Accept-Language", "Accept-Encoding",+ "Connection", "Cache-Control"+ ]++data Host = Host BS.ByteString (Maybe Int) deriving Show++parseHost :: BS.ByteString -> Host+parseHost src = case BSC.span (/= ':') src of+ (h, cp) -> case BSC.uncons cp of+ Just (':', p) -> Host h (Just . read $ BSC.unpack p)+ Nothing -> Host h Nothing+ _ -> error "parseHost: never occur"++showHost :: Host -> BS.ByteString+showHost (Host h p) = h +++ maybe "" ((':' -:-) . BSC.pack . show) p++data Product+ = Product BS.ByteString (Maybe BS.ByteString)+ | ProductComment BS.ByteString+ deriving Show++showProduct :: Product -> BS.ByteString+showProduct (Product pn mpv) = pn +++ case mpv of+ Just v -> '/' -:- v+ _ -> ""+showProduct (ProductComment cm) = "(" +++ cm +++ ")"++parseProduct :: BS.ByteString -> Product+parseProduct pcm+ | Just ('(', cm) <- BSC.uncons pcm = case myLast "here" cm of+ ')' -> ProductComment $ BS.init cm+ _ -> error "parseProduct: bad comment"+parseProduct pnv = case BSC.span (/= '/') pnv of+ (pn, sv) -> case BSC.uncons sv of+ Just ('/', v) -> Product pn $ Just v+ _ -> Product pnv Nothing++myLast :: String -> BS.ByteString -> Char+myLast err bs+ | BS.null bs = error err+ | otherwise = BSC.last bs++data Accept+ = Accept (BS.ByteString, BS.ByteString) Qvalue+ deriving Show++showAccept :: Accept -> BS.ByteString+showAccept (Accept (t, st) qv) = ((t +++ "/" +++ st) +++) $ showQvalue qv++parseAccept :: BS.ByteString -> Accept+parseAccept src = case BSC.span (/= ';') src of+ (mr, sqv) -> case BSC.uncons sqv of+ Just (';', qv) -> Accept (parseMediaRange mr) $ parseQvalue qv+ Nothing -> Accept (parseMediaRange mr) $ Qvalue 1+ _ -> error "parseAccept: never occur"++parseMediaRange :: BS.ByteString -> (BS.ByteString, BS.ByteString)+parseMediaRange src = case BSC.span (/= '/') src of+ (t, sst) -> case BSC.uncons sst of+ Just ('/', st) -> (t, st)+ _ -> error "parseMediaRange: bad media range"++unlist :: BS.ByteString -> [BS.ByteString]+unlist "" = []+unlist src = case BSC.span (/= ',') src of+ (h, "") -> [h]+ (h, ct) -> case BSC.uncons ct of+ Just (',', t) -> h : unlist (BSC.dropWhile isSpace t)+ _ -> error "unlist: never occur"++data Qvalue+ = Qvalue Double+ deriving Show++showQvalue :: Qvalue -> BS.ByteString+showQvalue (Qvalue 1.0) = ""+showQvalue (Qvalue qv) = ";q=" +++ BSC.pack (show qv)++parseQvalue :: BS.ByteString -> Qvalue+parseQvalue qeqv+ | ("q=", qv) <- BS.splitAt 2 qeqv = Qvalue . read $ BSC.unpack qv+parseQvalue _ = error "parseQvalue: bad qvalue"++data AcceptLanguage+ = AcceptLanguage BS.ByteString Qvalue+ deriving Show++showAcceptLanguage :: AcceptLanguage -> BS.ByteString+showAcceptLanguage (AcceptLanguage al qv) = al +++ showQvalue qv++parseAcceptLanguage :: BS.ByteString -> AcceptLanguage+parseAcceptLanguage src = case BSC.span (/= ';') src of+ (al, sqv) -> case BSC.uncons sqv of+ Just (';', qv) -> AcceptLanguage al $ parseQvalue qv+ Nothing -> AcceptLanguage al $ Qvalue 1+ _ -> error "parseAcceptLanguage: never occur"++data AcceptEncoding+ = AcceptEncoding BS.ByteString Qvalue+ deriving Show++showAcceptEncoding :: AcceptEncoding -> BS.ByteString+showAcceptEncoding (AcceptEncoding ae qv) = ae +++ showQvalue qv++parseAcceptEncoding :: BS.ByteString -> AcceptEncoding+parseAcceptEncoding src = case BSC.span (/= ';') src of+ (ae, sqv) -> case BSC.uncons sqv of+ Just (';', qv) -> AcceptEncoding ae $ parseQvalue qv+ Nothing -> AcceptEncoding ae $ Qvalue 1+ _ -> error "parseAcceptEncoding: never occur"++data Connection+ = Connection BS.ByteString+ deriving Show++showConnection :: Connection -> BS.ByteString+showConnection (Connection c) = c++parseConnection :: BS.ByteString -> Connection+parseConnection = Connection++data CacheControl+ = MaxAge Int+ | CacheControlRaw BS.ByteString+ deriving Show++showCacheControl :: CacheControl -> BS.ByteString+showCacheControl (MaxAge ma) = "max-age=" +++ BSC.pack (show ma)+showCacheControl (CacheControlRaw cc) = cc++parseCacheControl :: BS.ByteString -> CacheControl+parseCacheControl ccma+ | ("max-age", ema) <- BSC.span (/= '=') ccma = case BSC.uncons ema of+ Just ('=', ma) -> MaxAge . read $ BSC.unpack ma+ _ -> error "parseCacheControl: bad"+parseCacheControl cc = CacheControlRaw cc++data Response p h = Response {+ responseVersion :: Version,+ responseStatusCode :: StatusCode,+ responseConnection :: Maybe BS.ByteString,+ responseDate :: Maybe UTCTime,+ responseTransferEncoding :: Maybe TransferEncoding,+ responseAcceptRanges :: Maybe BS.ByteString,+ responseETag :: Maybe BS.ByteString,+ responseServer :: Maybe [Product],+ responseContentLength :: Maybe ContentLength,+ responseContentType :: ContentType,+ responseLastModified :: Maybe UTCTime,+ responseOthers :: [(BS.ByteString, BS.ByteString)],+ responseBody :: p () BS.ByteString (HandleMonad h) ()+ }++parseResponse :: (+ Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h) =>+ [BS.ByteString] -> Response p h+parseResponse (h : t) = let (v, sc) = parseResponseLine h in+ parseResponseSep v sc $ map separate t+ where+ separate i = let (k, csv) = BSC.span (/= ':') i in+ case BS.splitAt 2 csv of+ (": ", v) -> (k, v)+ _ -> error "parseResponse: bad response"+ -- let (k, ':' : ' ' : v) = span (/= ':') i in (k, v)+parseResponse _ = error "parseResponse: bad response"++parseResponseSep :: (+ Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h) =>+ Version -> StatusCode ->+ [(BS.ByteString, BS.ByteString)] -> Response p h+parseResponseSep v sc kvs = Response {+ responseVersion = v,+ responseStatusCode = sc,+ responseDate = readTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S" .+ BSC.unpack . initN 4 <$> lookup "Date" kvs,+ responseContentLength = ContentLength . read . BSC.unpack <$>+ lookup "Content-Length" kvs,+ responseTransferEncoding = case lookup "Transfer-Encoding" kvs of+ Just "chunked" -> Just Chunked+ Nothing -> Nothing+ _ -> error "bad Transfer-Encoding",+ responseContentType = parseContentType . fromJust $+ lookup "Content-Type" kvs,+ responseServer = map parseProduct . sepTkn <$> lookup "Server" kvs,+ responseLastModified = readTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S" .+ BSC.unpack . initN 4 <$> lookup "Last-Modified" kvs,+ responseETag = lookup "ETag" kvs,+ responseAcceptRanges = lookup "Accept-Ranges" kvs,+ responseConnection = lookup "Connection" kvs,+ responseOthers = filter ((`notElem` responseKeys) . fst) kvs,+ responseBody = return ()+ }++responseKeys :: [BS.ByteString]+responseKeys = [+ "Date", "Content-Length", "Content-Type", "Server", "Last-Modified",+ "ETag", "Accept-Ranges", "Connection", "Transfer-Encoding" ]++initN :: Int -> BS.ByteString -> BS.ByteString+initN n lst = BS.take (BS.length lst - n) lst++parseResponseLine :: BS.ByteString -> (Version, StatusCode)+parseResponseLine src = case BSC.span (/= ' ') src of+ (vs, sscs) -> case BSC.uncons sscs of+ Just (' ', scs) -> (parseVersion vs, parseStatusCode scs)+ _ -> error "parseResponseLine: bad response line"++parseStatusCode :: BS.ByteString -> StatusCode+parseStatusCode sc+ | ("200", _) <- BSC.span (not . isSpace) sc = OK+ | ("301", _) <- BSC.span (not . isSpace) sc = MovedPermanently+ | ("302", _) <- BSC.span (not . isSpace) sc = Found+ | ("400", _) <- BSC.span (not . isSpace) sc = BadRequest+parseStatusCode sc = error $ "parseStatusCode: bad status code: " ++ BSC.unpack sc++putResponse :: (+ PipeClass p, MonadTrans (p BS.ByteString ()),+ Monad (p BS.ByteString () (HandleMonad h)),+ HandleLike h) =>+ h -> Response p h -> HandleMonad h ()+putResponse cl r = do+ let hd = [+ Just $ showVersion (responseVersion r) +++ " " ++++ showStatusCode (responseStatusCode r),+ Just $ "Date: " +++ maybe "" showTime (responseDate r),+ ("Content-Length: " +++) . showContentLength <$>+ responseContentLength r,+ ("Transfer-Encoding: " +++) . showTransferEncoding <$>+ responseTransferEncoding r,+ Just $ "Content-Type: " ++++ showContentType (responseContentType r),+ ("Server: " +++) . BSC.unwords . map showProduct <$> responseServer r,+ ("Last-Modified: " +++) . showTime <$> responseLastModified r,+ ("ETag: " +++) <$> responseETag r,+ ("Accept-Ranges: " +++) <$> responseAcceptRanges r,+ ("Connection: " +++) <$> responseConnection r+ ] +++ map (\(k, v) -> Just $ k +++ ": " +++ v) (responseOthers r) +++ [ Just "" ]+ p = responseBody r+ hlPut cl . crlf $ catMaybes hd+ _ <- runPipe $ p =$= putAll cl+ return ()++putAll :: (+ PipeClass p, MonadTrans (p BS.ByteString ()),+ Monad (p BSC.ByteString () (HandleMonad h)),+ HandleLike h) =>+ h -> p BS.ByteString () (HandleMonad h) ()+putAll cl = do+ ms <- await+ case ms of+ Just s -> do+-- lift (hlPut cl s >> hlPut cl "\r\n")+ lift $ hlPut cl s+ putAll cl+ _ -> return ()++crlf :: [BS.ByteString] -> BS.ByteString+crlf = BS.concat . map (`BS.append` "\r\n")++data StatusCode+ = Continue+ | SwitchingProtocols+ | OK+ | MovedPermanently+ | Found+ | BadRequest+ deriving Show++showStatusCode :: StatusCode -> BS.ByteString+showStatusCode Continue = "100 Continue"+showStatusCode SwitchingProtocols = "101 SwitchingProtocols"+showStatusCode OK = "200 OK"+showStatusCode MovedPermanently = "301 Moved Permanently"+showStatusCode Found = "302 Found"+showStatusCode BadRequest = "400 Bad Request"++data ContentLength = ContentLength Int deriving Show++showContentLength :: ContentLength -> BS.ByteString+showContentLength (ContentLength n) = BSC.pack $ show n++contentLength :: ContentLength -> Int+contentLength (ContentLength n) = n++data TransferEncoding = Chunked deriving Show++showTransferEncoding :: TransferEncoding -> BS.ByteString+showTransferEncoding Chunked = "chunked"++showTime :: UTCTime -> BS.ByteString+showTime = BSC.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
+ src/Network/TigHTTP/Papillon.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.TigHTTP.Papillon (+ ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),+ parseContentType, showContentType,+) where++import Data.Char+import Text.Papillon++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC++import Network.TigHTTP.Token++data ContentType = ContentType Type Subtype [Parameter] deriving Show++parseContentType :: BS.ByteString -> ContentType+parseContentType ct = case runError . contentType $ parse ct of+ Left _ -> error "parseContentType"+ Right (r, _) -> r++showContentType :: ContentType -> BS.ByteString+showContentType (ContentType t st ps) = showType t+ `BS.append` "/"+ `BS.append` showSubtype st+ `BS.append` showParameters ps++data Type+ = Text+ | TypeRaw BS.ByteString+ deriving Show++mkType :: BS.ByteString -> Type+mkType "text" = Text+mkType t = TypeRaw t++showType :: Type -> BS.ByteString+showType Text = "text"+showType (TypeRaw t) = t++data Subtype+ = Plain+ | Html+ | SubtypeRaw BS.ByteString+ deriving Show++mkSubtype :: BS.ByteString -> Subtype+mkSubtype "html" = Html+mkSubtype "plain" = Plain+mkSubtype s = SubtypeRaw s++showSubtype :: Subtype -> BS.ByteString+showSubtype Plain = "plain"+showSubtype Html = "html"+showSubtype (SubtypeRaw s) = s++data Parameter+ = Charset Charset+ | ParameterRaw BS.ByteString BS.ByteString+ deriving Show++mkParameter :: BS.ByteString -> BS.ByteString -> Parameter+mkParameter "charset" "UTF-8" = Charset Utf8+mkParameter "charset" v = Charset $ CharsetRaw v+mkParameter a v = ParameterRaw a v++showParameters :: [Parameter] -> BS.ByteString+showParameters [] = ""+showParameters (Charset v : ps) = "; " `BS.append` "charset"+ `BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps+showParameters (ParameterRaw a v : ps) = "; " `BS.append` a+ `BS.append` "=" `BS.append` v `BS.append` showParameters ps++data Charset+ = Utf8+ | CharsetRaw BS.ByteString+ deriving Show++showCharset :: Charset -> BS.ByteString+showCharset Utf8 = "UTF-8"+showCharset (CharsetRaw cs) = cs++bsconcat :: [ByteString] -> ByteString+bsconcat = BS.concat++[papillon|++source: ByteString++contentType :: ContentType+ = c:token '/' sc:token ps:(';' ' '* p:parameter { p })*+ { ContentType (mkType c) (mkSubtype sc) ps }++token :: ByteString+ = t:<isTokenChar>+ { pack t }++quotedString :: ByteString+ = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"'+ { bsconcat t }++quotedPair :: Char+ = '\\' c:<isAscii> { c }++crlf :: () = '\r' '\n'++lws :: () = _:crlf _:(' ' / '\t')+++text :: ByteString+ = ts:(cs:<isTextChar>+ { cs } / _:lws { " " })+ { pack $ concat ts }++qdtext :: ByteString+ = ts:(cs:<isQdtextChar>+ { cs } / _:lws { " " })+ { pack $ concat ts }++parameter :: Parameter+ = a:attribute '=' v:value { mkParameter a v }++attribute :: ByteString = t:token { t }++value :: ByteString+ = t:token { t }+ / qs:quotedString { qs }++|]++instance Source ByteString where+ type Token ByteString = Char+ data Pos ByteString = NoPos+ getToken = BSC.uncons+ initialPos = NoPos+ updatePos _ _ = NoPos
+ src/Network/TigHTTP/Server.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, PackageImports #-}++module Network.TigHTTP.Server (+ getRequest, putResponse, response,+-- ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),+-- Request(..), Get(..), Post(..),+ requestBody,+ requestPath,+ ) where++import Control.Monad+import "monads-tf" Control.Monad.Trans+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBSC+import Data.Time+import Data.Pipe+import Data.Pipe.List+import System.Locale++import Network.TigHTTP.HttpTypes+import Data.HandleLike++import Numeric++getRequest :: HandleLike h => h -> HandleMonad h (Request h)+getRequest cl = do+ h <- hlGetHeader cl+ let req = parseReq h+ r <- case req of+ RequestPost {} -> return . httpContent cl $+ requestBodyLength req+ _ -> return (return ())+-- mapM_ (hlDebug cl "critical" . (`BS.append` "\n")) .+-- catMaybes =<< showRequest cl req+ return $ putPostBody cl req r++response :: (+ PipeClass p, Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h) => LBS.ByteString -> Response p h+response = mkContents . mkChunked . LBS.toChunks++httpContent :: HandleLike h =>+ h -> Maybe Int -> Pipe () BS.ByteString (HandleMonad h) ()+httpContent h (Just n) = lift (hlGet h n) >>= yield+httpContent h _ = getChunked h++getChunked :: HandleLike h => h -> Pipe () BS.ByteString (HandleMonad h) ()+getChunked h = do+ (n :: Int) <- lift $ (fst . head . readHex . BSC.unpack) `liftM` hlGetLine h+ lift . hlDebug h "low" . BSC.pack . (++ "\n") $ show n+ case n of+ 0 -> return ()+ _ -> do r <- lift $ hlGet h n+ "" <- lift $ hlGetLine h+ yield r+ getChunked h++mkChunked :: [BS.ByteString] -> LBS.ByteString+mkChunked = flip foldr ("0\r\n\r\n") $ \b ->+ LBS.append (LBSC.pack (showHex (BS.length b) "") `LBS.append` "\r\n"+ `LBS.append` LBS.fromStrict b `LBS.append` "\r\n")++mkContents :: (+ PipeClass p, Monad (p () BS.ByteString (HandleMonad h)),+ HandleLike h ) => LBS.ByteString -> Response p h+mkContents cnt = Response {+ responseVersion = Version 1 1,+ responseStatusCode = OK,+ responseDate = Just $ readTime defaultTimeLocale+ "%a, %d %b %Y %H:%M:%S" "Wed, 07 May 2014 02:27:34",+ responseContentLength = Nothing, -- Just $ ContentLength $ BS.length cnt,+ responseTransferEncoding = Just Chunked,+ responseContentType = ContentType Text Plain [],+ responseServer = Nothing,+ responseLastModified = Nothing,+ responseETag = Nothing,+ responseAcceptRanges = Nothing,+ responseConnection = Nothing,+ responseOthers = [],+ responseBody = fromList $ LBS.toChunks cnt+ }++hlGetHeader :: HandleLike h => h -> HandleMonad h [BS.ByteString]+hlGetHeader h = do+ l <- hlGetLine h+ if BS.null l then return [] else (l :) `liftM` hlGetHeader h
+ src/Network/TigHTTP/Token.hs view
@@ -0,0 +1,19 @@+module Network.TigHTTP.Token (+ isTokenChar,+ isTextChar,+ isQdtextChar,+ ) where++import Data.Char (isAscii)+import Control.Applicative++isCtl, isSeparator, isTokenChar, isTextChar, isQdtextChar :: Char -> Bool+isCtl = (`elem` (['\0' .. '\31'] ++ "\DEL"))++isSeparator = (`elem` "()<>@,;:\\\"/[]?={} \t")++isTokenChar = (&&) <$> not . isCtl <*> not . isSeparator++isTextChar = (&&) <$> isAscii <*> not . isCtl++isQdtextChar = (&&) <$> isTextChar <*> (/= '"')
+ src/Network/TigHTTP/Types.hs view
@@ -0,0 +1,30 @@+module Network.TigHTTP.Types (+ -- * Request and Response+ Request(..), Get(..), Post(..), Response(..),++ -- * Header Types++ -- ** First Line+ Version(..), Path(..), RequestType(..), StatusCode(..),++ -- ** General Header+ CacheControl(..), Connection(..), TransferEncoding(..),++ -- ** Request Header+ Accept(..), AcceptEncoding(..), AcceptLanguage(..), Host(..),++ -- ** Response Header+ -- ** Entity Header+ ContentLength(..), ContentType(..), Type(..), Subtype(..),++ -- ** Basic Types+ Parameter(..),+ Charset(..),++ Product(..),+ Qvalue(..),++ HostName,+ ) where++import Network.TigHTTP.HttpTypes
+ tighttp.cabal view
@@ -0,0 +1,119 @@+build-type: Simple+cabal-version: >= 1.8++name: tighttp+version: 0.0.0.0+stability: Experimental+author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>+homepage: https://github.com/YoshikuniJujo/tighttp/wiki++license: BSD3+license-file: LICENSE++category: Network+Synopsis: Tiny and Incrementally-Growing HTTP library+description:+ Example programs+ .+ examples/get.hs+ .+ This is simple client.+ This send GET request and show page source.+ Run as following.+ .+ > runhaskell get.hs hackage.haskell.org /packages/+ .+ extensions+ .+ * PackageImports+ .+ > import "monads-tf" Control.Monad.Trans+ > import Data.Pipe+ > import System.Environment+ > import Network+ > import Network.TigHTTP.Client+ > import Network.TigHTTP.Types+ > + > import qualified Data.ByteString as BS+ >+ > main :: IO ()+ > main = do+ > addr : pth : _ <- getArgs+ > h <- connectTo addr $ PortNumber 80+ > r <- request h $ get addr 80 pth+ > _ <- runPipe $ responseBody r =$= finally printP (putStrLn "")+ > return ()+ >+ > printP :: MonadIO m => Pipe BS.ByteString () m ()+ > printP = await >>= maybe (return ()) (\s -> liftIO (BS.putStr s) >> printP)+ .+ examples/server.hs+ .+ This is simple server.+ This recieve client's request.+ And send command line arguments as response.+ Run as following.+ .+ > runhaskell server.hs Hello World I Am TigHTTP+ .+ > import Control.Monad+ > import Control.Concurrent+ > import Data.Pipe+ > import System.IO+ > import System.Environment+ > import Network+ > import Network.TigHTTP.Server+ > import Network.TigHTTP.Types+ >+ > import qualified Data.ByteString.Char8 as BSC+ > import qualified Data.ByteString.Lazy as LBS+ >+ > main :: IO ()+ > main = do+ > as <- getArgs+ > soc <- listenOn $ PortNumber 80+ > forever $ do+ > (h, _, _) <- accept soc+ > void . forkIO $ do+ > req <- getRequest h+ > print $ requestPath req+ > putResponse h+ > . (response :: LBS.ByteString -> Response Pipe Handle)+ > . LBS.fromChunks $ map BSC.pack as+ .+ If you want more examples. Please see examples directory.++extra-source-files:+ examples/get.hs+ examples/server.hs+ examples/post.hs+ examples/serverp.hs+ examples/gets.hs+ examples/servers.hs+ examples/posts.hs+ examples/serverps.hs++source-repository head+ type: git+ location: git://github.com/YoshikuniJujo/tighttp.git++source-repository this+ type: git+ location: git://github.com/YoshikuniJujo/tighttp.git+ tag: tighttp-0.0.0.0++library+ hs-source-dirs: src+ exposed-modules:+ Network.TigHTTP.Client, Network.TigHTTP.Server,+ Network.TigHTTP.Types+ other-modules:+ Network.TigHTTP.HttpTypes, Network.TigHTTP.Papillon,+ Network.TigHTTP.Token+ build-depends:+ base == 4.*, bytestring == 0.10.*, handle-like == 0.1.*,+ old-locale == 1.0.*, time == 1.4.*, monads-tf == 0.1.*,+ papillon == 0.0.88, simple-pipe == 0.0.0.*+ ghc-options: -Wall+ extensions: PatternGuards