diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,1 @@ +import Distribution.Simple; main = defaultMain diff --git a/examples/get.hs b/examples/get.hs new file mode 100644 --- /dev/null +++ b/examples/get.hs @@ -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) diff --git a/examples/gets.hs b/examples/gets.hs new file mode 100644 --- /dev/null +++ b/examples/gets.hs @@ -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) diff --git a/examples/post.hs b/examples/post.hs new file mode 100644 --- /dev/null +++ b/examples/post.hs @@ -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) diff --git a/examples/posts.hs b/examples/posts.hs new file mode 100644 --- /dev/null +++ b/examples/posts.hs @@ -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) diff --git a/examples/server.hs b/examples/server.hs new file mode 100644 --- /dev/null +++ b/examples/server.hs @@ -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 diff --git a/examples/serverp.hs b/examples/serverp.hs new file mode 100644 --- /dev/null +++ b/examples/serverp.hs @@ -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) diff --git a/examples/serverps.hs b/examples/serverps.hs new file mode 100644 --- /dev/null +++ b/examples/serverps.hs @@ -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) diff --git a/examples/servers.hs b/examples/servers.hs new file mode 100644 --- /dev/null +++ b/examples/servers.hs @@ -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 diff --git a/src/Network/TigHTTP/Client.hs b/src/Network/TigHTTP/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/Client.hs @@ -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 diff --git a/src/Network/TigHTTP/HttpTypes.hs b/src/Network/TigHTTP/HttpTypes.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/HttpTypes.hs @@ -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" diff --git a/src/Network/TigHTTP/Papillon.hs b/src/Network/TigHTTP/Papillon.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/Papillon.hs @@ -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:+ { pack t } + +quotedString :: ByteString + = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"' + { bsconcat t } + +quotedPair :: Char + = '\\' c: { c } + +crlf :: () = '\r' '\n' + +lws :: () = _:crlf _:(' ' / '\t')+ + +text :: ByteString + = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } + +qdtext :: ByteString + = ts:(cs:+ { 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 diff --git a/src/Network/TigHTTP/Server.hs b/src/Network/TigHTTP/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/Server.hs @@ -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 diff --git a/src/Network/TigHTTP/Token.hs b/src/Network/TigHTTP/Token.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/Token.hs @@ -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 <*> (/= '"') diff --git a/src/Network/TigHTTP/Types.hs b/src/Network/TigHTTP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/Types.hs @@ -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 diff --git a/tighttp.cabal b/tighttp.cabal new file mode 100644 --- /dev/null +++ b/tighttp.cabal @@ -0,0 +1,119 @@ +build-type: Simple +cabal-version: >= 1.8 + +name: tighttp +version: 0.0.0.0 +stability: Experimental +author: Yoshikuni Jujo +maintainer: Yoshikuni Jujo +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