dist
report.html
+Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
+
+data/CompileMimeTypes
+
examples/HelloWorld
examples/Implanted
examples/ImplantedSmall
include cabal-package.mk
-update-web: update-web-doc update-web-ditz
-
-update-web-doc: doc
- rsync -av --delete \
- dist/doc/html/Lucu/ \
- www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/Lucu
-
-update-web-ditz: ditz
- rsync -av --delete \
- dist/ditz/ \
- www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/Lucu
+build-hook:
+ $(MAKE) -C data
ImplantFile.hs
NEWS
data/CompileMimeTypes.hs
+ data/Makefile
data/mime.types
examples/HelloWorld.hs
examples/Implanted.hs
Library
Build-Depends:
- HsOpenSSL == 0.10.*,
- base == 4.3.*,
- base-unicode-symbols == 0.2.*,
- base64-bytestring == 0.1.*,
- bytestring == 0.9.*,
- containers == 0.4.*,
- filepath == 1.2.*,
- directory == 1.1.*,
- haskell-src == 1.0.*,
- hxt == 9.1.*,
- mtl == 2.0.*,
- network == 2.3.*,
- stm == 2.2.*,
- time == 1.2.*,
- time-http == 0.1.*,
- unix == 2.4.*,
- zlib == 0.5.*
+ HsOpenSSL == 0.10.*,
+ ascii == 0.0.*,
+ attoparsec == 0.9.*,
+ base == 4.3.*,
+ base-unicode-symbols == 0.2.*,
+ base64-bytestring == 0.1.*,
+ blaze-builder == 0.3.*,
+ bytestring == 0.9.*,
+ containers == 0.4.*,
+ containers-unicode-symbols == 0.3.*,
+ filepath == 1.2.*,
+ directory == 1.1.*,
+ haskell-src == 1.0.*,
+ hxt == 9.1.*,
+ mtl == 2.0.*,
+ network == 2.3.*,
+ stm == 2.2.*,
+ text == 0.11.*,
+ text-icu == 0.6.*,
+ time == 1.2.*,
+ time-http == 0.1.*,
+ unix == 2.4.*,
+ zlib == 0.5.*
Exposed-Modules:
Network.HTTP.Lucu
Network.HTTP.Lucu.MIMEType
Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
Network.HTTP.Lucu.MIMEType.Guess
- Network.HTTP.Lucu.Parser
Network.HTTP.Lucu.Parser.Http
+ Network.HTTP.Lucu.RFC2231
Network.HTTP.Lucu.Request
Network.HTTP.Lucu.Resource
Network.HTTP.Lucu.Resource.Tree
{-# LANGUAGE
- DeriveDataTypeable
+ Arrows
+ , BangPatterns
+ , DeriveDataTypeable
+ , TypeOperators
, UnicodeSyntax
#-}
{-# OPTIONS_HADDOCK prune #-}
, abortPage
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowIO
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad.Trans
-import qualified Data.ByteString.Char8 as C8
-import Data.Typeable
-import GHC.Conc (unsafeIOToSTM)
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import System.IO.Unsafe
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlState
-
+import Control.Arrow
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.Trans
+import Data.Ascii (Ascii, CIAscii)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
data Abortion = Abortion {
aboStatus :: !StatusCode
, aboHeaders :: !Headers
- , aboMessage :: !(Maybe String)
- } deriving (Show, Typeable)
+ , aboMessage :: !(Maybe Text)
+ } deriving (Eq, Show, Typeable)
instance Exception Abortion
-- > abort MovedPermanently
-- > [("Location", "http://example.net/")]
-- > (Just "It has been moved to example.net")
-abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
-abort status headers msg
- = status `seq` headers `seq` msg `seq`
- let abo = Abortion status (toHeaders $ map pack headers) msg
- in
- liftIO $ throwIO abo
- where
- pack (x, y) = (C8.pack x, C8.pack y)
+abort :: MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
+{-# INLINE abort #-}
+abort status headers
+ = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)
-- |This is similar to 'abort' but computes it with
-- 'System.IO.Unsafe.unsafePerformIO'.
-abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a
-abortPurely = ((unsafePerformIO .) .) . abort
+abortPurely :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
+{-# INLINE abortPurely #-}
+abortPurely status headers
+ = throw ∘ Abortion status (toHeaders headers)
-- |Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a 'Control.Monad.STM.STM' monad.
-abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
-abortSTM status headers msg
- = status `seq` headers `seq` msg `seq`
- unsafeIOToSTM $! abort status headers msg
+abortSTM :: StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
+{-# INLINE abortSTM #-}
+abortSTM status headers
+ = throwSTM ∘ Abortion status (toHeaders headers)
-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
-abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
-abortA
- = arrIO3 abort
+abortA :: Arrow (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
+{-# INLINE abortA #-}
+abortA = proc (status, (headers, msg)) →
+ returnA ⤙ abortPurely status headers msg
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
-abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
-abortPage conf reqM res abo
- = conf `seq` reqM `seq` res `seq` abo `seq`
- case aboMessage abo of
+abortPage :: Config → Maybe Request → Response → Abortion → Text
+abortPage !conf !reqM !res !abo
+ = case aboMessage abo of
Just msg
- -> let [html] = unsafePerformIO
- $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
- >>>
- writeDocumentToString [ withIndent True ]
- )
- in
- html
+ → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
+ ⋙
+ writeDocumentToString [ withIndent True ]
+ ) ()
+ in
+ T.pack html
Nothing
- -> let res' = res { resStatus = aboStatus abo }
- res'' = foldl (.) id [setHeader name value
- | (name, value) <- fromHeaders $ aboHeaders abo] res'
+ → let res' = res { resStatus = aboStatus abo }
+ res'' = foldl (∘) id [setHeader name value
+ | (name, value) ← fromHeaders $ aboHeaders abo] res'
in
getDefaultPage conf reqM res''
{-# LANGUAGE
- UnicodeSyntax
+ OverloadedStrings
+ , UnicodeSyntax
#-}
{-# OPTIONS_HADDOCK prune #-}
, UserID
, Password
+ , printAuthChallenge
, authCredentialP -- private
)
where
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as C8
-import Network.HTTP.Lucu.Parser
+import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
deriving (Eq)
-- |'Realm' is just a string which must not contain any non-ASCII letters.
-type Realm = String
+type Realm = Ascii
-- |Authorization credential to be sent by client with
-- \"Authorization\" header. See
-- |'UserID' is just a string which must not contain colon and any
-- non-ASCII letters.
-type UserID = String
+type UserID = Ascii
-- |'Password' is just a string which must not contain any non-ASCII
-- letters.
-type Password = String
+type Password = Ascii
-instance Show AuthChallenge where
- show (BasicAuthChallenge realm)
- = "Basic realm=" ⧺ quoteStr realm
+-- |Convert an 'AuthChallenge' to 'Ascii'.
+printAuthChallenge ∷ AuthChallenge → Ascii
+printAuthChallenge (BasicAuthChallenge realm)
+ = A.fromAsciiBuilder $
+ A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
authCredentialP ∷ Parser AuthCredential
authCredentialP
- = allowEOF $!
- do _ ← string "Basic"
- _ ← many1 lws
- b64 ← many1
- $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨
- (c ≥ 'A' ∧ c ≤ 'Z') ∨
- (c ≥ '0' ∧ c ≤ '9') ∨
- c ≡ '+' ∨
- c ≡ '/' ∨
- c ≡ '=')
- case break (≡ ':') (decode b64) of
- (uid, ':' : password)
- → return (BasicAuthCredential uid password)
- _ → failP
+ = do _ ← string "Basic"
+ skipMany1 lws
+ b64 ← takeWhile1 base64
+ case C8.break (≡ ':') (B64.decodeLenient b64) of
+ (user, cPassword)
+ | C8.null cPassword
+ → fail "no colons in the basic auth credential"
+ | otherwise
+ → do u ← asc user
+ p ← asc (C8.tail cPassword)
+ return (BasicAuthCredential u p)
where
- decode ∷ String → String
- decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack
+ base64 ∷ Char → Bool
+ base64 = inClass "a-zA-Z0-9+/="
+
+ asc ∷ C8.ByteString → Parser Ascii
+ asc bs = case A.fromByteString bs of
+ Just as → return as
+ Nothing → fail "Non-ascii character in auth credential"
+{-# LANGUAGE
+ UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Chunk
( chunkHeaderP -- Num a => Parser a
, chunkFooterP -- Parser ()
, chunkTrailerP -- Parser Headers
)
where
-
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Numeric
-
-
-chunkHeaderP :: Num a => Parser a
-chunkHeaderP = do hexLen <- many1 hexDigit
- _ <- extension
- _ <- crlf
-
- let [(len, _)] = readHex hexLen
+import Control.Applicative
+import Data.Attoparsec.Char8
+import Data.Bits
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Parser.Http
+
+chunkHeaderP ∷ (Integral a, Bits a) ⇒ Parser a
+{-# INLINEABLE chunkHeaderP #-}
+chunkHeaderP = do len ← hexadecimal
+ extension
+ crlf
return len
where
- extension :: Parser ()
- extension = many ( char ';' >>
- token >>
- char '=' >>
- ( token <|> quotedStr )
- )
- >>
- return ()
-{-# SPECIALIZE chunkHeaderP :: Parser Int #-}
-
-
-chunkFooterP :: Parser ()
-chunkFooterP = crlf >> return ()
-
-
-chunkTrailerP :: Parser Headers
+ extension ∷ Parser ()
+ extension = skipMany $
+ do _ ← char ';'
+ _ ← token
+ _ ← char '='
+ _ ← token <|> quotedStr
+ return ()
+
+chunkFooterP ∷ Parser ()
+chunkFooterP = crlf
+
+chunkTrailerP ∷ Parser Headers
chunkTrailerP = headersP
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
-- |Configurations for the Lucu httpd like a port to listen.
module Network.HTTP.Lucu.Config
( Config(..)
, defaultConfig
)
where
-
-import qualified Data.ByteString as Strict (ByteString)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Network
-import Network.BSD
-import Network.HTTP.Lucu.MIMEType.Guess
-import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
-import OpenSSL.Session
-import System.IO.Unsafe
+import Data.Ascii (Ascii)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network
+import Network.BSD
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
+import OpenSSL.Session
+import System.IO.Unsafe
-- |Configuration record for the Lucu httpd. You need to use
-- 'defaultConfig' or setup your own configuration to run the httpd.
data Config = Config {
-- |A string which will be sent to clients as \"Server\" field.
- cnfServerSoftware :: !Strict.ByteString
+ cnfServerSoftware ∷ !Ascii
-- |The host name of the server. This value will be used in
-- built-in pages like \"404 Not Found\".
- , cnfServerHost :: !Strict.ByteString
+ , cnfServerHost ∷ !Text
-- |A port number (or service name) to listen to HTTP clients.
- , cnfServerPort :: !ServiceName
+ , cnfServerPort ∷ !ServiceName
-- |Local IPv4 address to listen to both HTTP and HTTPS
-- clients. Set this to @('Just' "0.0.0.0")@ if you want to accept
-- any IPv4 connections. Set this to 'Nothing' to disable IPv4.
- , cnfServerV4Addr :: !(Maybe HostName)
+ , cnfServerV4Addr ∷ !(Maybe HostName)
-- |Local IPv6 address to listen to both HTTP and HTTPS
-- clients. Set this to @('Just' "::")@ if you want to accept any
-- IPv6 connections. Set this to 'Nothing' to disable IPv6. Note
-- that there is currently no way to assign separate ports to IPv4
-- and IPv6 server sockets.
- , cnfServerV6Addr :: !(Maybe HostName)
+ , cnfServerV6Addr ∷ !(Maybe HostName)
-- |Configuration for HTTPS connections. Set this 'Nothing' to
-- disable HTTPS.
- , cnfSSLConfig :: !(Maybe SSLConfig)
+ , cnfSSLConfig ∷ !(Maybe SSLConfig)
-- |The maximum number of requests to accept in one connection
-- simultaneously. If a client exceeds this limitation, its last
-- request won't be processed until a response for its earliest
-- pending request is sent back to the client.
- , cnfMaxPipelineDepth :: !Int
+ , cnfMaxPipelineDepth ∷ !Int
-- |The maximum length of request entity to accept in bytes. Note
-- that this is nothing but the default value which is used when
-- 'Network.HTTP.Lucu.Resource.input' and such like are applied to
-- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
-- guarantee that this value always constrains all the requests.
- , cnfMaxEntityLength :: !Int
+ , cnfMaxEntityLength ∷ !Int
-- |The maximum length of chunk to output. This value is used by
-- 'Network.HTTP.Lucu.Resource.output' and such like to limit the
-- chunk length so you can safely output an infinite string (like
-- a lazy stream of \/dev\/random) using those actions.
- , cnfMaxOutputChunkLength :: !Int
+ , cnfMaxOutputChunkLength ∷ !Int
-- | Whether to dump too late abortion to the stderr or not. See
-- 'Network.HTTP.Lucu.Abortion.abort'.
- , cnfDumpTooLateAbortionToStderr :: !Bool
+ , cnfDumpTooLateAbortionToStderr ∷ !Bool
-- |A mapping from extension to MIME Type. This value is used by
-- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME
-- good idea to use GnomeVFS
-- (<http://developer.gnome.org/doc/API/2.0/gnome-vfs-2.0/>)
-- instead of vanilla FS.
- , cnfExtToMIMEType :: !ExtMap
+ , cnfExtToMIMEType ∷ !ExtMap
}
-- |Configuration record for HTTPS connections.
-- |A port ID to listen to HTTPS clients. Local addresses
-- (both for IPv4 and IPv6) will be derived from the parent
-- 'Config'.
- sslServerPort :: !ServiceName
+ sslServerPort ∷ !ServiceName
-- |An SSL context for accepting connections.
- , sslContext :: !SSLContext
+ , sslContext ∷ !SSLContext
}
-- |The default configuration. Generally you can use this value as-is,
-- or possibly you just want to replace the 'cnfServerSoftware' and
-- 'cnfServerPort'. SSL connections are disabled by default.
-defaultConfig :: Config
+defaultConfig ∷ Config
defaultConfig = Config {
- cnfServerSoftware = C8.pack "Lucu/1.0"
- , cnfServerHost = C8.pack (unsafePerformIO getHostName)
+ cnfServerSoftware = "Lucu/1.0"
+ , cnfServerHost = T.pack (unsafePerformIO getHostName)
, cnfServerPort = "http"
, cnfServerV4Addr = Just "0.0.0.0"
, cnfServerV6Addr = Just "::"
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.ContentCoding
- ( acceptEncodingListP
+ ( AcceptEncoding(..)
+
+ , acceptEncodingListP
, normalizeCoding
, unnormalizeCoding
- , orderAcceptEncodings
)
where
-
-import Data.Char
-import Data.Ord
-import Data.Maybe
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-
-
-acceptEncodingListP :: Parser [(String, Maybe Double)]
-acceptEncodingListP = allowEOF $! listOf accEncP
-
-
-accEncP :: Parser (String, Maybe Double)
-accEncP = do coding <- token
- qVal <- option Nothing
- $ do _ <- string ";q="
- q <- qvalue
- return $ Just q
+import Control.Applicative
+import Data.Ascii (CIAscii, toCIAscii)
+import Data.Attoparsec.Char8
+import Data.Ord
+import Data.Maybe
+import Network.HTTP.Lucu.Parser.Http
+import Prelude.Unicode
+
+data AcceptEncoding
+ = AcceptEncoding !CIAscii !(Maybe Double)
+ deriving (Eq, Show)
+
+instance Ord AcceptEncoding where
+ (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2)
+ | q1' > q1' = GT
+ | q1' < q2' = LT
+ | otherwise = compare c1 c2
+ where
+ q1' = fromMaybe 0 q1
+ q2' = fromMaybe 0 q2
+
+acceptEncodingListP ∷ Parser [(CIAscii, Maybe Double)]
+acceptEncodingListP = listOf accEncP
+
+accEncP ∷ Parser (CIAscii, Maybe Double)
+accEncP = do coding ← toCIAscii <$> token
+ qVal ← option Nothing
+ $ do _ ← string ";q="
+ q ← qvalue
+ return $ Just q
return (normalizeCoding coding, qVal)
-
-normalizeCoding :: String -> String
+normalizeCoding ∷ CIAscii → CIAscii
normalizeCoding coding
- = case map toLower coding of
- "x-gzip" -> "gzip"
- "x-compress" -> "compress"
- other -> other
-
-
-unnormalizeCoding :: String -> String
+ = if coding ≡ "x-gzip" then
+ "gzip"
+ else
+ if coding ≡ "x-compress" then
+ "compress"
+ else
+ coding
+
+unnormalizeCoding ∷ CIAscii → CIAscii
unnormalizeCoding coding
- = case map toLower coding of
- "gzip" -> "x-gzip"
- "compress" -> "x-compress"
- other -> other
-
-
-orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
-orderAcceptEncodings (_, q1) (_, q2)
- = comparing (fromMaybe 0) q1 q2
-
+ = if coding ≡ "gzip" then
+ "x-gzip"
+ else
+ if coding ≡ "compress" then
+ "x-compress"
+ else
+ coding
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnboxedTuples
, UnicodeSyntax
#-}
, mkDefaultPage
)
where
-
-import Control.Arrow
-import Control.Arrow.ArrowList
-import Control.Concurrent.STM
-import Control.Monad
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import Data.Maybe
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Format
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import Network.URI hiding (path)
-import System.IO.Unsafe
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlState
-import Text.XML.HXT.DOM.TypeDefs
-
-
-getDefaultPage :: Config -> Maybe Request -> Response -> String
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.Ascii as A
+import Data.Maybe
+import qualified Data.Sequence as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.URI hiding (path)
+import Prelude.Unicode
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
+import Text.XML.HXT.DOM.TypeDefs
+
+getDefaultPage ∷ Config → Maybe Request → Response → Text
+{-# INLINEABLE getDefaultPage #-}
getDefaultPage !conf !req !res
- = let msgA = getMsg req res
+ = let msgA = getMsg req res
+ [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
+ ⋙
+ writeDocumentToString [ withIndent True ]
+ ) ()
in
- unsafePerformIO $
- do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
- >>>
- writeDocumentToString [ withIndent True ]
- )
- return xmlStr
-
+ T.pack xmlStr
-writeDefaultPage :: Interaction -> STM ()
+writeDefaultPage ∷ Interaction → STM ()
writeDefaultPage !itr
-- Content-Type が正しくなければ補完できない。
- = do res <- readItr itr itrResponse id
- when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
- $ do reqM <- readItr itr itrRequest id
+ = do res ← readItr itr itrResponse id
+ when (getHeader "Content-Type" res == Just defaultPageContentType)
+ $ do reqM ← readItr itr itrRequest id
let conf = itrConfig itr
- page = L8.pack $ getDefaultPage conf reqM res
+ page = getDefaultPage conf reqM res
writeTVar (itrBodyToSend itr)
- $ page
+ (S.singleton (encodeUtf8 page))
-
-mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
+{-# INLINEABLE mkDefaultPage #-}
mkDefaultPage !conf !status !msgA
- = let (# sCode, sMsg #) = statusCode status
- sig = C8.unpack (cnfServerSoftware conf)
- ++ " at "
- ++ C8.unpack (cnfServerHost conf)
+ = let sStr = A.toString $ printStatusCode status
+ sig = concat [ A.toString (cnfServerSoftware conf)
+ , " at "
+ , T.unpack (cnfServerHost conf)
+ ]
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
+ += txt sStr
))
+= ( eelem "body"
+= ( eelem "h1"
- += txt (C8.unpack sMsg)
+ += txt sStr
)
+= ( eelem "p" += msgA )
+= eelem "hr"
+= ( eelem "address" += txt sig ))))
-{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
-getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
+getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
+{-# INLINEABLE getMsg #-}
getMsg !req !res
= case resStatus res of
-- 1xx は body を持たない
-- 3xx
MovedPermanently
- -> txt ("The resource at " ++ path ++ " has been moved to ")
+ → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt " permanently."
Found
- -> txt ("The resource at " ++ path ++ " is currently located at ")
+ → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt ". This is not a permanent relocation."
SeeOther
- -> txt ("The resource at " ++ path ++ " can be found at ")
+ → txt ("The resource at " ⧺ path ⧺ " can be found at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt "."
TemporaryRedirect
- -> txt ("The resource at " ++ path ++ " is temporarily located at ")
+ → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
-- 4xx
BadRequest
- -> txt "The server could not understand the request you sent."
+ → txt "The server could not understand the request you sent."
Unauthorized
- -> txt ("You need a valid authentication to access " ++ path)
+ → txt ("You need a valid authentication to access " ⧺ path)
Forbidden
- -> txt ("You don't have permission to access " ++ path)
+ → txt ("You don't have permission to access " ⧺ path)
NotFound
- -> txt ("The requested URL " ++ path ++ " was not found on this server.")
+ → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
Gone
- -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
+ → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
RequestEntityTooLarge
- -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
+ → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
RequestURITooLarge
- -> txt "The request URI you sent was too big to accept."
+ → txt "The request URI you sent was too large to accept."
-- 5xx
InternalServerError
- -> txt ("An internal server error has occured during the process of your request to " ++ path)
+ → txt ("An internal server error has occured during the process of your request to " ⧺ path)
ServiceUnavailable
- -> txt "The service is temporarily unavailable. Try later."
+ → txt "The service is temporarily unavailable. Try later."
- _ -> none
+ _ → none
-
where
- path :: String
- path = let uri = reqURI $! fromJust req
+ path ∷ String
+ path = let uri = reqURI $ fromJust req
in
uriPath uri
- loc :: String
- loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
-
-{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file
+ loc ∷ String
+ loc = A.toString $ fromJust $ getHeader "Location" res
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of entity tags.
module Network.HTTP.Lucu.ETag
( ETag(..)
+
+ , printETag
+
, strongETag
, weakETag
, eTagP
, eTagListP
)
where
-
-import Control.Monad
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http hiding (token)
-import Network.HTTP.Lucu.Utils
+import Control.Monad
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Parser.Http hiding (token)
+import Network.HTTP.Lucu.Utils
-- |An entity tag is made of a weakness flag and a opaque string.
data ETag = ETag {
-- |The weakness flag. Weak tags looks like W\/\"blahblah\" and
-- strong tags are like \"blahblah\".
- etagIsWeak :: !Bool
+ etagIsWeak ∷ !Bool
-- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~)
-- are allowed.
- , etagToken :: !String
- } deriving (Eq)
+ , etagToken ∷ !Ascii
+ } deriving (Eq, Show)
-instance Show ETag where
- show (ETag isWeak token) = (if isWeak then
- "W/"
- else
- "")
- ++
- quoteStr token
+-- |Convert an 'ETag' to 'Ascii'.
+printETag ∷ ETag → Ascii
+printETag et
+ = A.fromAsciiBuilder $
+ ( ( if etagIsWeak et then
+ A.toAsciiBuilder "W/"
+ else
+ (∅)
+ )
+ ⊕
+ quoteStr (etagToken et) )
-- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to
-- generate an ETag from a file, try using
-- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'.
-strongETag :: String -> ETag
+strongETag ∷ Ascii → ETag
strongETag = ETag False
-- |This is equivalent to @'ETag' 'Prelude.True'@.
-weakETag :: String -> ETag
+weakETag ∷ Ascii → ETag
weakETag = ETag True
-
-eTagP :: Parser ETag
-eTagP = do isWeak <- option False (string "W/" >> return True)
- str <- quotedStr
+eTagP ∷ Parser ETag
+eTagP = do isWeak ← option False (string "W/" ≫ return True)
+ str ← quotedStr
return $ ETag isWeak str
-
-eTagListP :: Parser [ETag]
-eTagListP = allowEOF
- $! do xs <- listOf eTagP
- when (null xs)
- $ fail ""
- return xs
+eTagListP ∷ Parser [ETag]
+eTagListP = do xs ← listOf eTagP
+ when (null xs) $
+ fail "empty list of ETags"
+ return xs
+{-# LANGUAGE
+ OverloadedStrings
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UnicodeSyntax
+ #-}
-- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの
-- で駄目だが、それ以外のモジュールを探しても見付からなかった。
-
module Network.HTTP.Lucu.Format
( fmtInt
, fmtHex
)
where
-
-
-fmtInt :: Int -> Bool -> Int -> Char -> Bool -> Int -> String
-fmtInt base upperCase minWidth pad forceSign n
- = base `seq` minWidth `seq` pad `seq` forceSign `seq` n `seq`
- let raw = reverse $! fmt' (abs n)
- sign = if forceSign || n < 0 then
- if n < 0 then "-" else "+"
- else
- ""
- padded = padStr (minWidth - length sign) pad raw
+import qualified Blaze.ByteString.Builder.Char8 as BC
+import Data.Ascii (AsciiBuilder)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Ascii as A
+import Data.Char
+import Data.Monoid.Unicode
+import Prelude.Unicode
+
+fmtInt ∷ ∀n. Integral n ⇒ n → Int → n → AsciiBuilder
+{-# INLINEABLE fmtInt #-}
+fmtInt base minWidth n
+ = let (# raw, len #) = fmt' (abs n) (∅) 0
in
- sign ++ padded
+ if n < 0 then
+ ( A.toAsciiBuilder "-" ⊕
+ mkPad (minWidth - 1) len ⊕
+ raw
+ )
+ else
+ mkPad minWidth len ⊕ raw
where
- fmt' :: Int -> String
- fmt' m
- | m < base = [intToChar upperCase m]
- | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base)
-
-
-fmtDec :: Int -> Int -> String
+ fmt' ∷ n → AsciiBuilder → Int → (# AsciiBuilder, Int #)
+ {-# INLINEABLE fmt' #-}
+ fmt' x b len
+ | x < base
+ = let b' = b ⊕ fromDigit x
+ in
+ (# b', len + 1 #)
+ | otherwise
+ = let x' = x `div` base
+ y = x `mod` base
+ b' = b ⊕ fromDigit y
+ in
+ fmt' x' b' (len + 1)
+
+mkPad ∷ Int → Int → AsciiBuilder
+{-# INLINEABLE mkPad #-}
+mkPad minWidth len
+ = A.toAsciiBuilder $
+ A.unsafeFromByteString $
+ BS.replicate (minWidth - len) '0'
+
+fmtDec ∷ Integral n ⇒ Int → n → AsciiBuilder
+{-# INLINE fmtDec #-}
fmtDec minWidth n
| minWidth == 2 = fmtDec2 n -- optimization
| minWidth == 3 = fmtDec3 n -- optimization
| minWidth == 4 = fmtDec4 n -- optimization
- | otherwise = fmtInt 10 undefined minWidth '0' False n
-{-# INLINE fmtDec #-}
-
+ | otherwise = fmtInt 10 minWidth n
-fmtDec2 :: Int -> String
+fmtDec2 ∷ Integral n ⇒ n → AsciiBuilder
+{-# INLINEABLE fmtDec2 #-}
fmtDec2 n
- | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback
- | n < 10 = [ '0'
- , intToChar undefined n
- ]
- | otherwise = [ intToChar undefined (n `div` 10)
- , intToChar undefined (n `mod` 10)
- ]
-
-
-fmtDec3 :: Int -> String
+ | n < 0 ∨ n ≥ 100 = fmtInt 10 2 n -- fallback
+ | n < 10 = A.toAsciiBuilder "0" ⊕
+ fromDigit n
+ | otherwise = fromDigit (n `div` 10) ⊕
+ fromDigit (n `mod` 10)
+
+fmtDec3 ∷ Integral n ⇒ n → AsciiBuilder
+{-# INLINEABLE fmtDec3 #-}
fmtDec3 n
- | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback
- | n < 10 = [ '0'
- , '0'
- , intToChar undefined n
- ]
- | n < 100 = [ '0'
- , intToChar undefined ((n `div` 10) `mod` 10)
- , intToChar undefined ( n `mod` 10)
- ]
- | otherwise = [ intToChar undefined ((n `div` 100) `mod` 10)
- , intToChar undefined ((n `div` 10) `mod` 10)
- , intToChar undefined ( n `mod` 10)
- ]
-
-
-fmtDec4 :: Int -> String
+ | n < 0 ∨ n ≥ 1000 = fmtInt 10 3 n -- fallback
+ | n < 10 = A.toAsciiBuilder "00" ⊕
+ fromDigit n
+ | n < 100 = A.toAsciiBuilder "0" ⊕
+ fromDigit ((n `div` 10) `mod` 10) ⊕
+ fromDigit ( n `mod` 10)
+ | otherwise = fromDigit (n `div` 100) ⊕
+ fromDigit ((n `div` 10) `mod` 10) ⊕
+ fromDigit ( n `mod` 10)
+
+fmtDec4 ∷ Integral n ⇒ n → AsciiBuilder
+{-# INLINEABLE fmtDec4 #-}
fmtDec4 n
- | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback
- | n < 10 = [ '0'
- , '0'
- , '0'
- , intToChar undefined n
- ]
- | n < 100 = [ '0'
- , '0'
- , intToChar undefined ((n `div` 10) `mod` 10)
- , intToChar undefined ( n `mod` 10)
- ]
- | n < 1000 = [ '0'
- , intToChar undefined ((n `div` 100) `mod` 10)
- , intToChar undefined ((n `div` 10) `mod` 10)
- , intToChar undefined ( n `mod` 10)
- ]
- | otherwise = [ intToChar undefined ((n `div` 1000) `mod` 10)
- , intToChar undefined ((n `div` 100) `mod` 10)
- , intToChar undefined ((n `div` 10) `mod` 10)
- , intToChar undefined ( n `mod` 10)
- ]
-
-
-fmtHex :: Bool -> Int -> Int -> String
-fmtHex upperCase minWidth
- = fmtInt 16 upperCase minWidth '0' False
-
-
-padStr :: Int -> Char -> String -> String
-padStr minWidth pad str
- = let delta = minWidth - length str
- in
- if delta > 0 then
- replicate delta pad ++ str
- else
- str
-
-
-intToChar :: Bool -> Int -> Char
-intToChar _ 0 = '0'
-intToChar _ 1 = '1'
-intToChar _ 2 = '2'
-intToChar _ 3 = '3'
-intToChar _ 4 = '4'
-intToChar _ 5 = '5'
-intToChar _ 6 = '6'
-intToChar _ 7 = '7'
-intToChar _ 8 = '8'
-intToChar _ 9 = '9'
-intToChar False 10 = 'a'
-intToChar True 10 = 'A'
-intToChar False 11 = 'b'
-intToChar True 11 = 'B'
-intToChar False 12 = 'c'
-intToChar True 12 = 'C'
-intToChar False 13 = 'd'
-intToChar True 13 = 'D'
-intToChar False 14 = 'e'
-intToChar True 14 = 'E'
-intToChar False 15 = 'f'
-intToChar True 15 = 'F'
-intToChar _ _ = undefined
+ | n < 0 ∨ n ≥ 10000 = fmtInt 10 4 n -- fallback
+ | n < 10 = A.toAsciiBuilder "000" ⊕
+ fromDigit n
+ | n < 100 = A.toAsciiBuilder "00" ⊕
+ fromDigit ((n `div` 10) `mod` 10) ⊕
+ fromDigit ( n `mod` 10)
+ | n < 1000 = A.toAsciiBuilder "0" ⊕
+ fromDigit ((n `div` 100) `mod` 10) ⊕
+ fromDigit ((n `div` 10) `mod` 10) ⊕
+ fromDigit ( n `mod` 10)
+ | otherwise = fromDigit (n `div` 1000) ⊕
+ fromDigit ((n `div` 100) `mod` 10) ⊕
+ fromDigit ((n `div` 10) `mod` 10) ⊕
+ fromDigit ( n `mod` 10)
+
+fmtHex ∷ Integral n ⇒ Int → n → AsciiBuilder
+{-# INLINE fmtHex #-}
+fmtHex = fmtInt 16
+
+digitToChar ∷ Integral n ⇒ n → Char
+{-# INLINE digitToChar #-}
+digitToChar n
+ | n < 0 = (⊥)
+ | n < 10 = chr (ord '0' + fromIntegral n )
+ | n < 16 = chr (ord 'A' + fromIntegral (n-10))
+ | otherwise = (⊥)
+
+fromDigit ∷ Integral n ⇒ n → AsciiBuilder
+{-# INLINE fromDigit #-}
+fromDigit = A.unsafeFromBuilder ∘ BC.fromChar ∘ digitToChar
+{-# LANGUAGE
+ BangPatterns
+ , GeneralizedNewtypeDeriving
+ , OverloadedStrings
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Headers
( Headers
, HasHeaders(..)
- , noCaseCmp
- , noCaseEq
-
- , emptyHeaders
, toHeaders
, fromHeaders
, hPutHeaders
)
where
-
-import qualified Data.ByteString as Strict (ByteString)
-import Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Data.Char
-import Data.List
-import Data.Map (Map)
+import Control.Applicative
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.ByteString as BS
+import Data.Map (Map)
import qualified Data.Map as M
-import Data.Ord
-import Data.Word
-import Foreign.ForeignPtr
-import Foreign.Ptr
-import Foreign.Storable
-import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
-
-type Headers = Map NCBS Strict.ByteString
-newtype NCBS = NCBS Strict.ByteString
-
-toNCBS :: Strict.ByteString -> NCBS
-toNCBS = NCBS
-{-# INLINE toNCBS #-}
-
-fromNCBS :: NCBS -> Strict.ByteString
-fromNCBS (NCBS x) = x
-{-# INLINE fromNCBS #-}
-
-instance Eq NCBS where
- (NCBS a) == (NCBS b) = a == b
-
-instance Ord NCBS where
- (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b
-
-instance Show NCBS where
- show (NCBS x) = show x
-
-noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering
-noCaseCmp a b = a `seq` b `seq`
- toForeignPtr a `cmp` toForeignPtr b
- where
- cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
- cmp (x1, s1, l1) (x2, s2, l2)
- | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
- | l1 == 0 && l2 == 0 = EQ
- | x1 == x2 && s1 == s2 && l1 == l2 = EQ
- | otherwise
- = inlinePerformIO $
- withForeignPtr x1 $ \ p1 ->
- withForeignPtr x2 $ \ p2 ->
- noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2
-
-
--- もし先頭の文字列が等しければ、短い方が小さい。
-noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
-noCaseCmp' p1 l1 p2 l2
- | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined
- | l1 == 0 && l2 == 0 = return EQ
- | l1 == 0 = return LT
- | l2 == 0 = return GT
- | otherwise
- = do c1 <- peek p1
- c2 <- peek p2
- case comparing (toLower . w2c) c1 c2 of
- EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
- x -> return x
-
-
-noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool
-noCaseEq a b = a `seq` b `seq`
- toForeignPtr a `cmp` toForeignPtr b
- where
- cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
- cmp (x1, s1, l1) (x2, s2, l2)
- | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
- | l1 /= l2 = False
- | l1 == 0 && l2 == 0 = True
- | x1 == x2 && s1 == s2 && l1 == l2 = True
- | otherwise
- = inlinePerformIO $
- withForeignPtr x1 $ \ p1 ->
- withForeignPtr x2 $ \ p2 ->
- noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1
-
-
-noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
-noCaseEq' p1 p2 l
- | p1 `seq` p2 `seq` l `seq` False = undefined
- | l == 0 = return True
- | otherwise
- = do c1 <- peek p1
- c2 <- peek p2
- if toLower (w2c c1) == toLower (w2c c2) then
- noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
- else
- return False
+import Data.Monoid
+import Data.Monoid.Unicode
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+newtype Headers
+ = Headers (Map CIAscii Ascii)
+ deriving (Eq, Show, Monoid)
class HasHeaders a where
- getHeaders :: a -> Headers
- setHeaders :: a -> Headers -> a
-
- getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
- getHeader key a
- = key `seq` a `seq`
- M.lookup (toNCBS key) (getHeaders a)
-
- deleteHeader :: Strict.ByteString -> a -> a
- deleteHeader key a
- = key `seq` a `seq`
- setHeaders a $ M.delete (toNCBS key) (getHeaders a)
-
- setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a
- setHeader key val a
- = key `seq` val `seq` a `seq`
- setHeaders a $ M.insert (toNCBS key) val (getHeaders a)
-
-
-emptyHeaders :: Headers
-emptyHeaders = M.empty
-
-
-toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers
-toHeaders xs = mkHeaders xs M.empty
-
-
-mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers
-mkHeaders [] m = m
-mkHeaders ((key, val):xs) m = mkHeaders xs $
- case M.lookup (toNCBS key) m of
- Nothing -> M.insert (toNCBS key) val m
- Just old -> M.insert (toNCBS key) (merge old val) m
+ getHeaders ∷ a → Headers
+ setHeaders ∷ a → Headers → a
+
+ getHeader ∷ CIAscii → a → Maybe Ascii
+ {-# INLINE getHeader #-}
+ getHeader !key !a
+ = case getHeaders a of
+ Headers m → M.lookup key m
+
+ deleteHeader ∷ CIAscii → a → a
+ {-# INLINE deleteHeader #-}
+ deleteHeader !key !a
+ = case getHeaders a of
+ Headers m
+ → setHeaders a $ Headers $ M.delete key m
+
+ setHeader ∷ CIAscii → Ascii → a → a
+ {-# INLINE setHeader #-}
+ setHeader !key !val !a
+ = case getHeaders a of
+ Headers m
+ → setHeaders a $ Headers $ M.insert key val m
+
+instance HasHeaders Headers where
+ getHeaders = id
+ setHeaders _ = id
+
+toHeaders ∷ [(CIAscii, Ascii)] → Headers
+{-# INLINE toHeaders #-}
+toHeaders = flip mkHeaders (∅)
+
+mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers
+mkHeaders [] (Headers m) = Headers m
+mkHeaders ((key, val):xs) (Headers m)
+ = mkHeaders xs $ Headers $
+ case M.lookup key m of
+ Nothing → M.insert key val m
+ Just old → M.insert key (merge old val) m
where
- merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
- -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
- -- ヘッダは複數個あってはならない事になってゐる。
+ merge ∷ Ascii → Ascii → Ascii
+ {-# INLINE merge #-}
merge a b
- | C8.null a && C8.null b = C8.empty
- | C8.null a = b
- | C8.null b = a
- | otherwise = C8.concat [a, C8.pack ", ", b]
-
+ | nullA a ∧ nullA b = (∅)
+ | nullA a = b
+ | nullA b = a
+ | otherwise = a ⊕ ", " ⊕ b
-fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
-fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
+ nullA ∷ Ascii → Bool
+ {-# INLINE nullA #-}
+ nullA = BS.null ∘ A.toByteString
+fromHeaders ∷ Headers → [(CIAscii, Ascii)]
+fromHeaders (Headers m) = M.toList m
{-
message-header = field-name ":" [ field-value ]
field-value の先頭および末尾にある LWS は全て削除され、それ以外の
LWS は單一の SP に變換される。
-}
-headersP :: Parser Headers
-headersP = do xs <- many header
- _ <- crlf
- return $! toHeaders xs
+headersP ∷ Parser Headers
+{-# INLINEABLE headersP #-}
+headersP = do xs ← P.many header
+ crlf
+ return $ toHeaders xs
where
- header :: Parser (Strict.ByteString, Strict.ByteString)
- header = do name <- token
- _ <- char ':'
- -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
- -- の記述はひどく曖昧であり、この動作が本當に間違って
- -- ゐるのかどうかも良く分からない。例へば
- -- quoted-string の内部にある空白は纏めていいのか惡い
- -- のか？直勸的には駄目さうに思へるが、そんな記述は見
- -- 付からない。
- contents <- many (lws <|> many1 text)
- _ <- crlf
- let value = foldr (++) "" contents
- norm = normalize value
- return (C8.pack name, C8.pack norm)
-
- normalize :: String -> String
- normalize = trimBody . trim isWhiteSpace
-
- trimBody = concat
- . map (\ s -> if head s == ' ' then
- " "
- else
- s)
- . group
- . map (\ c -> if isWhiteSpace c
- then ' '
- else c)
-
-
-hPutHeaders :: HandleLike h => h -> Headers -> IO ()
-hPutHeaders h hds
- = h `seq` hds `seq`
- mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
+ header ∷ Parser (CIAscii, Ascii)
+ header = do name ← A.toCIAscii <$> token
+ _ ← char ':'
+ skipMany lws
+ values ← sepBy content (try lws)
+ skipMany (try lws)
+ crlf
+ return (name, joinValues values)
+
+ content ∷ Parser Ascii
+ {-# INLINE content #-}
+ content = A.unsafeFromByteString
+ <$>
+ takeWhile1 (\c → ((¬) (isSPHT c)) ∧ isText c)
+
+ joinValues ∷ [Ascii] → Ascii
+ {-# INLINE joinValues #-}
+ joinValues = A.fromAsciiBuilder ∘ joinWith "\x20" ∘ map A.toAsciiBuilder
+
+hPutHeaders ∷ HandleLike h => h → Headers → IO ()
+hPutHeaders !h !(Headers m)
+ = mapM_ putH (M.toList m) >> hPutBS h "\r\n"
where
- putH :: (NCBS, Strict.ByteString) -> IO ()
- putH (name, value)
- = name `seq` value `seq`
- do hPutBS h (fromNCBS name)
- hPutBS h (C8.pack ": ")
- hPutBS h value
- hPutBS h (C8.pack "\r\n")
+ putH ∷ (CIAscii, Ascii) → IO ()
+ putH (!name, !value)
+ = do hPutBS h (A.ciToByteString name)
+ hPutBS h ": "
+ hPutBS h (A.toByteString value)
+ hPutBS h "\r\n"
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnicodeSyntax
#-}
{-# OPTIONS_HADDOCK prune #-}
, hPutHttpVersion
)
where
-
-import qualified Data.ByteString.Char8 as C8
-import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.Parser
-import Prelude hiding (min)
+import Control.Monad.Unicode
+import Data.Attoparsec.Char8
+import Network.HTTP.Lucu.HandleLike
+import Prelude hiding (min)
-- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
-data HttpVersion = HttpVersion !Int !Int
- deriving (Eq)
-
-instance Show HttpVersion where
- show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min
+data HttpVersion
+ = HttpVersion !Int !Int
+ deriving (Eq, Show)
instance Ord HttpVersion where
(HttpVersion majA minA) `compare` (HttpVersion majB minB)
| minA < minB = LT
| otherwise = EQ
-
-httpVersionP :: Parser HttpVersion
+httpVersionP ∷ Parser HttpVersion
httpVersionP = string "HTTP/"
- >>
- -- 頻出するので高速化
- choice [ string "1.0" >> return (HttpVersion 1 0)
- , string "1.1" >> return (HttpVersion 1 1)
- -- 一般の場合
- , do major <- many1 digit
- _ <- char '.'
- minor <- many1 digit
- return $ HttpVersion (read major) (read minor)
+ ≫
+ choice [ string "1.1" ≫ return (HttpVersion 1 1)
+ , string "1.0" ≫ return (HttpVersion 1 0)
+ , do major ← decimal
+ _ ← char '.'
+ minor ← decimal
+ return $ HttpVersion major minor
]
-
-hPutHttpVersion :: HandleLike h => h -> HttpVersion -> IO ()
+hPutHttpVersion ∷ HandleLike h ⇒ h → HttpVersion → IO ()
hPutHttpVersion !h !v
= case v of
-- 頻出するので高速化
- HttpVersion 1 0 -> hPutBS h (C8.pack "HTTP/1.0")
- HttpVersion 1 1 -> hPutBS h (C8.pack "HTTP/1.1")
+ HttpVersion 1 0 → hPutBS h "HTTP/1.0"
+ HttpVersion 1 1 → hPutBS h "HTTP/1.1"
-- 一般の場合
HttpVersion !maj !min
- -> do hPutBS h (C8.pack "HTTP/")
- hPutStr h (show maj)
- hPutChar h '.'
- hPutStr h (show min)
+ → do hPutBS h "HTTP/"
+ hPutStr h (show maj)
+ hPutChar h '.'
+ hPutStr h (show min)
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
, updateItrF
)
where
-
-import Control.Concurrent.STM
-import qualified Data.ByteString as Strict (ByteString)
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import Data.ByteString.Char8 as C8 hiding (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
+import Control.Applicative
+import Control.Concurrent.STM
+import Data.Ascii (Ascii)
+import qualified Data.ByteString as BS
+import Data.Sequence (Seq)
import qualified Data.Sequence as S
-import Data.Sequence (Seq)
-import Network.Socket
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import OpenSSL.X509
+import Network.Socket
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import OpenSSL.X509
+import Prelude.Unicode
data Interaction = Interaction {
- itrConfig :: !Config
- , itrLocalPort :: !PortNumber
- , itrRemoteAddr :: !SockAddr
- , itrRemoteCert :: !(Maybe X509)
- , itrResourcePath :: !(Maybe [String])
- , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
- , itrResponse :: !(TVar Response)
-
- , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し
- , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し
- , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し
-
- , itrReqChunkLength :: !(TVar (Maybe Int))
- , itrReqChunkRemaining :: !(TVar (Maybe Int))
- , itrReqChunkIsOver :: !(TVar Bool)
- , itrReqBodyWanted :: !(TVar (Maybe Int))
- , itrReqBodyWasteAll :: !(TVar Bool)
- , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
-
- , itrWillReceiveBody :: !(TVar Bool)
- , itrWillChunkBody :: !(TVar Bool)
- , itrWillDiscardBody :: !(TVar Bool)
- , itrWillClose :: !(TVar Bool)
-
- , itrBodyToSend :: !(TVar Lazy.ByteString)
- , itrBodyIsNull :: !(TVar Bool)
-
- , itrState :: !(TVar InteractionState)
-
- , itrWroteContinue :: !(TVar Bool)
- , itrWroteHeader :: !(TVar Bool)
+ itrConfig ∷ !Config
+ , itrLocalPort ∷ !PortNumber
+ , itrRemoteAddr ∷ !SockAddr
+ , itrRemoteCert ∷ !(Maybe X509)
+ , itrResourcePath ∷ !(Maybe [Ascii])
+ , itrRequest ∷ !(TVar (Maybe Request))
+ , itrResponse ∷ !(TVar Response)
+
+ , itrRequestHasBody ∷ !(TVar Bool)
+ , itrRequestIsChunked ∷ !(TVar Bool)
+ , itrExpectedContinue ∷ !(TVar Bool)
+
+ , itrReqChunkLength ∷ !(TVar (Maybe Int))
+ , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
+ , itrReqChunkIsOver ∷ !(TVar Bool)
+ , itrReqBodyWanted ∷ !(TVar (Maybe Int))
+ , itrReqBodyWasteAll ∷ !(TVar Bool)
+ , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
+
+ , itrWillReceiveBody ∷ !(TVar Bool)
+ , itrWillChunkBody ∷ !(TVar Bool)
+ , itrWillDiscardBody ∷ !(TVar Bool)
+ , itrWillClose ∷ !(TVar Bool)
+
+ , itrBodyToSend ∷ !(TVar (Seq BS.ByteString))
+ , itrBodyIsNull ∷ !(TVar Bool)
+
+ , itrState ∷ !(TVar InteractionState)
+
+ , itrWroteContinue ∷ !(TVar Bool)
+ , itrWroteHeader ∷ !(TVar Bool)
}
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingRequest。
+-- |The interaction state of Resource monad. 'ExaminingRequest' is the
+-- initial state.
data InteractionState = ExaminingRequest
| GettingBody
| DecidingHeader
type InteractionQueue = TVar (Seq Interaction)
-
-newInteractionQueue :: IO InteractionQueue
+newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
+defaultPageContentType ∷ Ascii
+defaultPageContentType = "application/xhtml+xml"
-defaultPageContentType :: Strict.ByteString
-defaultPageContentType = C8.pack "application/xhtml+xml"
-
-
-newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
+newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
newInteraction !conf !port !addr !cert !req
- = do request <- newTVarIO req
- responce <- newTVarIO Response {
+ = do request ← newTVarIO req
+ responce ← newTVarIO Response {
resVersion = HttpVersion 1 1
, resStatus = Ok
- , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
+ , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
}
- requestHasBody <- newTVarIO False
- requestIsChunked <- newTVarIO False
- expectedContinue <- newTVarIO False
+ requestHasBody ← newTVarIO False
+ requestIsChunked ← newTVarIO False
+ expectedContinue ← newTVarIO False
- reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
- reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
- reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
- reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
- reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
- receivedBody <- newTVarIO L8.empty
+ reqChunkLength ← newTVarIO Nothing -- 現在のチャンク長
+ reqChunkRemaining ← newTVarIO Nothing -- 現在のチャンクの殘り
+ reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた
+ reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
+ reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
+ receivedBody ← newTVarIO S.empty
- willReceiveBody <- newTVarIO False
- willChunkBody <- newTVarIO False
- willDiscardBody <- newTVarIO False
- willClose <- newTVarIO False
+ willReceiveBody ← newTVarIO False
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO False
+ willClose ← newTVarIO False
- bodyToSend <- newTVarIO L8.empty
- bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
+ bodyToSend ← newTVarIO S.empty
+ bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
- state <- newTVarIO ExaminingRequest
+ state ← newTVarIO ExaminingRequest
- wroteContinue <- newTVarIO False
- wroteHeader <- newTVarIO False
+ wroteContinue ← newTVarIO False
+ wroteHeader ← newTVarIO False
return Interaction {
itrConfig = conf
, itrWroteHeader = wroteHeader
}
+writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
+{-# INLINE writeItr #-}
+writeItr itr accessor
+ = writeTVar (accessor itr)
-writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr !itr !accessor !value
- = writeTVar (accessor itr) value
-
+readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
+{-# INLINE readItr #-}
+readItr itr accessor reader
+ = reader <$> readTVar (accessor itr)
-readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-readItr !itr !accessor !reader
- = fmap reader $ readTVar (accessor itr)
-
-
-readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-readItrF !itr !accessor !reader
+readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
+{-# INLINE readItrF #-}
+readItrF itr accessor reader
= readItr itr accessor (fmap reader)
-{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
-
-updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
-updateItr !itr !accessor !updator
- = do old <- readItr itr accessor id
+updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
+{-# INLINE updateItr #-}
+updateItr itr accessor updator
+ = do old ← readItr itr accessor id
writeItr itr accessor (updator old)
-
-updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
-updateItrF !itr !accessor !updator
- = updateItr itr accessor (fmap updator)
-{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file
+updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
+{-# INLINE updateItrF #-}
+updateItrF itr accessor
+ = updateItr itr accessor ∘ fmap
{-# LANGUAGE
- UnboxedTuples
+ OverloadedStrings
, UnicodeSyntax
#-}
{-# OPTIONS_HADDOCK prune #-}
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
, parseMIMEType
+ , printMIMEType
+
, mimeTypeP
, mimeTypeListP
)
where
-
-import qualified Data.ByteString.Lazy as B
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
-import Prelude hiding (min)
+import Control.Applicative
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.ByteString.Char8 as C8
+import Data.Map (Map)
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.RFC2231
+import Prelude hiding (min)
+import Prelude.Unicode
-- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
-- represents \"major\/minor; name=value\".
data MIMEType = MIMEType {
- mtMajor :: !String
- , mtMinor :: !String
- , mtParams :: ![ (String, String) ]
- } deriving (Eq)
-
-
-instance Show MIMEType where
- show (MIMEType maj min params)
- = maj ++ "/" ++ min ++
- if null params then
- ""
- else
- "; " ++ joinWith "; " (map showPair params)
- where
- showPair :: (String, String) -> String
- showPair (name, value)
- = name ++ "=" ++ if any (not . isToken) value then
- quoteStr value
- else
- value
+ mtMajor ∷ !CIAscii
+ , mtMinor ∷ !CIAscii
+ , mtParams ∷ !(Map CIAscii Text)
+ } deriving (Eq, Show)
+-- |Convert a 'MIMEType' to 'Ascii'.
+printMIMEType ∷ MIMEType → Ascii
+printMIMEType (MIMEType maj min params)
+ = A.fromAsciiBuilder $
+ ( A.toAsciiBuilder (A.fromCIAscii maj) ⊕
+ A.toAsciiBuilder "/" ⊕
+ A.toAsciiBuilder (A.fromCIAscii min) ⊕
+ printParams params
+ )
-instance Read MIMEType where
- readsPrec _ s = [(parseMIMEType s, "")]
-
--- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an
+-- |Parse 'MIMEType' from an 'Ascii'. This function throws an
-- exception for parse error.
-parseMIMEType :: String -> MIMEType
-parseMIMEType str = case parseStr mimeTypeP str of
- (# Success t, r #) -> if B.null r
- then t
- else error ("unparsable MIME Type: " ++ str)
- (# _ , _ #) -> error ("unparsable MIME Type: " ++ str)
-
+parseMIMEType ∷ Ascii → MIMEType
+parseMIMEType str
+ = let p = do t ← mimeTypeP
+ endOfInput
+ return t
+ bs = A.toByteString str
+ in
+ case parseOnly p bs of
+ Right t → t
+ Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)
-mimeTypeP :: Parser MIMEType
-mimeTypeP = allowEOF $!
- do maj <- token
- _ <- char '/'
- min <- token
- params <- many paramP
+mimeTypeP ∷ Parser MIMEType
+mimeTypeP = do maj ← A.toCIAscii <$> token
+ _ ← char '/'
+ min ← A.toCIAscii <$> token
+ params ← paramsP
return $ MIMEType maj min params
- where
- paramP :: Parser (String, String)
- paramP = do _ <- many lws
- _ <- char ';'
- _ <- many lws
- name <- token
- _ <- char '='
- value <- token <|> quotedStr
- return (name, value)
-mimeTypeListP :: Parser [MIMEType]
-mimeTypeListP = allowEOF $! listOf mimeTypeP
+mimeTypeListP ∷ Parser [MIMEType]
+mimeTypeListP = listOf mimeTypeP
+++ /dev/null
--- |This module is automatically generated from data\/mime.types.
--- 'defaultExtensionMap' contains every possible pairs of an extension
--- and a MIME Type.
-
-{- !!! WARNING !!!
- This file is automatically generated.
- DO NOT EDIT BY HAND OR YOU WILL REGRET -}
-
-module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
- (defaultExtensionMap) where
-import Network.HTTP.Lucu.MIMEType ()
-import Network.HTTP.Lucu.MIMEType.Guess
-import qualified Data.Map as M
-
-defaultExtensionMap :: ExtMap
-defaultExtensionMap
- = M.fromList
- [("3gp", read "application/x-3gp"), ("669", read "audio/x-mod"),
- ("Z", read "application/x-compress"),
- ("a", read "application/x-ar"), ("ac3", read "audio/x-ac3"),
- ("ai", read "application/postscript"),
- ("aif", read "audio/x-aiff"), ("aifc", read "audio/x-aiff"),
- ("aiff", read "audio/x-aiff"), ("amf", read "audio/x-mod"),
- ("anx", read "application/ogg"), ("ape", read "application/x-ape"),
- ("asc", read "text/plain"), ("asf", read "video/x-ms-asf"),
- ("atom", read "application/atom+xml"), ("au", read "audio/x-au"),
- ("avi", read "video/x-msvideo"),
- ("bcpio", read "application/x-bcpio"),
- ("bin", read "application/octet-stream"),
- ("bmp", read "image/bmp"), ("bz2", read "application/x-bzip"),
- ("cabal", read "text/x-cabal"),
- ("cdf", read "application/x-netcdf"), ("cgm", read "image/cgm"),
- ("class", read "application/octet-stream"),
- ("cpio", read "application/x-cpio"),
- ("cpt", read "application/mac-compactpro"),
- ("csh", read "application/x-csh"), ("css", read "text/css"),
- ("dcr", read "application/x-director"), ("dif", read "video/x-dv"),
- ("dir", read "application/x-director"),
- ("djv", read "image/vnd.djvu"), ("djvu", read "image/vnd.djvu"),
- ("dll", read "application/octet-stream"),
- ("dmg", read "application/octet-stream"),
- ("dms", read "application/octet-stream"),
- ("doc", read "application/msword"), ("dsm", read "audio/x-mod"),
- ("dtd", read "application/xml-dtd"), ("dv", read "video/x-dv"),
- ("dvi", read "application/x-dvi"),
- ("dxr", read "application/x-director"),
- ("eps", read "application/postscript"),
- ("etx", read "text/x-setext"),
- ("exe", read "application/octet-stream"),
- ("ez", read "application/andrew-inset"),
- ("far", read "audio/x-mod"), ("flac", read "audio/x-flac"),
- ("flc", read "video/x-fli"), ("fli", read "video/x-fli"),
- ("flv", read "video/x-flv"), ("gdm", read "audio/x-mod"),
- ("gif", read "image/gif"), ("gram", read "application/srgs"),
- ("grxml", read "application/srgs+xml"),
- ("gtar", read "application/x-gtar"),
- ("gz", read "application/x-gzip"),
- ("hdf", read "application/x-hdf"),
- ("hi", read "application/octet-stream"),
- ("hqx", read "application/mac-binhex40"),
- ("hs", read "text/x-haskell"), ("htm", read "text/html"),
- ("html", read "text/html"),
- ("ice", read "x-conference/x-cooltalk"),
- ("ico", read "image/x-icon"), ("ics", read "text/calendar"),
- ("ief", read "image/ief"), ("ifb", read "text/calendar"),
- ("iff", read "audio/x-svx"), ("iges", read "model/iges"),
- ("igs", read "model/iges"), ("ilbc", read "audio/iLBC-sh"),
- ("imf", read "audio/x-mod"), ("it", read "audio/x-mod"),
- ("jng", read "image/x-jng"),
- ("jnlp", read "application/x-java-jnlp-file"),
- ("jp2", read "image/jp2"), ("jpe", read "image/jpeg"),
- ("jpeg", read "image/jpeg"), ("jpg", read "image/jpeg"),
- ("js", read "application/x-javascript"),
- ("kar", read "audio/midi"), ("latex", read "application/x-latex"),
- ("lha", read "application/octet-stream"),
- ("lzh", read "application/octet-stream"),
- ("m3u", read "audio/x-mpegurl"), ("m4a", read "audio/mp4a-latm"),
- ("m4p", read "audio/mp4a-latm"), ("m4u", read "video/vnd.mpegurl"),
- ("m4v", read "video/mpeg4"), ("mac", read "image/x-macpaint"),
- ("man", read "application/x-troff-man"),
- ("mathml", read "application/mathml+xml"),
- ("me", read "application/x-troff-me"), ("med", read "audio/x-mod"),
- ("mesh", read "model/mesh"), ("mid", read "audio/midi"),
- ("midi", read "audio/midi"), ("mif", read "application/vnd.mif"),
- ("mka", read "video/x-matroska"), ("mkv", read "video/x-matroska"),
- ("mng", read "video/x-mng"), ("mod", read "audio/x-mod"),
- ("mov", read "video/quicktime"),
- ("movie", read "video/x-sgi-movie"), ("mp2", read "audio/mpeg"),
- ("mp3", read "audio/mpeg"), ("mp4", read "video/mp4"),
- ("mpc", read "audio/x-musepack"), ("mpe", read "video/mpeg"),
- ("mpeg", read "video/mpeg"), ("mpg", read "video/mpeg"),
- ("mpga", read "audio/mpeg"), ("ms", read "application/x-troff-ms"),
- ("msh", read "model/mesh"), ("mtm", read "audio/x-mod"),
- ("mve", read "video/x-mve"), ("mxu", read "video/vnd.mpegurl"),
- ("nar", read "application/x-nar"),
- ("nc", read "application/x-netcdf"), ("nist", read "audio/x-nist"),
- ("nuv", read "video/x-nuv"),
- ("o", read "application/octet-stream"),
- ("oda", read "application/oda"), ("ogg", read "application/ogg"),
- ("ogm", read "application/ogg"), ("okt", read "audio/x-mod"),
- ("paf", read "audio/x-paris"),
- ("pbm", read "image/x-portable-bitmap"),
- ("pct", read "image/pict"), ("pdb", read "chemical/x-pdb"),
- ("pdf", read "application/pdf"),
- ("pgm", read "image/x-portable-graymap"),
- ("pgn", read "application/x-chess-pgn"),
- ("pic", read "image/pict"), ("pict", read "image/pict"),
- ("png", read "image/png"), ("pnm", read "image/x-portable-anymap"),
- ("pnt", read "image/x-macpaint"),
- ("pntg", read "image/x-macpaint"),
- ("ppm", read "image/x-portable-pixmap"),
- ("ppt", read "application/vnd.ms-powerpoint"),
- ("ps", read "application/postscript"),
- ("qif", read "image/x-quicktime"), ("qt", read "video/quicktime"),
- ("qti", read "image/x-quicktime"),
- ("qtif", read "image/x-quicktime"),
- ("ra", read "audio/x-pn-realaudio"), ("ram", read "text/uri-list"),
- ("rar", read "application/x-rar"),
- ("ras", read "image/x-sun-raster"),
- ("rdf", read "application/rdf+xml"), ("rgb", read "image/x-rgb"),
- ("rm", read "application/vnd.rn-realmedia"),
- ("roff", read "application/x-troff"), ("rtf", read "text/rtf"),
- ("rtx", read "text/richtext"), ("s3m", read "audio/x-mod"),
- ("sam", read "audio/x-mod"), ("sds", read "audio/x-sds"),
- ("sf", read "audio/x-ircam"), ("sgm", read "text/sgml"),
- ("sgml", read "text/sgml"), ("sh", read "application/x-sh"),
- ("shar", read "application/x-shar"),
- ("shn", read "audio/x-shorten"), ("sid", read "audio/x-sid"),
- ("silo", read "model/mesh"), ("sit", read "application/x-stuffit"),
- ("skd", read "application/x-koan"),
- ("skm", read "application/x-koan"),
- ("skp", read "application/x-koan"),
- ("skt", read "application/x-koan"),
- ("smi", read "application/smil"),
- ("smil", read "application/smil"), ("snd", read "audio/x-au"),
- ("so", read "application/octet-stream"),
- ("spc", read "application/x-spc"),
- ("spl", read "application/x-futuresplash"),
- ("src", read "application/x-wais-source"),
- ("stm", read "audio/x-mod"), ("stx", read "audio/x-mod"),
- ("sv4cpio", read "application/x-sv4cpio"),
- ("sv4crc", read "application/x-sv4crc"),
- ("svg", read "image/svg+xml"), ("svx", read "audio/x-svx"),
- ("swf", read "application/x-shockwave-flash"),
- ("swfl", read "application/x-shockwave-flash"),
- ("t", read "application/x-troff"),
- ("tar", read "application/x-tar"),
- ("tbz", read "application/x-bzip"),
- ("tcl", read "application/x-tcl"),
- ("tex", read "application/x-tex"),
- ("texi", read "application/x-texinfo"),
- ("texinfo", read "application/x-texinfo"),
- ("tgz", read "application/x-gzip"), ("tif", read "image/tiff"),
- ("tiff", read "image/tiff"), ("tr", read "application/x-troff"),
- ("ts", read "video/mpegts"),
- ("tsv", read "text/tab-separated-values"),
- ("tta", read "audio/x-ttafile"), ("txt", read "text/plain"),
- ("ult", read "audio/x-mod"), ("ustar", read "application/x-ustar"),
- ("vcd", read "application/x-cdlink"), ("voc", read "audio/x-voc"),
- ("vrml", read "model/vrml"),
- ("vxml", read "application/voicexml+xml"),
- ("w64", read "audio/x-w64"), ("wav", read "audio/x-wav"),
- ("wbmp", read "image/vnd.wap.wbmp"),
- ("wbxml", read "application/vnd.wap.wbxml"),
- ("wm", read "video/x-ms-asf"), ("wma", read "video/x-ms-asf"),
- ("wml", read "text/vnd.wap.wml"),
- ("wmlc", read "application/vnd.wap.wmlc"),
- ("wmls", read "text/vnd.wap.wmlscript"),
- ("wmlsc", read "application/vnd.wap.wmlscriptc"),
- ("wmv", read "video/x-ms-asf"), ("wrl", read "model/vrml"),
- ("wv", read "audio/x-wavpack"),
- ("wvc", read "audio/x-wavpack-correction"),
- ("wvp", read "audio/x-wavpack"), ("xbm", read "image/x-xbitmap"),
- ("xcf", read "image/x-xcf"), ("xht", read "application/xhtml+xml"),
- ("xhtml", read "application/xhtml+xml"),
- ("xls", read "application/vnd.ms-excel"),
- ("xm", read "audio/x-mod"), ("xml", read "application/xml"),
- ("xpm", read "image/x-xpixmap"), ("xsl", read "application/xml"),
- ("xslt", read "application/xslt+xml"),
- ("xul", read "application/vnd.mozilla.xul+xml"),
- ("xwd", read "image/x-xwindowdump"),
- ("xyz", read "chemical/x-xyz"), ("zip", read "application/zip")]
{-# LANGUAGE
- UnboxedTuples
+ BangPatterns
, UnicodeSyntax
#-}
-- |MIME Type guessing by a file extension. This is a poor man's way
, serializeExtMap
)
where
-
+import Control.Applicative
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import qualified Data.Attoparsec.Lazy as AL
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Maybe
-import Language.Haskell.Pretty
-import Language.Haskell.Syntax
-import Network.HTTP.Lucu.MIMEType
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
+import Data.Map (Map)
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Language.Haskell.Pretty
+import Language.Haskell.Syntax
+import Network.HTTP.Lucu.MIMEType
+import Prelude.Unicode
+import System.FilePath
--- |'Data.Map.Map' from extension to MIME Type.
-type ExtMap = Map String MIMEType
+-- |'Map' from extension to 'MIMEType'.
+type ExtMap = Map Text MIMEType
-- |Guess the MIME Type of file.
-guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
-guessTypeByFileName extMap fpath
- = extMap `seq` fpath `seq`
- let ext = last $ splitBy (== '.') fpath
+guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
+guessTypeByFileName !extMap !fpath
+ = let ext = T.pack $ takeExtension fpath
in
- M.lookup ext extMap >>= return
+ M.lookup ext extMap
-- |Read an Apache mime.types and parse it.
-parseExtMapFile :: FilePath -> IO ExtMap
+parseExtMapFile ∷ FilePath → IO ExtMap
parseExtMapFile fpath
- = fpath `seq`
- do file <- B.readFile fpath
- case parse (allowEOF extMapP) file of
- (# Success xs, _ #)
- -> return $ compile xs
-
- (# _, input' #)
- -> let near = B.unpack $ B.take 100 input'
- in
- fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
-
+ = do file ← B.readFile fpath
+ case AL.parse extMapP file of
+ AL.Done _ xs → return $ compile xs
+ AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
-extMapP :: Parser [ (MIMEType, [String]) ]
-extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
- eof
+extMapP ∷ Parser [ (MIMEType, [Text]) ]
+extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
+ endOfInput
return $ catMaybes xs
where
- spc = oneOf " \t"
+ isSpc ∷ Char → Bool
+ isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
- comment = many spc >>
- char '#' >>
- ( many $ satisfy (/= '\n') ) >>
- return Nothing
+ comment ∷ Parser (Maybe (MIMEType, [Text]))
+ comment = try $
+ do skipWhile isSpc
+ _ ← char '#'
+ skipWhile (≢ '\x0A')
+ return Nothing
- validLine = do _ <- many spc
- mime <- mimeTypeP
- _ <- many spc
- exts <- sepBy token (many spc)
+ validLine ∷ Parser (Maybe (MIMEType, [Text]))
+ validLine = try $
+ do skipWhile isSpc
+ mime ← mimeTypeP
+ skipWhile isSpc
+ exts ← sepBy extP (skipWhile isSpc)
return $ Just (mime, exts)
- emptyLine = oneOf " \t\n" >> return Nothing
+ extP ∷ Parser Text
+ extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
+ emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
+ emptyLine = try $
+ do skipWhile isSpc
+ _ ← char '\x0A'
+ return Nothing
-compile :: [ (MIMEType, [String]) ] -> Map String MIMEType
-compile = M.fromList . foldr (++) [] . map tr
+compile ∷ [ (MIMEType, [Text]) ] → Map Text MIMEType
+compile = M.fromList ∘ concat ∘ map tr
where
- tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]
- tr (mime, exts) = [ (ext, mime) | ext <- exts ]
+ tr ∷ (MIMEType, [Text]) → [ (Text, MIMEType) ]
+ tr (mime, exts) = [ (ext, mime) | ext ← exts ]
-- |@'serializeExtMap' extMap moduleName variableName@ generates a
-- Haskell source code which contains the following things:
--
-- * A definition of module named @moduleName@.
--
--- * @variableName :: 'ExtMap'@ whose content is a serialization of
+-- * @variableName ∷ 'ExtMap'@ whose content is a serialization of
-- @extMap@.
--
-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
-- surely generated using this function.
-serializeExtMap :: ExtMap -> String -> String -> String
+serializeExtMap ∷ ExtMap → String → String → String
serializeExtMap extMap moduleName variableName
- = let hsModule = HsModule undefined modName (Just exports) imports decls
+ = let hsModule = HsModule (⊥) modName (Just exports) imports decls
modName = Module moduleName
exports = [HsEVar (UnQual (HsIdent variableName))]
- imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, []))
- , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
- , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
+ imports = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+ , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
+ , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing
+ , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing
+ , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing
]
- decls = [ HsTypeSig undefined [HsIdent variableName]
+ decls = [ HsTypeSig (⊥) [HsIdent variableName]
(HsQualType []
(HsTyCon (UnQual (HsIdent "ExtMap"))))
- , HsFunBind [HsMatch undefined (HsIdent variableName)
+ , HsFunBind [HsMatch (⊥) (HsIdent variableName)
[] (HsUnGuardedRhs extMapExp) []]
]
extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
in
comment ++ prettyPrint hsModule ++ "\n"
where
- records :: [HsExp]
+ records ∷ [HsExp]
records = map record $ M.assocs extMap
- record :: (String, MIMEType) -> HsExp
+ record ∷ (Text, MIMEType) → HsExp
record (ext, mime)
- = HsTuple [HsLit (HsString ext), mimeToExp mime]
+ = HsTuple
+ [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack")))
+ (HsLit (HsString (T.unpack ext)))
+ , mimeToExp mime
+ ]
- mimeToExp :: MIMEType -> HsExp
+ mimeToExp ∷ MIMEType → HsExp
mimeToExp mt
- = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))
+ = HsApp (HsVar (UnQual (HsIdent "parseMIMEType")))
+ (HsParen
+ (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString")))
+ (HsLit (HsString $ A.toString $ printMIMEType mt))))
{-# LANGUAGE
- UnboxedTuples
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , ScopedTypeVariables
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.MultipartForm
, multipartFormP
)
where
-
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import Data.Char
-import Data.List
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
-
-
-data Part = Part Headers L8.ByteString
+import Control.Applicative hiding (many)
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LS
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.RFC2231
+import Prelude.Unicode
-- |This data type represents a form value and possibly an uploaded
-- file name.
data FormData
= FormData {
- fdFileName :: Maybe String
- , fdContent :: L8.ByteString
+ fdFileName ∷ Maybe Text
+ , fdContent ∷ LS.ByteString
}
-instance HasHeaders Part where
- getHeaders (Part hs _) = hs
- setHeaders (Part _ b) hs = Part hs b
-
+data Part
+ = Part {
+ ptHeaders ∷ Headers
+ , ptContDispo ∷ ContDispo
+ , ptBody ∷ LS.ByteString
+ }
-data ContDispo = ContDispo String [(String, String)]
+instance HasHeaders Part where
+ getHeaders = ptHeaders
+ setHeaders pt hs = pt { ptHeaders = hs }
-instance Show ContDispo where
- show (ContDispo dType dParams)
- = dType ++
- if null dParams then
- ""
- else
- "; " ++ joinWith "; " (map showPair dParams)
- where
- showPair :: (String, String) -> String
- showPair (name, value)
- = name ++ "=" ++ if any (not . isToken) value then
- quoteStr value
- else
- value
+data ContDispo
+ = ContDispo {
+ dType ∷ !CIAscii
+ , dParams ∷ !(Map CIAscii Text)
+ }
+printContDispo ∷ ContDispo → Ascii
+printContDispo d
+ = A.fromAsciiBuilder $
+ ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
+ ⊕
+ printParams (dParams d) )
-multipartFormP :: String -> Parser [(String, FormData)]
+multipartFormP ∷ Ascii → Parser [(Text, FormData)]
multipartFormP boundary
- = do parts <- many (partP boundary)
- _ <- string "--"
- _ <- string boundary
- _ <- string "--"
- _ <- crlf
- eof
- return $ map partToFormPair parts
-
-
-partP :: String -> Parser Part
+ = do parts ← many $ try $ partP boundary
+ _ ← string "--"
+ _ ← string $ A.toByteString boundary
+ _ ← string "--"
+ crlf
+ catMaybes <$> mapM partToFormPair parts
+
+partP ∷ Ascii → Parser Part
partP boundary
- = do _ <- string "--"
- _ <- string boundary
- _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
- hs <- headersP
- body <- bodyP boundary
- return $ Part hs body
-
-
-bodyP :: String -> Parser L8.ByteString
+ = do _ ← string "--"
+ _ ← string $ A.toByteString boundary
+ crlf
+ hs ← headersP
+ d ← getContDispo hs
+ body ← bodyP boundary
+ return $ Part hs d body
+
+bodyP ∷ Ascii → Parser LS.ByteString
bodyP boundary
- = do body <- manyChar $
- do notFollowedBy $ ( crlf >>
- string "--" >>
- string boundary )
- anyChar
- _ <- crlf
+ = do body ← manyCharsTill anyChar $
+ try $
+ do crlf
+ _ ← string "--"
+ _ ← string $ A.toByteString boundary
+ return ()
+ crlf
return body
-
-partToFormPair :: Part -> (String, FormData)
-partToFormPair part@(Part _ body)
- = let name = partName part
- fname = partFileName part
- fd = FormData {
- fdFileName = fname
- , fdContent = body
- }
- in (name, fd)
-
-partName :: Part -> String
-partName = getName' . getContDispoFormData
- where
- getName' :: ContDispo -> String
- getName' dispo@(ContDispo _ dParams)
- = case find ((== "name") . map toLower . fst) dParams of
- Just (_, name) -> name
- Nothing
- -> abortPurely BadRequest []
- (Just $ "form-data without name: " ++ show dispo)
-
-
-partFileName :: Part -> Maybe String
-partFileName = getFileName' . getContDispoFormData
- where
- getFileName' :: ContDispo -> Maybe String
- getFileName' (ContDispo _ dParams)
- = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
- return fileName
-
-getContDispoFormData :: Part -> ContDispo
-getContDispoFormData part
- = let dispo@(ContDispo dType _) = getContDispo part
- in
- if map toLower dType == "form-data" then
- dispo
- else
- abortPurely BadRequest []
- (Just $ "Content-Disposition type is not form-data: " ++ dType)
-
-
-getContDispo :: Part -> ContDispo
-getContDispo part
- = case getHeader (C8.pack "Content-Disposition") part of
- Nothing
- -> abortPurely BadRequest []
- (Just "There is a part without Content-Disposition in the multipart/form-data.")
- Just dispoStr
- -> case parse contDispoP (L8.fromChunks [dispoStr]) of
- (# Success dispo, _ #)
- -> dispo
- (# _, _ #)
- -> abortPurely BadRequest []
- (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
-
-
-contDispoP :: Parser ContDispo
-contDispoP = do dispoType <- token
- params <- allowEOF $ many paramP
+partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
+{-# INLINEABLE partToFormPair #-}
+partToFormPair pt
+ | dType (ptContDispo pt) ≡ "form-data"
+ = do name ← partName pt
+ let fname = partFileName pt
+ let fd = FormData {
+ fdFileName = fname
+ , fdContent = ptBody pt
+ }
+ return $ Just (name, fd)
+ | otherwise
+ = return Nothing
+
+partName ∷ Monad m ⇒ Part → m Text
+{-# INLINEABLE partName #-}
+partName (Part {..})
+ = case M.lookup "name" $ dParams ptContDispo of
+ Just name
+ → return name
+ Nothing
+ → fail ("form-data without name: " ⧺
+ A.toString (printContDispo ptContDispo))
+
+partFileName ∷ Part → Maybe Text
+{-# INLINEABLE partFileName #-}
+partFileName (Part {..})
+ = M.lookup "filename" $ dParams ptContDispo
+
+getContDispo ∷ Monad m ⇒ Headers → m ContDispo
+{-# INLINEABLE getContDispo #-}
+getContDispo hdr
+ = case getHeader "Content-Disposition" hdr of
+ Nothing
+ → fail ("There is a part without Content-Disposition in the multipart/form-data.")
+ Just str
+ → let p = do d ← contDispoP
+ endOfInput
+ return d
+ bs = A.toByteString str
+ in
+ case parseOnly p bs of
+ Right d → return d
+ Left err → fail (concat [ "Unparsable Content-Disposition: "
+ , BS.unpack bs
+ , ": "
+ , err
+ ])
+
+contDispoP ∷ Parser ContDispo
+contDispoP = do dispoType ← A.toCIAscii <$> token
+ params ← paramsP
return $ ContDispo dispoType params
- where
- paramP :: Parser (String, String)
- paramP = do _ <- many lws
- _ <- char ';'
- _ <- many lws
- name <- token
- _ <- char '='
- value <- token <|> quotedStr
- return (name, value)
+++ /dev/null
-{-# LANGUAGE
- BangPatterns
- , ScopedTypeVariables
- , UnboxedTuples
- , UnicodeSyntax
- #-}
--- |Yet another parser combinator. This is mostly a subset of
--- "Text.ParserCombinators.Parsec" but there are some differences:
---
--- * This parser works on 'Data.ByteString.Base.LazyByteString'
--- instead of 'Prelude.String'.
---
--- * Backtracking is the only possible behavior so there is no \"try\"
--- action.
---
--- * On success, the remaining string is returned as well as the
--- parser result.
---
--- * You can choose whether to treat reaching EOF (trying to eat one
--- more letter at the end of string) a fatal error or to treat it a
--- normal failure. If a fatal error occurs, the entire parsing
--- process immediately fails without trying any backtracks. The
--- default behavior is to treat EOF fatal.
---
--- In general, you don't have to use this module directly.
-module Network.HTTP.Lucu.Parser
- ( Parser
- , ParserResult(..)
-
- , failP
-
- , parse
- , parseStr
-
- , anyChar
- , eof
- , allowEOF
- , satisfy
- , char
- , string
- , (<|>)
- , choice
- , oneOf
- , digit
- , hexDigit
- , notFollowedBy
- , many
- , manyChar
- , many1
- , count
- , option
- , sepBy
- , sepBy1
-
- , sp
- , ht
- , crlf
- )
- where
-
-import Control.Monad.State.Strict hiding (state)
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
-import qualified Data.Foldable as Fold
-import Data.Int
-import qualified Data.Sequence as Seq
-import Data.Sequence (Seq, (|>))
-
--- |@'Parser' a@ is obviously a parser which parses and returns @a@.
-newtype Parser a = Parser {
- runParser :: State ParserState (ParserResult a)
- }
-
-
-data ParserState
- = PST {
- pstInput :: Lazy.ByteString
- , pstIsEOFFatal :: !Bool
- }
- deriving (Eq, Show)
-
-
-data ParserResult a = Success !a
- | IllegalInput -- 受理出來ない入力があった
- | ReachedEOF -- 限界を越えて讀まうとした
- deriving (Eq, Show)
-
-
--- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
-instance Monad Parser where
- p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存
- result <- runParser p
- case result of
- Success a -> runParser (f a)
- IllegalInput -> do put saved -- 状態を復歸
- return IllegalInput
- ReachedEOF -> do put saved -- 状態を復歸
- return ReachedEOF
- return !x = Parser $! return $! Success x
- fail _ = Parser $! return $! IllegalInput
-
-instance Functor Parser where
- fmap f p = p >>= return . f
-
--- |@'failP'@ is just a synonym for @'Prelude.fail'
--- 'Prelude.undefined'@.
-failP :: Parser a
-failP = fail undefined
-
--- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
--- remaining #)@.
-parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #)
-parse !p input -- input は lazy である必要有り。
- = let (!result, state') = runState (runParser p) (PST input True)
- in
- (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
-
--- |@'parseStr' p str@ packs @str@ and parses it.
-parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #)
-parseStr !p input -- input は lazy である必要有り。
- = parse p (B.pack input)
-
-
-anyChar :: Parser Char
-anyChar = Parser $!
- do state@(PST input _) <- get
- if B.null input then
- return ReachedEOF
- else
- do put $! state { pstInput = B.tail input }
- return (Success $! B.head input)
-
-
-eof :: Parser ()
-eof = Parser $!
- do PST input _ <- get
- if B.null input then
- return $! Success ()
- else
- return IllegalInput
-
--- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure.
-allowEOF :: Parser a -> Parser a
-allowEOF !f
- = Parser $! do saved@(PST _ isEOFFatal) <- get
- put $! saved { pstIsEOFFatal = False }
-
- result <- runParser f
-
- state <- get
- put $! state { pstIsEOFFatal = isEOFFatal }
-
- return result
-
-
-satisfy :: (Char -> Bool) -> Parser Char
-satisfy !f
- = do c <- anyChar
- if f c then
- return c
- else
- failP
-
-
-char :: Char -> Parser Char
-char !c = satisfy (== c)
-
-
-string :: String -> Parser String
-string !str
- = let bs = B.pack str
- len = B.length bs
- in
- Parser $!
- do st <- get
- let (bs', rest) = B.splitAt len $ pstInput st
- st' = st { pstInput = rest }
- if B.length bs' < len then
- return ReachedEOF
- else
- if bs == bs' then
- do put st'
- return $ Success str
- else
- return IllegalInput
-
-
-infixr 0 <|>
-
--- |This is the backtracking alternation. There is no non-backtracking
--- equivalent.
-(<|>) :: Parser a -> Parser a -> Parser a
-(!f) <|> (!g)
- = Parser $! do saved <- get -- 状態を保存
- result <- runParser f
- case result of
- Success a -> return $! Success a
- IllegalInput -> do put saved -- 状態を復歸
- runParser g
- ReachedEOF -> if pstIsEOFFatal saved then
- do put saved
- return ReachedEOF
- else
- do put saved
- runParser g
-
-
-choice :: [Parser a] -> Parser a
-choice = foldl (<|>) failP
-
-
-oneOf :: [Char] -> Parser Char
-oneOf = foldl (<|>) failP . map char
-
-
-notFollowedBy :: Parser a -> Parser ()
-notFollowedBy !p
- = Parser $! do saved <- get -- 状態を保存
- result <- runParser p
- case result of
- Success _ -> do put saved -- 状態を復歸
- return IllegalInput
- IllegalInput -> do put saved -- 状態を復歸
- return $! Success ()
- ReachedEOF -> do put saved -- 状態を復歸
- return $! Success ()
-
-
-digit :: Parser Char
-digit = do c <- anyChar
- if c >= '0' && c <= '9' then
- return c
- else
- failP
-
-
-hexDigit :: Parser Char
-hexDigit = do c <- anyChar
- if (c >= '0' && c <= '9') ||
- (c >= 'a' && c <= 'f') ||
- (c >= 'A' && c <= 'F') then
- return c
- else
- failP
-
-
-many :: forall a. Parser a -> Parser [a]
-many !p = Parser $!
- do state <- get
- let (# result, state' #) = many' state Seq.empty
- put state'
- return result
- where
- many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #)
- many' !st !soFar
- = case runState (runParser p) st of
- (Success a, st') -> many' st' (soFar |> a)
- (IllegalInput, _) -> (# Success (Fold.toList soFar), st #)
- (ReachedEOF , _) -> if pstIsEOFFatal st then
- (# ReachedEOF, st #)
- else
- (# Success (Fold.toList soFar), st #)
-
-manyChar :: Parser Char -> Parser Lazy.ByteString
-manyChar !p = Parser $!
- do state <- get
- case scan' state 0 of
- Success len
- -> do let (bs, rest) = B.splitAt len (pstInput state)
- state' = state { pstInput = rest }
- put state'
- return $ Success bs
- ReachedEOF
- -> if pstIsEOFFatal state then
- return ReachedEOF
- else
- error "internal error"
- _ -> error "internal error"
- where
- scan' :: ParserState -> Int64 -> ParserResult Int64
- scan' !st !soFar
- = case runState (runParser p) st of
- (Success _ , st') -> scan' st' (soFar + 1)
- (IllegalInput, _ ) -> Success soFar
- (ReachedEOF , _ ) -> if pstIsEOFFatal st then
- ReachedEOF
- else
- Success soFar
-
-
-many1 :: Parser a -> Parser [a]
-many1 !p = do x <- p
- xs <- many p
- return (x:xs)
-
-
-count :: Int -> Parser a -> Parser [a]
-count !n !p = Parser $! count' n p Seq.empty
-
--- This implementation is rather ugly but we need to make it
--- tail-recursive to avoid stack overflow.
-count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a])
-count' 0 _ !soFar = return $! Success $! Fold.toList soFar
-count' !n !p !soFar = do saved <- get
- result <- runParser p
- case result of
- Success a -> count' (n-1) p (soFar |> a)
- IllegalInput -> do put saved
- return IllegalInput
- ReachedEOF -> do put saved
- return ReachedEOF
-
-
--- def may be a _|_
-option :: a -> Parser a -> Parser a
-option def !p = p <|> return def
-
-
-sepBy :: Parser a -> Parser sep -> Parser [a]
-sepBy !p !sep = sepBy1 p sep <|> return []
-
-
-sepBy1 :: Parser a -> Parser sep -> Parser [a]
-sepBy1 !p !sep
- = do x <- p
- xs <- many $! sep >> p
- return (x:xs)
-
-
-sp :: Parser Char
-sp = char ' '
-
-
-ht :: Parser Char
-ht = char '\t'
-
-
-crlf :: Parser String
-crlf = string "\x0d\x0a"
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
+ , ScopedTypeVariables
, UnicodeSyntax
#-}
-- |This is an auxiliary parser utilities for parsing things related
-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.Parser.Http
( isCtl
+ , isText
, isSeparator
, isChar
, isToken
+ , isSPHT
+
, listOf
- , token
+
+ , crlf
+ , sp
, lws
- , text
- , separator
+
+ , token
+ , separators
, quotedStr
, qvalue
+
+ , atMost
+ , manyCharsTill
)
where
+import Control.Applicative
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P hiding (scan)
+import qualified Data.Attoparsec.FastSet as FS
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LS
+import qualified Data.ByteString.Lazy.Internal as LS
+import Data.Foldable
+import Data.Monoid
+import Data.Monoid.Unicode
+import qualified Data.Sequence as S
+import Data.Sequence.Unicode hiding ((∅))
+import Prelude.Unicode
-import Network.HTTP.Lucu.Parser
-
--- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
-isCtl :: Char -> Bool
+-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
+isCtl ∷ Char → Bool
+{-# INLINE isCtl #-}
isCtl c
- | c < '\x1f' = True
- | c >= '\x7f' = True
- | otherwise = False
+ | c ≤ '\x1f' = True
+ | c > '\x7f' = True
+ | otherwise = False
+
+-- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@
+isText ∷ Char → Bool
+{-# INLINE isText #-}
+isText = (¬) ∘ isCtl
-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
-- separators.
-isSeparator :: Char -> Bool
-isSeparator '(' = True
-isSeparator ')' = True
-isSeparator '<' = True
-isSeparator '>' = True
-isSeparator '@' = True
-isSeparator ',' = True
-isSeparator ';' = True
-isSeparator ':' = True
-isSeparator '\\' = True
-isSeparator '"' = True
-isSeparator '/' = True
-isSeparator '[' = True
-isSeparator ']' = True
-isSeparator '?' = True
-isSeparator '=' = True
-isSeparator '{' = True
-isSeparator '}' = True
-isSeparator ' ' = True
-isSeparator '\t' = True
-isSeparator _ = False
+isSeparator ∷ Char → Bool
+{-# INLINE isSeparator #-}
+isSeparator = flip FS.memberChar set
+ where
+ {-# NOINLINE set #-}
+ set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
-- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
-isChar :: Char -> Bool
-isChar c
- | c <= '\x7f' = True
- | otherwise = False
+isChar ∷ Char → Bool
+{-# INLINE isChar #-}
+isChar = (≤ '\x7F')
-- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
-- c)@
-isToken :: Char -> Bool
-isToken c = c `seq`
- not (isCtl c || isSeparator c)
-
--- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
--- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
--- occurrences of LWS before and after each tokens.
-listOf :: Parser a -> Parser [a]
-listOf !p = do _ <- many lws
- sepBy p $! do _ <- many lws
- _ <- char ','
- many lws
-
--- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
--- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
-token :: Parser String
-token = many1 $! satisfy isToken
-
--- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
--- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
-lws :: Parser String
-lws = do s <- option "" crlf
- xs <- many1 (sp <|> ht)
- return (s ++ xs)
-
--- |'text' accepts one character which doesn't satisfy 'isCtl'.
-text :: Parser Char
-text = satisfy (not . isCtl)
-
--- |'separator' accepts one character which satisfies 'isSeparator'.
-separator :: Parser Char
-separator = satisfy isSeparator
+isToken ∷ Char → Bool
+{-# INLINE isToken #-}
+isToken !c
+ = (¬) (isCtl c ∨ isSeparator c)
+
+-- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
+-- allows any occurrences of 'lws' before and after each tokens.
+listOf ∷ Parser a → Parser [a]
+{-# INLINEABLE listOf #-}
+listOf p
+ = do skipMany lws
+ sepBy p $ do skipMany lws
+ _ <- char ','
+ skipMany lws
+
+-- |'token' is similar to @'takeWhile1' 'isToken'@
+token ∷ Parser Ascii
+{-# INLINE token #-}
+token = A.unsafeFromByteString <$> takeWhile1 isToken
+
+-- |The CRLF: 0x0D 0x0A.
+crlf ∷ Parser ()
+{-# INLINE crlf #-}
+crlf = string "\x0D\x0A" ≫ return ()
+
+-- |The SP: 0x20.
+sp ∷ Parser ()
+{-# INLINE sp #-}
+sp = char '\x20' ≫ return ()
+
+-- |HTTP LWS: crlf? (sp | ht)+
+lws ∷ Parser ()
+{-# INLINEABLE lws #-}
+lws = do option () crlf
+ _ ← takeWhile1 isSPHT
+ return ()
+
+-- |Returns 'True' for SP and HT.
+isSPHT ∷ Char → Bool
+{-# INLINE isSPHT #-}
+isSPHT '\x20' = True
+isSPHT '\x09' = True
+isSPHT _ = False
+
+-- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
+separators ∷ Parser Ascii
+{-# INLINE separators #-}
+separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
-- |'quotedStr' accepts a string surrounded by double quotation
-- marks. Quotes can be escaped by backslashes.
-quotedStr :: Parser String
-quotedStr = do _ <- char '"'
- xs <- many (qdtext <|> quotedPair)
- _ <- char '"'
- return $ foldr (++) "" xs
+quotedStr ∷ Parser Ascii
+{-# INLINEABLE quotedStr #-}
+quotedStr = try $
+ do _ ← char '"'
+ xs ← P.many (qdtext <|> quotedPair)
+ _ ← char '"'
+ return $ A.unsafeFromByteString $ BS.pack xs
where
- qdtext = do c <- satisfy (/= '"')
- return [c]
+ qdtext ∷ Parser Char
+ {-# INLINE qdtext #-}
+ qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
- quotedPair = do _ <- char '\\'
- c <- satisfy isChar
- return [c]
+ quotedPair ∷ Parser Char
+ {-# INLINE quotedPair #-}
+ quotedPair = char '\\' ≫ satisfy isChar
-- |'qvalue' accepts a so-called qvalue.
-qvalue :: Parser Double
-qvalue = do x <- char '0'
- xs <- option ""
- $ do y <- char '.'
- ys <- many digit -- 本當は三文字までに制限
- return (y:ys)
+qvalue ∷ Parser Double
+{-# INLINEABLE qvalue #-}
+qvalue = do x ← char '0'
+ xs ← option "" $
+ do y ← char '.'
+ ys ← atMost 3 digit
+ return (y:ys)
return $ read (x:xs)
<|>
- do x <- char '1'
- xs <- option ""
- $ do y <- char '.'
- ys <- many (char '0') -- 本當は三文字までに制限
- return (y:ys)
+ do x ← char '1'
+ xs ← option "" $
+ do y ← char '.'
+ ys ← atMost 3 (char '0')
+ return (y:ys)
return $ read (x:xs)
+
+-- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
+-- at most @n@ times.
+atMost ∷ Alternative f ⇒ Int → f a → f [a]
+{-# INLINE atMost #-}
+atMost 0 _ = pure []
+atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
+ <|>
+ pure []
+
+
+data CharAccumState
+ = CharAccumState {
+ casChunks ∷ !(S.Seq BS.ByteString)
+ , casLastChunk ∷ !(S.Seq Char)
+ }
+
+instance Monoid CharAccumState where
+ mempty
+ = CharAccumState {
+ casChunks = (∅)
+ , casLastChunk = (∅)
+ }
+ mappend a b
+ = b {
+ casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
+ }
+
+lastChunk ∷ CharAccumState → BS.ByteString
+{-# INLINE lastChunk #-}
+lastChunk = BS.pack ∘ toList ∘ casLastChunk
+
+snoc ∷ CharAccumState → Char → CharAccumState
+{-# INLINEABLE snoc #-}
+snoc cas c
+ | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
+ = cas {
+ casChunks = casChunks cas ⊳ lastChunk cas
+ , casLastChunk = S.singleton c
+ }
+ | otherwise
+ = cas {
+ casLastChunk = casLastChunk cas ⊳ c
+ }
+
+finish ∷ CharAccumState → LS.ByteString
+{-# INLINEABLE finish #-}
+finish cas
+ = let chunks = toList $ casChunks cas ⊳ lastChunk cas
+ str = LS.fromChunks chunks
+ in
+ str
+
+manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
+ ⇒ m Char
+ → m b
+ → m LS.ByteString
+{-# INLINEABLE manyCharsTill #-}
+manyCharsTill p end = scan (∅)
+ where
+ scan ∷ CharAccumState → m LS.ByteString
+ {-# INLINE scan #-}
+ scan s
+ = (end *> pure (finish s))
+ <|>
+ (scan =≪ (snoc s <$> p))
{-# LANGUAGE
BangPatterns
+ , DoAndIfThenElse
+ , OverloadedStrings
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Postprocess
, completeUnconditionalHeaders
)
where
-
-import Control.Concurrent.STM
-import Control.Monad
+import Control.Applicative
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Data.IORef
-import Data.Maybe
-import Data.Time
+import Data.IORef
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Time
import qualified Data.Time.HTTP as HTTP
-import GHC.Conc (unsafeIOToSTM)
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-import System.IO.Unsafe
+import GHC.Conc (unsafeIOToSTM)
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import System.IO.Unsafe
{-
-}
-postprocess :: Interaction -> STM ()
+postprocess ∷ Interaction → STM ()
postprocess !itr
- = do reqM <- readItr itr itrRequest id
- res <- readItr itr itrResponse id
+ = do reqM ← readItr itr itrRequest id
+ res ← readItr itr itrResponse id
let sc = resStatus res
- unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError])
- $ abortSTM InternalServerError []
- $ Just ("The status code is not good for a final status: "
- ++ show sc)
-
- when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing)
- $ abortSTM InternalServerError []
- $ Just ("The status was " ++ show sc ++ " but no Allow header.")
-
- when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing)
- $ abortSTM InternalServerError []
- $ Just ("The status code was " ++ show sc ++ " but no Location header.")
+ unless (any (\ p → p sc) [isSuccessful, isRedirection, isError])
+ $ abortSTM InternalServerError []
+ $ Just
+ $ A.toText ( "The status code is not good for a final status of a response: "
+ ⊕ printStatusCode sc )
+
+ when (sc ≡ MethodNotAllowed ∧ getHeader "Allow" res ≡ Nothing)
+ $ abortSTM InternalServerError []
+ $ Just
+ $ A.toText ( "The status was "
+ ⊕ printStatusCode sc
+ ⊕ " but no Allow header." )
+
+ when (sc /= NotModified ∧ isRedirection sc ∧ getHeader "Location" res ≡ Nothing)
+ $ abortSTM InternalServerError []
+ $ Just
+ $ A.toText ( "The status code was "
+ ⊕ printStatusCode sc
+ ⊕ " but no Location header." )
when (reqM /= Nothing) relyOnRequest
-- itrResponse の内容は relyOnRequest によって變へられてゐる可
-- 能性が高い。
- do oldRes <- readItr itr itrResponse id
- newRes <- unsafeIOToSTM
- $ completeUnconditionalHeaders (itrConfig itr) oldRes
+ do oldRes ← readItr itr itrResponse id
+ newRes ← unsafeIOToSTM
+ $ completeUnconditionalHeaders (itrConfig itr) oldRes
writeItr itr itrResponse newRes
where
- relyOnRequest :: STM ()
+ relyOnRequest ∷ STM ()
relyOnRequest
- = do status <- readItr itr itrResponse resStatus
- req <- readItr itr itrRequest fromJust
+ = do status ← readItr itr itrResponse resStatus
+ req ← readItr itr itrRequest fromJust
let reqVer = reqVersion req
- canHaveBody = if reqMethod req == HEAD then
+ canHaveBody = if reqMethod req ≡ HEAD then
False
else
- not (isInformational status ||
- status == NoContent ||
- status == ResetContent ||
- status == NotModified )
+ not (isInformational status ∨
+ status ≡ NoContent ∨
+ status ≡ ResetContent ∨
+ status ≡ NotModified )
- updateRes $! deleteHeader (C8.pack "Content-Length")
- updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
+ updateRes $ deleteHeader "Content-Length"
+ updateRes $ deleteHeader "Transfer-Encoding"
- cType <- readHeader (C8.pack "Content-Type")
- when (cType == Nothing)
- $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
+ cType ← readHeader "Content-Type"
+ when (cType ≡ Nothing)
+ $ updateRes $ setHeader "Content-Type" defaultPageContentType
if canHaveBody then
- when (reqVer == HttpVersion 1 1)
- $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
- writeItr itr itrWillChunkBody True
- else
+ when (reqVer ≡ HttpVersion 1 1)
+ $ do updateRes $ setHeader "Transfer-Encoding" "chunked"
+ writeItr itr itrWillChunkBody True
+ else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
when (reqMethod req /= HEAD)
- $ do updateRes $! deleteHeader (C8.pack "Content-Type")
- updateRes $! deleteHeader (C8.pack "Etag")
- updateRes $! deleteHeader (C8.pack "Last-Modified")
+ $ do updateRes $ deleteHeader "Content-Type"
+ updateRes $ deleteHeader "Etag"
+ updateRes $ deleteHeader "Last-Modified"
- conn <- readHeader (C8.pack "Connection")
+ conn ← readHeader "Connection"
case conn of
- Nothing -> return ()
- Just value -> when (value `noCaseEq` C8.pack "close")
- $ writeItr itr itrWillClose True
+ Nothing → return ()
+ Just value → when (A.toCIAscii value ≡ "close")
+ $ writeItr itr itrWillClose True
- willClose <- readItr itr itrWillClose id
+ willClose ← readItr itr itrWillClose id
when willClose
- $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
+ $ updateRes $ setHeader "Connection" "close"
- when (reqMethod req == HEAD || not canHaveBody)
- $ writeTVar (itrWillDiscardBody itr) True
+ when (reqMethod req ≡ HEAD ∨ not canHaveBody)
+ $ writeTVar (itrWillDiscardBody itr) True
- readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
- readHeader !name
- = readItr itr itrResponse $ getHeader name
+ readHeader ∷ CIAscii → STM (Maybe Ascii)
+ {-# INLINE readHeader #-}
+ readHeader = readItr itr itrResponse ∘ getHeader
- updateRes :: (Response -> Response) -> STM ()
- updateRes !updator
- = updateItr itr itrResponse updator
+ updateRes ∷ (Response → Response) → STM ()
+ {-# INLINE updateRes #-}
+ updateRes = updateItr itr itrResponse
-
-completeUnconditionalHeaders :: Config -> Response -> IO Response
-completeUnconditionalHeaders !conf !res
- = compServer res >>= compDate
+completeUnconditionalHeaders ∷ Config → Response → IO Response
+completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
where
compServer res'
- = case getHeader (C8.pack "Server") res' of
- Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
- Just _ -> return res'
+ = case getHeader "Server" res' of
+ Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
+ Just _ → return res'
compDate res'
- = case getHeader (C8.pack "Date") res' of
- Nothing -> do date <- getCurrentDate
- return $ setHeader (C8.pack "Date") date res'
- Just _ -> return res'
-
-
-cache :: IORef (UTCTime, Strict.ByteString)
-cache = unsafePerformIO $
- newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
-{-# NOINLINE cache #-}
-
-getCurrentDate :: IO Strict.ByteString
-getCurrentDate = do now <- getCurrentTime
- (cachedTime, cachedStr) <- readIORef cache
-
- if now `mostlyEq` cachedTime then
- return cachedStr
- else
- do let dateStr = C8.pack $ HTTP.format now
- writeIORef cache (now, dateStr)
- return dateStr
- where
- mostlyEq :: UTCTime -> UTCTime -> Bool
- mostlyEq a b
- = (utctDay a == utctDay b)
- &&
- (fromEnum (utctDayTime a) == fromEnum (utctDayTime b))
+ = case getHeader "Date" res' of
+ Nothing → do date ← getCurrentDate
+ return $ setHeader "Date" date res'
+ Just _ → return res'
+
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.format <$> getCurrentTime
--- /dev/null
+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
+-- |Provide facilities to encode/decode MIME parameter values in
+-- character sets other than US-ASCII. See:
+-- http://www.faqs.org/rfcs/rfc2231.html
+module Network.HTTP.Lucu.RFC2231
+ ( printParams
+ , paramsP
+ )
+ where
+import Control.Applicative
+import qualified Control.Exception as E
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8 as P
+import Data.Bits
+import qualified Data.ByteString.Char8 as BS
+import Data.Char
+import Data.Foldable
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Monoid.Unicode
+import Data.Sequence (Seq, ViewL(..))
+import qualified Data.Sequence as S
+import Data.Sequence.Unicode hiding ((∅))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.ICU.Convert as TC
+import Data.Text.ICU.Error
+import Data.Text.Encoding
+import Data.Traversable
+import Data.Word
+import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (concat, mapM, takeWhile)
+import Prelude.Unicode
+import System.IO.Unsafe
+
+printParams ∷ Map CIAscii Text → AsciiBuilder
+printParams params
+ | M.null params = (∅)
+ | otherwise = A.toAsciiBuilder "; " ⊕
+ joinWith "; " (map printPair $ M.toList params)
+
+printPair ∷ (CIAscii, Text) → AsciiBuilder
+printPair (name, value)
+ | T.any (> '\xFF') value
+ = printPairInUTF8 name value
+ | otherwise
+ = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value)
+
+printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder
+printPairInUTF8 name value
+ = A.toAsciiBuilder (A.fromCIAscii name) ⊕
+ A.toAsciiBuilder "*=utf-8''" ⊕
+ escapeUnsafeChars (encodeUtf8 value) (∅)
+
+printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder
+printPairInAscii name value
+ = A.toAsciiBuilder (A.fromCIAscii name) ⊕
+ A.toAsciiBuilder "=" ⊕
+ if BS.any ((¬) ∘ isToken) (A.toByteString value) then
+ quoteStr value
+ else
+ A.toAsciiBuilder value
+
+escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
+escapeUnsafeChars bs b
+ = case BS.uncons bs of
+ Nothing → b
+ Just (c, bs')
+ | isToken c → escapeUnsafeChars bs' $
+ b ⊕ A.toAsciiBuilder (A.unsafeFromString [c])
+ | otherwise → escapeUnsafeChars bs' $
+ b ⊕ toHex (fromIntegral $ fromEnum c)
+
+toHex ∷ Word8 → AsciiBuilder
+toHex o = A.toAsciiBuilder "%" ⊕
+ A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8)
+ , toHex' (o .&. 0x0F) ])
+
+toHex' ∷ Word8 → Char
+toHex' o
+ | o ≤ 0x09 = toEnum $ fromIntegral $ fromEnum '0' + fromIntegral o
+ | otherwise = toEnum $ fromIntegral $ fromEnum 'A' + fromIntegral (o - 0x0A)
+
+
+data ExtendedParam
+ = InitialEncodedParam {
+ epName ∷ !CIAscii
+ , epCharset ∷ !CIAscii
+ , epPayload ∷ !BS.ByteString
+ }
+ | ContinuedEncodedParam {
+ epName ∷ !CIAscii
+ , epSection ∷ !Integer
+ , epPayload ∷ !BS.ByteString
+ }
+ | AsciiParam {
+ epName ∷ !CIAscii
+ , epSection ∷ !Integer
+ , apPayload ∷ !Ascii
+ }
+
+section ∷ ExtendedParam → Integer
+section (InitialEncodedParam {..}) = 0
+section ep = epSection ep
+
+paramsP ∷ Parser (Map CIAscii Text)
+paramsP = decodeParams =≪ P.many (try paramP)
+
+paramP ∷ Parser ExtendedParam
+paramP = do skipMany lws
+ _ ← char ';'
+ skipMany lws
+ epm ← nameP
+ _ ← char '='
+ case epm of
+ (name, 0, True)
+ → do (charset, payload) ← initialEncodedValue
+ return $ InitialEncodedParam name charset payload
+ (name, sect, True)
+ → do payload ← encodedPayload
+ return $ ContinuedEncodedParam name sect payload
+ (name, sect, False)
+ → do payload ← token <|> quotedStr
+ return $ AsciiParam name sect payload
+
+nameP ∷ Parser (CIAscii, Integer, Bool)
+nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+ takeWhile1 (\c → isToken c ∧ c ≢ '*')
+ sect ← option 0 $
+ try $
+ do _ ← char '*'
+ n ← decimal
+ return n
+ isEncoded ← option False $
+ do _ ← char '*'
+ return True
+ return (name, sect, isEncoded)
+
+initialEncodedValue ∷ Parser (CIAscii, BS.ByteString)
+initialEncodedValue
+ = do charset ← metadata
+ _ ← char '\''
+ _ ← metadata -- Ignore the language tag
+ _ ← char '\''
+ payload ← encodedPayload
+ if charset ≡ "" then
+ -- NOTE: I'm not sure this is the right thing, but RFC
+ -- 2231 doesn't tell us what we should do when the
+ -- charset is omitted.
+ return ("US-ASCII", payload)
+ else
+ return (charset, payload)
+ where
+ metadata ∷ Parser CIAscii
+ metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$>
+ takeWhile (\c → isToken c ∧ c ≢ '\'')
+
+encodedPayload ∷ Parser BS.ByteString
+encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars)
+
+hexChar ∷ Parser BS.ByteString
+hexChar = do _ ← char '%'
+ h ← satisfy isHexChar
+ l ← satisfy isHexChar
+ return $ BS.singleton $ hexToChar h l
+
+isHexChar ∷ Char → Bool
+isHexChar = inClass "0-9a-fA-F"
+
+hexToChar ∷ Char → Char → Char
+hexToChar h l
+ = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l
+
+hexToInt ∷ Char → Int
+hexToInt c
+ | c ≤ '9' = ord c - ord '0'
+ | c ≤ 'F' = ord c - ord 'A' + 10
+ | otherwise = ord c - ord 'a' + 10
+
+rawChars ∷ Parser BS.ByteString
+rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
+
+decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
+decodeParams = (mapM decodeSections =≪) ∘ sortBySection
+
+sortBySection ∷ ∀m. Monad m
+ ⇒ [ExtendedParam]
+ → m (Map CIAscii (Map Integer ExtendedParam))
+sortBySection = flip go (∅)
+ where
+ go ∷ [ExtendedParam]
+ → Map CIAscii (Map Integer ExtendedParam)
+ → m (Map CIAscii (Map Integer ExtendedParam))
+ go [] m = return m
+ go (x:xs) m
+ = case M.lookup (epName x) m of
+ Nothing
+ → let s = M.singleton (section x) x
+ m' = M.insert (epName x) s m
+ in
+ go xs m'
+ Just s
+ → case M.insertLookupWithKey (\_ s' _ → s') (section x) x s of
+ (Nothing, s')
+ → let m' = M.insert (epName x) s' m
+ in
+ go xs m'
+ (Just _, _)
+ → fail (concat [ "Duplicate section "
+ , show $ section x
+ , " for parameter '"
+ , A.toString $ A.fromCIAscii $ epName x
+ , "'"
+ ])
+
+decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
+ where
+ toSeq ∷ Map Integer ExtendedParam
+ → Integer
+ → Seq ExtendedParam
+ → m (Seq ExtendedParam)
+ toSeq m expectedSect sects
+ = case M.minViewWithKey m of
+ Nothing
+ → return sects
+ Just ((sect, p), m')
+ | sect ≡ expectedSect
+ → toSeq m' (expectedSect + 1) (sects ⊳ p)
+ | otherwise
+ → fail (concat [ "Missing section "
+ , show $ section p
+ , " for parameter '"
+ , A.toString $ A.fromCIAscii $ epName p
+ , "'"
+ ])
+
+ decodeSeq ∷ Seq ExtendedParam → m Text
+ decodeSeq sects
+ = case S.viewl sects of
+ EmptyL
+ → fail "decodeSeq: internal error: empty seq"
+ InitialEncodedParam {..} :< xs
+ → do conv ← openConv epCharset
+ let t = TC.toUnicode conv epPayload
+ decodeSeq' (Just conv) xs $ S.singleton t
+ ContinuedEncodedParam {..} :< _
+ → fail "decodeSeq: internal error: CEP at section 0"
+ AsciiParam {..} :< xs
+ → let t = A.toText apPayload
+ in
+ decodeSeq' Nothing xs $ S.singleton t
+
+ decodeSeq' ∷ Maybe (TC.Converter)
+ → Seq ExtendedParam
+ → Seq Text
+ → m Text
+ decodeSeq' convM sects chunks
+ = case S.viewl sects of
+ EmptyL
+ → return $ T.concat $ toList chunks
+ InitialEncodedParam {..} :< _
+ → fail "decodeSeq': internal error: IEP at section > 0"
+ ContinuedEncodedParam {..} :< xs
+ → case convM of
+ Just conv
+ → let t = TC.toUnicode conv epPayload
+ in
+ decodeSeq' convM xs $ chunks ⊳ t
+ Nothing
+ → fail (concat [ "Section "
+ , show epSection
+ , " for parameter '"
+ , A.toString $ A.fromCIAscii epName
+ , "' is encoded but its first section is not"
+ ])
+ AsciiParam {..} :< xs
+ → let t = A.toText apPayload
+ in
+ decodeSeq' convM xs $ chunks ⊳ t
+
+ openConv ∷ CIAscii → m TC.Converter
+ openConv charset
+ = let cs = A.toString $ A.fromCIAscii charset
+ open' = TC.open cs (Just True)
+ in
+ case unsafePerformIO $ E.try open' of
+ Right conv → return conv
+ Left err → fail $ show (err ∷ ICUError)
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
{-# OPTIONS_HADDOCK prune #-}
-- |Definition of things related on HTTP request.
, requestP
)
where
-
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.URI
+import Control.Applicative
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Char8 as C8
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Parser.Http
+import Network.URI
+import Prelude.Unicode
-- |This is the definition of HTTP request methods, which shouldn't
-- require any description.
| DELETE
| TRACE
| CONNECT
- | ExtensionMethod !String
+ | ExtensionMethod !Ascii
deriving (Eq, Show)
-- |This is the definition of HTTP reqest.
data Request
= Request {
- reqMethod :: !Method
- , reqURI :: !URI
- , reqVersion :: !HttpVersion
- , reqHeaders :: !Headers
+ reqMethod ∷ !Method
+ , reqURI ∷ !URI
+ , reqVersion ∷ !HttpVersion
+ , reqHeaders ∷ !Headers
}
- deriving (Show, Eq)
+ deriving (Eq, Show)
instance HasHeaders Request where
getHeaders = reqHeaders
setHeaders req hdr = req { reqHeaders = hdr }
-
-requestP :: Parser Request
-requestP = do _ <- many crlf
- (method, uri, version) <- requestLineP
- headers <- headersP
+requestP ∷ Parser Request
+requestP = do skipMany crlf
+ (method, uri, version) ← requestLineP
+ headers ← headersP
return Request {
reqMethod = method
, reqURI = uri
, reqHeaders = headers
}
-
-requestLineP :: Parser (Method, URI, HttpVersion)
-requestLineP = do method <- methodP
- _ <- sp
- uri <- uriP
- _ <- sp
- ver <- httpVersionP
- _ <- crlf
+requestLineP ∷ Parser (Method, URI, HttpVersion)
+requestLineP = do method ← methodP
+ sp
+ uri ← uriP
+ sp
+ ver ← httpVersionP
+ crlf
return (method, uri, ver)
+methodP ∷ Parser Method
+methodP = choice
+ [ string "OPTIONS" ≫ return OPTIONS
+ , string "GET" ≫ return GET
+ , string "HEAD" ≫ return HEAD
+ , string "POST" ≫ return POST
+ , string "PUT" ≫ return PUT
+ , string "DELETE" ≫ return DELETE
+ , string "TRACE" ≫ return TRACE
+ , string "CONNECT" ≫ return CONNECT
+ , ExtensionMethod <$> token
+ ]
-methodP :: Parser Method
-methodP = ( let methods = [ ("OPTIONS", OPTIONS)
- , ("GET" , GET )
- , ("HEAD" , HEAD )
- , ("POST" , POST )
- , ("PUT" , PUT )
- , ("DELETE" , DELETE )
- , ("TRACE" , TRACE )
- , ("CONNECT", CONNECT)
- ]
- in choice $ map (\ (str, mth)
- -> string str >> return mth) methods )
- <|>
- fmap ExtensionMethod token
-
-
-uriP :: Parser URI
-uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))
+uriP ∷ Parser URI
+uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
+ let str = C8.unpack bs
case parseURIReference str of
- Nothing -> failP
- Just uri -> return uri
\ No newline at end of file
+ Nothing -> fail ("Unparsable URI: " ⧺ str)
+ Just uri -> return uri
( requestReader
)
where
-
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
, driftTo
)
where
-
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.ByteString as Strict (ByteString)
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.MultipartForm
-import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
{-# LANGUAGE
DeriveDataTypeable
+ , OverloadedStrings
+ , RecordWildCards
, UnboxedTuples
, UnicodeSyntax
+ , ViewPatterns
#-}
{-# OPTIONS_HADDOCK prune #-}
module Network.HTTP.Lucu.Response
( StatusCode(..)
, Response(..)
+ , printStatusCode
, hPutResponse
, isInformational
, isSuccessful
, statusCode
)
where
-
-import qualified Data.ByteString as Strict (ByteString)
-import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
-import Data.Typeable
-import Network.HTTP.Lucu.Format
-import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Monoid.Unicode
+import Data.Typeable
+import Network.HTTP.Lucu.Format
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Prelude.Unicode
-- |This is the definition of HTTP status code.
-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
| GatewayTimeout
| HttpVersionNotSupported
| InsufficientStorage
- deriving (Typeable, Eq)
-
-instance Show StatusCode where
- show sc = case statusCode sc of
- (# num, msg #)
- -> (fmtDec 3 num) ++ " " ++ C8.unpack msg
+ deriving (Eq, Show, Typeable)
+-- |Convert a 'StatusCode' to 'Ascii'.
+printStatusCode ∷ StatusCode → Ascii
+printStatusCode (statusCode → (# num, msg #))
+ = A.fromAsciiBuilder $
+ ( fmtDec 3 num ⊕
+ A.toAsciiBuilder " " ⊕
+ A.toAsciiBuilder msg
+ )
data Response = Response {
- resVersion :: !HttpVersion
- , resStatus :: !StatusCode
- , resHeaders :: !Headers
+ resVersion ∷ !HttpVersion
+ , resStatus ∷ !StatusCode
+ , resHeaders ∷ !Headers
} deriving (Show, Eq)
-
instance HasHeaders Response where
getHeaders = resHeaders
setHeaders res hdr = res { resHeaders = hdr }
-
-hPutResponse :: HandleLike h => h -> Response -> IO ()
-hPutResponse h res
- = h `seq` res `seq`
- do hPutHttpVersion h (resVersion res)
+hPutResponse ∷ HandleLike h ⇒ h → Response → IO ()
+hPutResponse h (Response {..})
+ = do hPutHttpVersion h resVersion
hPutChar h ' '
- hPutStatus h (resStatus res)
- hPutBS h (C8.pack "\r\n")
- hPutHeaders h (resHeaders res)
-
-hPutStatus :: HandleLike h => h -> StatusCode -> IO ()
-hPutStatus h sc
- = h `seq` sc `seq`
- case statusCode sc of
- (# num, msg #)
- -> do hPutStr h (fmtDec 3 num)
- hPutChar h ' '
- hPutBS h msg
+ hPutStatus h resStatus
+ hPutBS h "\r\n"
+ hPutHeaders h resHeaders
+hPutStatus ∷ HandleLike h ⇒ h → StatusCode → IO ()
+hPutStatus h (statusCode → (# num, msg #))
+ = do hPutBS h (A.toByteString $ A.fromAsciiBuilder $ fmtDec 3 num)
+ hPutChar h ' '
+ hPutBS h (A.toByteString msg)
-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
-isInformational :: StatusCode -> Bool
+isInformational ∷ StatusCode → Bool
isInformational = doesMeet (< 200)
-- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@.
-isSuccessful :: StatusCode -> Bool
-isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
+isSuccessful ∷ StatusCode → Bool
+isSuccessful = doesMeet (\ n → n ≥ 200 ∧ n < 300)
-- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@.
-isRedirection :: StatusCode -> Bool
-isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
+isRedirection ∷ StatusCode → Bool
+isRedirection = doesMeet (\ n → n ≥ 300 ∧ n < 400)
-- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
-isError :: StatusCode -> Bool
-isError = doesMeet (>= 400)
+isError ∷ StatusCode → Bool
+isError = doesMeet (≥ 400)
-- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@.
-isClientError :: StatusCode -> Bool
-isClientError = doesMeet (\ n -> n >= 400 && n < 500)
+isClientError ∷ StatusCode → Bool
+isClientError = doesMeet (\ n → n ≥ 400 ∧ n < 500)
-- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@.
-isServerError :: StatusCode -> Bool
-isServerError = doesMeet (>= 500)
-
-
-doesMeet :: (Int -> Bool) -> StatusCode -> Bool
-doesMeet p sc = case statusCode sc of
- (# num, _ #) -> p num
+isServerError ∷ StatusCode → Bool
+isServerError = doesMeet (≥ 500)
+doesMeet ∷ (Int → Bool) → StatusCode → Bool
+{-# INLINE doesMeet #-}
+doesMeet p (statusCode → (# num, _ #)) = p num
-- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
-- representation of @sc@.
-statusCode :: StatusCode -> (# Int, Strict.ByteString #)
-
-statusCode Continue = (# 100, C8.pack "Continue" #)
-statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #)
-statusCode Processing = (# 102, C8.pack "Processing" #)
-
-statusCode Ok = (# 200, C8.pack "OK" #)
-statusCode Created = (# 201, C8.pack "Created" #)
-statusCode Accepted = (# 202, C8.pack "Accepted" #)
-statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #)
-statusCode NoContent = (# 204, C8.pack "No Content" #)
-statusCode ResetContent = (# 205, C8.pack "Reset Content" #)
-statusCode PartialContent = (# 206, C8.pack "Partial Content" #)
-statusCode MultiStatus = (# 207, C8.pack "Multi Status" #)
-
-statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #)
-statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #)
-statusCode Found = (# 302, C8.pack "Found" #)
-statusCode SeeOther = (# 303, C8.pack "See Other" #)
-statusCode NotModified = (# 304, C8.pack "Not Modified" #)
-statusCode UseProxy = (# 305, C8.pack "Use Proxy" #)
-statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #)
-
-statusCode BadRequest = (# 400, C8.pack "Bad Request" #)
-statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #)
-statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #)
-statusCode Forbidden = (# 403, C8.pack "Forbidden" #)
-statusCode NotFound = (# 404, C8.pack "Not Found" #)
-statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #)
-statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #)
-statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #)
-statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #)
-statusCode Conflict = (# 409, C8.pack "Conflict" #)
-statusCode Gone = (# 410, C8.pack "Gone" #)
-statusCode LengthRequired = (# 411, C8.pack "Length Required" #)
-statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #)
-statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #)
-statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #)
-statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #)
-statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #)
-statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #)
-statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #)
-statusCode Locked = (# 423, C8.pack "Locked" #)
-statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #)
-
-statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #)
-statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #)
-statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #)
-statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #)
-statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #)
-statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #)
-statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #)
\ No newline at end of file
+statusCode ∷ StatusCode → (# Int, Ascii #)
+
+statusCode Continue = (# 100, "Continue" #)
+statusCode SwitchingProtocols = (# 101, "Switching Protocols" #)
+statusCode Processing = (# 102, "Processing" #)
+
+statusCode Ok = (# 200, "OK" #)
+statusCode Created = (# 201, "Created" #)
+statusCode Accepted = (# 202, "Accepted" #)
+statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #)
+statusCode NoContent = (# 204, "No Content" #)
+statusCode ResetContent = (# 205, "Reset Content" #)
+statusCode PartialContent = (# 206, "Partial Content" #)
+statusCode MultiStatus = (# 207, "Multi Status" #)
+
+statusCode MultipleChoices = (# 300, "Multiple Choices" #)
+statusCode MovedPermanently = (# 301, "Moved Permanently" #)
+statusCode Found = (# 302, "Found" #)
+statusCode SeeOther = (# 303, "See Other" #)
+statusCode NotModified = (# 304, "Not Modified" #)
+statusCode UseProxy = (# 305, "Use Proxy" #)
+statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #)
+
+statusCode BadRequest = (# 400, "Bad Request" #)
+statusCode Unauthorized = (# 401, "Unauthorized" #)
+statusCode PaymentRequired = (# 402, "Payment Required" #)
+statusCode Forbidden = (# 403, "Forbidden" #)
+statusCode NotFound = (# 404, "Not Found" #)
+statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #)
+statusCode NotAcceptable = (# 406, "Not Acceptable" #)
+statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #)
+statusCode RequestTimeout = (# 408, "Request Timeout" #)
+statusCode Conflict = (# 409, "Conflict" #)
+statusCode Gone = (# 410, "Gone" #)
+statusCode LengthRequired = (# 411, "Length Required" #)
+statusCode PreconditionFailed = (# 412, "Precondition Failed" #)
+statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #)
+statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #)
+statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #)
+statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #)
+statusCode ExpectationFailed = (# 417, "Expectation Failed" #)
+statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #)
+statusCode Locked = (# 423, "Locked" #)
+statusCode FailedDependency = (# 424, "Failed Dependency" #)
+
+statusCode InternalServerError = (# 500, "Internal Server Error" #)
+statusCode NotImplemented = (# 501, "Not Implemented" #)
+statusCode BadGateway = (# 502, "Bad Gateway" #)
+statusCode ServiceUnavailable = (# 503, "Service Unavailable" #)
+statusCode GatewayTimeout = (# 504, "Gateway Timeout" #)
+statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #)
+statusCode InsufficientStorage = (# 507, "Insufficient Storage" #)
{-# LANGUAGE
BangPatterns
+ , OverloadedStrings
, UnicodeSyntax
#-}
-- |Utility functions used internally in the Lucu httpd. These
module Network.HTTP.Lucu.Utils
( splitBy
, joinWith
- , trim
- , isWhiteSpace
, quoteStr
, parseWWWFormURLEncoded
)
where
import Control.Monad
-import Data.List hiding (last)
+import Data.Ascii (Ascii, AsciiBuilder)
+import qualified Data.Ascii as A
+import qualified Data.ByteString.Char8 as BS
+import Data.List hiding (last)
+import Data.Monoid.Unicode
import Network.URI
-import Prelude hiding (last)
+import Prelude hiding (last)
import Prelude.Unicode
-- |> splitBy (== ':') "ab:c:def"
-- > ==> ["ab", "c", "def"]
-splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy ∷ (a → Bool) → [a] → [[a]]
splitBy isSep src
= case break isSep src
- of (last , [] ) -> [last]
- (first, _sep:rest) -> first : splitBy isSep rest
+ of (last , [] ) → [last]
+ (first, _sep:rest) → first : splitBy isSep rest
-- |> joinWith ":" ["ab", "c", "def"]
-- > ==> "ab:c:def"
-joinWith :: [a] -> [[a]] -> [a]
-joinWith = (join .) . intersperse
-
--- |> trim (== '_') "__ab_c__def___"
--- > ==> "ab_c__def"
-trim :: (a -> Bool) -> [a] -> [a]
-trim !p = trimTail . trimHead
+joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder
+{-# INLINEABLE joinWith #-}
+joinWith sep = flip go (∅)
where
- trimHead = dropWhile p
- trimTail = reverse . trimHead . reverse
-
--- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR
--- and LF.
-isWhiteSpace :: Char -> Bool
-isWhiteSpace ' ' = True
-isWhiteSpace '\t' = True
-isWhiteSpace '\r' = True
-isWhiteSpace '\n' = True
-isWhiteSpace _ = False
-{-# INLINE isWhiteSpace #-}
+ go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder
+ {-# INLINE go #-}
+ go [] ab = ab
+ go (x:[]) ab = ab ⊕ x
+ go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x)
-- |> quoteStr "abc"
-- > ==> "\"abc\""
--
-- > quoteStr "ab\"c"
-- > ==> "\"ab\\\"c\""
-quoteStr :: String -> String
-quoteStr !str = concat (["\""] ++ map quote str ++ ["\""])
+quoteStr ∷ Ascii → AsciiBuilder
+quoteStr str = A.toAsciiBuilder "\"" ⊕
+ go (A.toByteString str) (∅) ⊕
+ A.toAsciiBuilder "\""
where
- quote :: Char -> String
- quote '"' = "\\\""
- quote c = [c]
+ go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
+ go bs ab
+ = case BS.break (≡ '"') bs of
+ (x, y)
+ | BS.null y → ab ⊕ b2ab x
+ | otherwise → go (BS.tail y) (ab ⊕ b2ab x
+ ⊕ A.toAsciiBuilder "\\\"")
+ b2ab ∷ BS.ByteString → AsciiBuilder
+ b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
-- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
-- > ==> [("aaa", "bbb"), ("ccc", "ddd")]
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-07-29 16:01:14.666629 Z
references: []
- PHO <pho@cielonegro.org>
- assigned to release Lucu-1.0 from unassigned
- ""
-git_branch:
+- - 2011-07-30 11:17:25.622897 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2010-03-12 06:56:06.939283 Z
references: []
- PHO <pho@cielonegro.org>
- assigned to release Lucu-1.0 from unassigned
- ""
-git_branch:
+- - 2011-07-30 11:17:19.173203 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-07-30 04:39:53.073102 Z
references: []
- PHO <pho@cielonegro.org>
- created
- ""
-git_branch:
+- - 2011-07-30 11:17:28.677836 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types CompileMimeTypes
./CompileMimeTypes $< $@
-CompileMimeTypes: CompileMimeTypes.hs
- ghc --make $@
+CompileMimeTypes:
+ ghc --make $@ -i..
+
+clean:
+ rm -f *.hi *.o CompileMimeTypes
+
+.PHONY: clean
projects / Lucu.git / commitdiff