import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
-import Data.Text (Text)
import Network.Socket
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.HttpVersion
, itrLocalPort ∷ !PortNumber
, itrRemoteAddr ∷ !SockAddr
, itrRemoteCert ∷ !(Maybe X509)
- , itrResourcePath ∷ !(Maybe [Text])
+ , itrResourcePath ∷ !(Maybe [Strict.ByteString])
, itrRequest ∷ !(Maybe Request)
, itrExpectedContinue ∷ !(Maybe Bool)
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
import Network.Socket
import Network.URI
acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
= do let itr = oldItr { itrResourcePath = Just rsrcPath }
atomically $ enqueue ctx itr
- do _ ← runResource rsrcDef itr
+ do _ ← spawnResource rsrcDef itr
if reqMustHaveBody $ fromJust $ itrRequest itr then
observeRequest ctx itr input
else
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
-- 'getResourcePath'.
--
--- Note that the returned path is URI-decoded and then UTF-8 decoded.
-getPathInfo ∷ Resource [Text]
+-- Note that the returned path components are URI-decoded.
+getPathInfo ∷ Resource [Strict.ByteString]
getPathInfo = do rsrcPath ← getResourcePath
reqPath ← splitPathInfo <$> getRequestURI
- -- rsrcPath と reqPath の共通する先頭部分を reqPath か
- -- ら全部取り除くと、それは PATH_INFO のやうなものにな
- -- る。rsrcPath は全部一致してゐるに決まってゐる（でな
- -- ければこの Resource が撰ばれた筈が無い）ので、
- -- rsrcPath の長さの分だけ削除すれば良い。
return $ drop (length rsrcPath) reqPath
-- |Assume the query part of request URI as
-- application\/x-www-form-urlencoded, and parse it into pairs of
-- @(name, formData)@. This function doesn't read the request
--- body. Field names are decoded in UTF-8. See 'getForm'.
+-- body. Field names are decoded in UTF-8 for an hardly avoidable
+-- reason. See 'getForm'.
getQueryForm ∷ Resource [(Text, FormData)]
getQueryForm = parse' <$> getRequestURI
where
--
-- Field names in @multipart\/form-data@ will be precisely decoded in
-- accordance with RFC 2231. On the other hand,
--- @application\/x-www-form-urlencoded@ says nothing about the
--- encoding of field names, so they'll always be decoded in
+-- @application\/x-www-form-urlencoded@ says nothing about character
+-- encodings for field names, so they'll always be decoded in
-- UTF-8. (This could be a bad design, but I can't think of any better
-- idea.)
getForm ∷ Maybe Int → Resource [(Text, FormData)]
import Data.List
import Data.Maybe
import Data.Monoid.Unicode
-import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
-- > ...
-- > , ...
-- > }
-getResourcePath ∷ Resource [Text]
+getResourcePath ∷ Resource [Strict.ByteString]
getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
)
where
import Control.Arrow
-import Control.Applicative
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Control.Monad
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Foldable
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Data.Monoid.Unicode
-import Network.HTTP.Lucu.Abortion
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
-import Network.HTTP.Lucu.Headers (fromHeaders)
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Interaction
+import Data.Sequence (Seq)
+import Data.Sequence.Unicode hiding ((∅))
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Utils
import Network.URI hiding (path)
import System.IO
-- httpd first searches for a resource in the tree, and then calls
-- fallback handlers to ask them for a resource. If all of the
-- handlers returned 'Nothing', the httpd responds with 404 Not Found.
-type FallbackHandler = [Text] → IO (Maybe ResourceDef)
+type FallbackHandler = [ByteString] → IO (Maybe ResourceDef)
-- |'ResTree' is an opaque structure which is a map from resource path
-- to 'ResourceDef'.
newtype ResTree = ResTree ResNode -- root だから Map ではない
-type ResSubtree = Map Text ResNode
+type ResSubtree = Map ByteString ResNode
data ResNode = ResNode (Maybe ResourceDef) ResSubtree
-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
-- ]
-- @
--
--- Note that the request path in an incoming HTTP request is always
--- treated as an URI-encoded UTF-8 string.
-mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
+-- Note that path components are always represented as octet streams
+-- in this system. Lucu automatically decodes percent-encoded URIs but
+-- has no involvement in character encodings such as UTF-8, since RFC
+-- 2616 (HTTP/1.1) says nothing about character encodings to be used
+-- in \"http\" and \"https\" URI schemas.
+mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree
mkResTree = processRoot ∘ map (first canonicalisePath)
where
- canonicalisePath ∷ [Text] → [Text]
- canonicalisePath = filter (≢ "")
+ canonicalisePath ∷ [ByteString] → [ByteString]
+ canonicalisePath = filter ((¬) ∘ BS.null)
- processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
+ processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree
processRoot list
= let (roots, nonRoots) = partition (\(path, _) → null path) list
children = processNonRoot nonRoots
in
ResTree (ResNode (Just def) children)
- processNonRoot ∷ [ ([Text], ResourceDef) ] → ResSubtree
+ processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree
processNonRoot list
= let subtree = M.fromList [(name, node name)
| name ← childNames]
in
subtree
-findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
+findResource ∷ ResTree
+ → [FallbackHandler]
+ → URI
+ → IO (Maybe ([ByteString], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
= do let path = splitPathInfo uri
hasGreedyRoot = maybe False resIsGreedy rootDefM
do def ← rootDefM
return ([], def)
else
- walkTree subtree path []
+ walkTree subtree path (∅)
if isJust foundInTree then
return foundInTree
else
fallback path fbs
where
- walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], ResourceDef)
+ walkTree ∷ ResSubtree
+ → [ByteString]
+ → Seq ByteString
+ → Maybe ([ByteString], ResourceDef)
walkTree _ [] _
= error "Internal error: should not reach here."
walkTree tree (name:[]) soFar
= do ResNode defM _ ← M.lookup name tree
def ← defM
- return (soFar ⧺ [name], def)
+ return (toList $ soFar ⊳ name, def)
walkTree tree (x:xs) soFar
= do ResNode defM sub ← M.lookup x tree
case defM of
Just (ResourceDef { resIsGreedy = True })
→ do def ← defM
- return (soFar ⧺ [x], def)
- _ â\86\92 walkTree sub xs (soFar ⧺ [x])
+ return (toList $ soFar ⊳ x, def)
+ _ â\86\92 walkTree sub xs (soFar â\8a³ x)
- fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
+ fallback ∷ [ByteString]
+ → [FallbackHandler]
+ → IO (Maybe ([ByteString], ResourceDef))
fallback _ [] = return Nothing
fallback path (x:xs) = do m ← x path
case m of
import Control.Monad.Unicode
import Control.Monad.Trans
import qualified Data.Ascii as A
-import qualified Data.ByteString.Lazy.Char8 as B
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Monoid.Unicode
+import Data.String
import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import Data.Time.Clock.POSIX
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.MIMEType.Guess
import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.FilePath
Just mime → setContentType mime
when sendContent
- $ liftIO (B.readFile path) ≫= putChunk
+ $ liftIO (LBS.readFile path) ≫= putChunks
-- |@'generateETagFromFile' fpath@ generates a strong entity tag from
-- a file. The file doesn't necessarily have to be a regular file; it
return $ strongETag tag
-- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
--- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
+-- @dir@ and its subdirectories on the filesystem to the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
--
-- Note that 'staticDir' currently doesn't have a directory-listing
-- capability. Requesting the content of a directory will end up being
, resHead = Just $ handleStaticDir False path
}
+-- TODO: implement directory listing.
handleStaticDir ∷ Bool → FilePath → Resource ()
handleStaticDir sendContent basePath
= do extraPath ← getPathInfo
securityCheck extraPath
- let path = basePath </> joinPath (map T.unpack extraPath)
-
+ let path = basePath </> joinPath (map dec8 extraPath)
handleStaticFile sendContent path
where
- securityCheck pathElems
- = when (any (≡ "..") pathElems)
- $ fail ("security error: " ⧺ show pathElems)
--- TODO: implement directory listing.
+ dec8 ∷ ByteString → String
+ dec8 = T.unpack ∘ T.decodeUtf8
+
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+ = when (any (≡ "..") pathElems)
+ $ fail ("security error: " ⧺ show pathElems)
import qualified Data.ByteString.Char8 as BS
import Data.List hiding (last)
import Data.Monoid.Unicode
-import Data.Text (Text)
-import Data.Text.Encoding as T
import Network.URI
import Prelude hiding (last)
import Prelude.Unicode
-- |> splitPathInfo "http://example.com/foo/bar"
-- > ==> ["foo", "bar"]
-splitPathInfo ∷ URI → [Text]
+splitPathInfo ∷ URI → [ByteString]
splitPathInfo uri
= let reqPathStr = uriPath uri
reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
in
- map (T.decodeUtf8 ∘ BS.pack) reqPath
+ map BS.pack reqPath
-- |> show3 5
-- > ==> "005"
projects / Lucu.git / commitdiff