import Codec.Compression.GZip
import Control.Monad
import Data.Bits
-import Data.ByteString.Base (LazyByteString)
-import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as L hiding (ByteString)
import Data.Char
import Data.Digest.SHA1
import Data.Int
import Data.Maybe
+import Data.Time
+import Data.Time.Clock.POSIX
import Data.Word
import Language.Haskell.Pretty
import Language.Haskell.Syntax
import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
import Network.HTTP.Lucu.MIMEType.Guess
import System.Console.GetOpt
-import System.Directory
import System.Environment
import System.Exit
+import System.Posix.Files
import System.IO
-import System.Time
data CmdOpt
= OptOutput FilePath
rawB64 = encode $ L.unpack input
gzippedB64 = encode $ L.unpack gzippedData
- header = mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
+ header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
- hsModule = HsModule undefined (Module modName) (Just exports) imports decls
+ let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
exports = [HsEVar (UnQual (HsIdent symName))]
imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
False Nothing Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Base")
- False Nothing (Just (False, [HsIVar (HsIdent "LazyByteString")]))
, HsImportDecl undefined (Module "Data.ByteString.Lazy")
True (Just (Module "L")) Nothing
- , HsImportDecl undefined (Module "Network.HTTP.Lucu")
+ , HsImportDecl undefined (Module "Data.Time")
False Nothing Nothing
- , HsImportDecl undefined (Module "System.Time")
+ , HsImportDecl undefined (Module "Network.HTTP.Lucu")
False Nothing Nothing
]
++
declLastModified
= [ HsTypeSig undefined [HsIdent "lastModified"]
(HsQualType []
- (HsTyCon (UnQual (HsIdent "ClockTime"))))
+ (HsTyCon (UnQual (HsIdent "UTCTime"))))
, HsFunBind [HsMatch undefined (HsIdent "lastModified")
[] (HsUnGuardedRhs defLastModified) []]
]
defLastModified :: HsExp
defLastModified
- = let TOD a b = lastMod
- in
- (HsApp (HsApp (HsCon (UnQual (HsIdent "TOD")))
- (HsLit (HsInt a)))
- (HsLit (HsInt b)))
+ = HsApp (HsVar (UnQual (HsIdent "read")))
+ (HsLit (HsString $ show lastMod))
declContentType :: [HsDecl]
declGZippedData
= [ HsTypeSig undefined [HsIdent "gzippedData"]
(HsQualType []
- (HsTyCon (UnQual (HsIdent "LazyByteString"))))
+ (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
, HsFunBind [HsMatch undefined (HsIdent "gzippedData")
[] (HsUnGuardedRhs defGZippedData) []]
]
declRawData
= [ HsTypeSig undefined [HsIdent "rawData"]
(HsQualType []
- (HsTyCon (UnQual (HsIdent "LazyByteString"))))
+ (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))
, HsFunBind [HsMatch undefined (HsIdent "rawData")
[] (HsUnGuardedRhs defRawData) []]
]
hClose output
-mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String
+mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
- = "{- DO NOT EDIT THIS FILE.\n" ++
- " This file is automatically generated by the lucu-implant-file program.\n" ++
- "\n" ++
- " Source: " ++ (if srcFile == "-"
- then "(stdin)"
- else srcFile) ++ "\n" ++
- " Original Length: " ++ show originalLen ++ " bytes\n" ++
- (if useGZip
- then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
- " Compression: gzip\n"
- else " Compression: disabled\n") ++
- " MIME Type: " ++ show mimeType ++ "\n" ++
- " ETag: " ++ eTag ++ "\n" ++
- " Last Modified: " ++ show lastMod ++ "\n" ++
- " -}"
+ = do localLastMod <- utcToLocalZonedTime lastMod
+ return ("{- DO NOT EDIT THIS FILE.\n" ++
+ " This file is automatically generated by the lucu-implant-file program.\n" ++
+ "\n" ++
+ " Source: " ++ (if srcFile == "-"
+ then "(stdin)"
+ else srcFile) ++ "\n" ++
+ " Original Length: " ++ show originalLen ++ " bytes\n" ++
+ (if useGZip
+ then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
+ " Compression: gzip\n"
+ else " Compression: disabled\n") ++
+ " MIME Type: " ++ show mimeType ++ "\n" ++
+ " ETag: " ++ eTag ++ "\n" ++
+ " Last Modified: " ++ show localLastMod ++ "\n" ++
+ " -}")
getModuleName :: [CmdOpt] -> IO String
defaultSymName = mkDefault modName
mkDefault = headToLower . getLastComp
headToLower = \ str -> case str of
+ [] -> error "module name must not be empty"
(x:xs) -> toLower x : xs
getLastComp = reverse . fst . break (== '.') . reverse
in
_ -> error "too many --mime-type options."
-getLastModified :: FilePath -> IO ClockTime
-getLastModified "-" = getClockTime
-getLastModified fpath = getModificationTime fpath
+getLastModified :: FilePath -> IO UTCTime
+getLastModified "-" = getCurrentTime
+getLastModified fpath = getFileStatus fpath
+ >>= return . posixSecondsToUTCTime . toEnum . fromEnum . modificationTime
-getETag :: [CmdOpt] -> LazyByteString -> IO String
+getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
getETag opts input
= let eTagOpts = filter (\ x -> case x of
OptETag _ -> True
hex4bit :: Int -> Char
hex4bit n
- | n < 10 = (chr $ ord '0' + n )
- | n < 16 = (chr $ ord 'a' + n - 10)
+ | n < 10 = (chr $ ord '0' + n )
+ | n < 16 = (chr $ ord 'a' + n - 10)
+ | otherwise = undefined
-openInput :: FilePath -> IO LazyByteString
+openInput :: FilePath -> IO Lazy.ByteString
openInput "-" = L.getContents
openInput fpath = L.readFile fpath
Compression: disabled
MIME Type: image/png
ETag: d41d8cd98f00b204e9800998ecf8427e
- Last Modified: Wed, 03 Oct 2007 00:55:45 JST
+ Last Modified: 2007-11-05 13:53:42.231882 JST
-}
module Foo.Bar.Baz (baz) where
import Codec.Binary.Base64
- import Data.ByteString.Base (LazyByteString)
import qualified Data.ByteString.Lazy as L
+ import Data.Time
import Network.HTTP.Lucu
- import System.Time
baz :: ResourceDef
baz = ResourceDef {
entityTag :: ETag
entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
- lastModified :: ClockTime
- lastModified = TOD 1191340545 0
+ lastModified :: UTCTime
+ lastModified = read "2007-11-05 04:47:56.008366 UTC"
contentType :: MIMEType
contentType = read "image/png"
- rawData :: LazyByteString
+ rawData :: L.ByteString
rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")
------------------------------------------------------------------------------
}
-- rawData の代はりに gzippedData
- gzippedData :: LazyByteString
+ gzippedData :: L.ByteString
gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")
------------------------------------------------------------------------------
-}
Stability: experimental
Homepage: http://ccm.sherry.jp/Lucu/
Category: Network
-Tested-With: GHC == 6.6.1
+Tested-With: GHC == 6.8.1
Build-Depends:
- base, mtl, network, stm, hxt, haskell-src, unix, zlib, Crypto
+ Crypto, base, bytestring, containers, directory, haskell-src,
+ hxt, mtl, network, stm, time, unix, zlib
Exposed-Modules:
Network.HTTP.Lucu
Network.HTTP.Lucu.Abortion
examples/Makefile
ghc-options:
-fglasgow-exts
- -fwarn-missing-signatures
- -fwarn-unused-imports
+ -Wall
-funbox-strict-fields
- -O3
+
Executable: lucu-implant-file
Main-Is: ImplantFile.hs
ghc-options:
-fglasgow-exts
- -fwarn-missing-signatures
- -fwarn-unused-imports
+ -Wall
-funbox-strict-fields
- -O3
+
--Executable: HelloWorld
--Main-Is: HelloWorld.hs
$(MAKE) -C examples run
.setup-config: $(CABAL_FILE) Setup
-# ./Setup configure
- ./Setup configure -p
+# ./Setup configure --disable-optimization
+ ./Setup configure -p --enable-split-objs
Setup: Setup.hs
$(GHC) --make Setup
$(MAKE) -C examples clean
doc: .setup-config Setup
- ./Setup haddock
+ ./Setup haddock --hyperlink-source --haddock-css=../hscolour/hscolour.css
install: build
- ./Setup install
+ sudo ./Setup install
sdist: Setup
./Setup sdist
-.PHONY: build run clean install doc sdist
\ No newline at end of file
+.PHONY: build run clean install doc sdist
)
where
-import Data.ByteString.Base (ByteString)
-import qualified Data.ByteString.Char8 as C8
+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
-- '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 :: !ByteString
+ cnfServerSoftware :: !Strict.ByteString
-- |The host name of the server. This value will be used in
-- built-in pages like \"404 Not Found\".
- , cnfServerHost :: !ByteString
+ , cnfServerHost :: !Strict.ByteString
-- |A port ID to listen to HTTP clients.
, cnfServerPort :: !PortID
-- |The maximum number of requests to accept in one connection
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network.URI
+import Network.URI hiding (path)
import System.IO.Unsafe
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
writeDefaultPage :: Interaction -> STM ()
writeDefaultPage itr
= itr `seq`
- do wroteHeader <- readTVar (itrWroteHeader itr)
-
- -- Content-Type が正しくなければ補完できない。
- res <- readItr itr itrResponse id
+ -- Content-Type が正しくなければ補完できない。
+ do res <- readItr itr itrResponse id
when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
$ do reqM <- readItr itr itrRequest id
import Control.Monad
import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
+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.
sign ++ padded
where
fmt' :: Int -> String
- fmt' n
- | n < base = (intToChar upperCase n) : []
- | otherwise = (intToChar upperCase $! n `mod` base) : fmt' (n `div` base)
+ fmt' m
+ | m < base = (intToChar upperCase m) : []
+ | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base)
fmtDec :: Int -> Int -> String
intToChar False 14 = 'e'
intToChar True 14 = 'E'
intToChar False 15 = 'f'
-intToChar True 15 = 'F'
\ No newline at end of file
+intToChar True 15 = 'F'
+intToChar _ _ = undefined
)
where
-import Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO)
-import qualified Data.ByteString.Char8 as C8
+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 Network.HTTP.Lucu.Utils
import System.IO
-type Headers = Map NCBS ByteString
-newtype NCBS = NCBS ByteString
+type Headers = Map NCBS Strict.ByteString
+newtype NCBS = NCBS Strict.ByteString
-toNCBS :: ByteString -> NCBS
+toNCBS :: Strict.ByteString -> NCBS
toNCBS = NCBS
{-# INLINE toNCBS #-}
-fromNCBS :: NCBS -> ByteString
+fromNCBS :: NCBS -> Strict.ByteString
fromNCBS (NCBS x) = x
{-# INLINE fromNCBS #-}
instance Show NCBS where
show (NCBS x) = show x
-noCaseCmp :: ByteString -> ByteString -> Ordering
+noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering
noCaseCmp a b = a `seq` b `seq`
toForeignPtr a `cmp` toForeignPtr b
where
x -> return x
-noCaseEq :: ByteString -> ByteString -> Bool
+noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool
noCaseEq a b = a `seq` b `seq`
toForeignPtr a `cmp` toForeignPtr b
where
getHeaders :: a -> Headers
setHeaders :: a -> Headers -> a
- getHeader :: ByteString -> a -> Maybe ByteString
+ getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
getHeader key a
= key `seq` a `seq`
M.lookup (toNCBS key) (getHeaders a)
- deleteHeader :: ByteString -> a -> a
+ deleteHeader :: Strict.ByteString -> a -> a
deleteHeader key a
= key `seq` a `seq`
setHeaders a $ M.delete (toNCBS key) (getHeaders a)
- setHeader :: ByteString -> ByteString -> a -> 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 = M.empty
-toHeaders :: [(ByteString, ByteString)] -> Headers
+toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers
toHeaders xs = mkHeaders xs M.empty
-mkHeaders :: [(ByteString, ByteString)] -> Headers -> Headers
+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
where
- merge :: ByteString -> ByteString -> ByteString
+ merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
-- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
-- ヘッダは複數個あってはならない事になってゐる。
merge a b
| otherwise = C8.concat [a, C8.pack ", ", b]
-fromHeaders :: Headers -> [(ByteString, ByteString)]
+fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]
crlf
return $! toHeaders xs
where
- header :: Parser (ByteString, ByteString)
+ header :: Parser (Strict.ByteString, Strict.ByteString)
header = do name <- token
char ':'
-- FIXME: これは多少インチキだが、RFC 2616 のこの部分
= h `seq` hds `seq`
mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n")
where
- putH :: (NCBS, ByteString) -> IO ()
+ putH :: (NCBS, Strict.ByteString) -> IO ()
putH (name, value)
= name `seq` value `seq`
do C8.hPut h (fromNCBS name)
import qualified Data.ByteString.Char8 as C8
import Network.HTTP.Lucu.Parser
+import Prelude hiding (min)
import System.IO
-- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
where
import Control.Concurrent.STM
-import Data.ByteString.Base (ByteString, LazyByteString)
-import Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
+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 qualified Data.Sequence as S
import Data.Sequence (Seq)
import Network.Socket
itrConfig :: !Config
, itrRemoteAddr :: !SockAddr
, itrResourcePath :: !(Maybe [String])
- , itrRequest :: !(TVar (Maybe Request))
+ , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
, itrResponse :: !(TVar Response)
- , itrRequestHasBody :: !(TVar Bool)
- , itrRequestIsChunked :: !(TVar Bool)
- , itrExpectedContinue :: !(TVar Bool)
+ , 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 LazyByteString) -- Resource が受領した部分は削除される
+ , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
, itrWillReceiveBody :: !(TVar Bool)
, itrWillChunkBody :: !(TVar Bool)
, itrWillDiscardBody :: !(TVar Bool)
, itrWillClose :: !(TVar Bool)
- , itrBodyToSend :: !(TVar LazyByteString)
+ , itrBodyToSend :: !(TVar Lazy.ByteString)
, itrBodyIsNull :: !(TVar Bool)
, itrState :: !(TVar InteractionState)
newInteractionQueue = newTVarIO S.empty
-defaultPageContentType :: ByteString
+defaultPageContentType :: Strict.ByteString
defaultPageContentType = C8.pack "application/xhtml+xml"
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
+import Prelude hiding (min)
-- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
-- represents \"major\/minor; name=value\".
)
where
-import Data.ByteString.Base (LazyByteString(..))
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
Nothing
-> abortPurely BadRequest []
(Just "There is a part without Content-Disposition in the multipart/form-data.")
- Just dispo
- -> case parse contDispoP (LPS [dispo]) of
+ Just dispoStr
+ -> case parse contDispoP (L8.fromChunks [dispoStr]) of
(# Success dispo, _ #)
-> (getName dispo, body)
(# _, _ #)
-> abortPurely BadRequest []
- (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo)
+ (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
where
getName :: ContDispo -> String
getName dispo@(ContDispo dType dParams)
where
import Control.Monad.State.Strict
-import Data.ByteString.Base (LazyByteString)
-import Data.ByteString.Lazy ()
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
-- |@'Parser' a@ is obviously a parser which parses and returns @a@.
newtype Parser a = Parser {
data ParserState
= PST {
- pstInput :: LazyByteString
+ pstInput :: Lazy.ByteString
, pstIsEOFFatal :: !Bool
}
deriving (Eq, Show)
-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
-- remaining #)@.
-parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #)
+parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #)
parse p input -- input は lazy である必要有り。
= p `seq`
let (result, state') = runState (runParser p) (PST input True)
result `seq` (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。
-- |@'parseStr' p str@ packs @str@ and parses it.
-parseStr :: Parser a -> String -> (# ParserResult a, LazyByteString #)
+parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #)
parseStr p input
= p `seq` -- input は lazy である必要有り。
parse p (B.pack input)
Parser $! do saved <- get -- 状態を保存
result <- runParser p
case result of
- Success a -> do put saved -- 状態を復歸
+ Success _ -> do put saved -- 状態を復歸
return IllegalInput
IllegalInput -> do put saved -- 状態を復歸
return $! Success ()
qdtext = do c <- satisfy (/= '"')
return [c]
- quotedPair = do q <- char '\\'
+ quotedPair = do char '\\'
c <- satisfy isChar
return [c]
qvalue :: Parser Double
qvalue = do x <- char '0'
xs <- option ""
- $ do x <- char '.'
- xs <- many digit -- 本當は三文字までに制限
- return (x:xs)
+ $ do y <- char '.'
+ ys <- many digit -- 本當は三文字までに制限
+ return (y:ys)
return $ read (x:xs)
<|>
do x <- char '1'
xs <- option ""
- $ do x <- char '.'
- xs <- many (char '0') -- 本當は三文字までに制限
- return (x:xs)
+ $ do y <- char '.'
+ ys <- many (char '0') -- 本當は三文字までに制限
+ return (y:ys)
return $ read (x:xs)
import Control.Concurrent.STM
import Control.Monad
-import Data.ByteString.Base (ByteString)
-import qualified Data.ByteString.Char8 as C8
+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 GHC.Conc (unsafeIOToSTM)
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.RFC1123DateTime
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import System.Time
import System.IO.Unsafe
{-
$ abortSTM InternalServerError []
$ Just ("The status code was " ++ show sc ++ " but no Location header.")
- when (reqM /= Nothing)
- $ relyOnRequest itr
+ when (reqM /= Nothing) relyOnRequest
-- itrResponse の内容は relyOnRequest によって變へられてゐる可
-- 能性が高い。
$ completeUnconditionalHeaders (itrConfig itr) oldRes
writeItr itr itrResponse newRes
where
- relyOnRequest :: Interaction -> STM ()
- relyOnRequest itr
- = itr `seq`
- do status <- readItr itr itrResponse resStatus
+ relyOnRequest :: STM ()
+ relyOnRequest
+ = do status <- readItr itr itrResponse resStatus
req <- readItr itr itrRequest fromJust
let reqVer = reqVersion req
status == ResetContent ||
status == NotModified )
- updateRes itr $! deleteHeader (C8.pack "Content-Length")
- updateRes itr $! deleteHeader (C8.pack "Transfer-Encoding")
+ updateRes $! deleteHeader (C8.pack "Content-Length")
+ updateRes $! deleteHeader (C8.pack "Transfer-Encoding")
- cType <- readHeader itr (C8.pack "Content-Type")
+ cType <- readHeader (C8.pack "Content-Type")
when (cType == Nothing)
- $ updateRes itr $ setHeader (C8.pack "Content-Type") defaultPageContentType
+ $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType
if canHaveBody then
when (reqVer == HttpVersion 1 1)
- $ do updateRes itr $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
+ $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked")
writeItr itr itrWillChunkBody True
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
when (reqMethod req /= HEAD)
- $ do updateRes itr $! deleteHeader (C8.pack "Content-Type")
- updateRes itr $! deleteHeader (C8.pack "Etag")
- updateRes itr $! deleteHeader (C8.pack "Last-Modified")
+ $ do updateRes $! deleteHeader (C8.pack "Content-Type")
+ updateRes $! deleteHeader (C8.pack "Etag")
+ updateRes $! deleteHeader (C8.pack "Last-Modified")
- conn <- readHeader itr (C8.pack "Connection")
+ conn <- readHeader (C8.pack "Connection")
case conn of
Nothing -> return ()
Just value -> if value `noCaseEq` C8.pack "close" then
willClose <- readItr itr itrWillClose id
when willClose
- $ updateRes itr $! setHeader (C8.pack "Connection") (C8.pack "close")
+ $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close")
when (reqMethod req == HEAD || not canHaveBody)
$ writeTVar (itrWillDiscardBody itr) True
- readHeader :: Interaction -> ByteString -> STM (Maybe ByteString)
- readHeader itr name
- = itr `seq` name `seq`
+ readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString)
+ readHeader name
+ = name `seq`
readItr itr itrResponse $ getHeader name
- updateRes :: Interaction -> (Response -> Response) -> STM ()
- updateRes itr updator
- = itr `seq` updator `seq`
+ updateRes :: (Response -> Response) -> STM ()
+ updateRes updator
+ = updator `seq`
updateItr itr itrResponse updator
= conf `seq` res `seq`
return res >>= compServer >>= compDate >>= return
where
- compServer res
- = case getHeader (C8.pack "Server") res of
- Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res
- Just _ -> return res
+ compServer res'
+ = case getHeader (C8.pack "Server") res' of
+ Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res'
+ Just _ -> return res'
- compDate res
- = case getHeader (C8.pack "Date") res of
+ compDate res'
+ = case getHeader (C8.pack "Date") res' of
Nothing -> do date <- getCurrentDate
- return $ setHeader (C8.pack "Date") date res
- Just _ -> return res
+ return $ setHeader (C8.pack "Date") date res'
+ Just _ -> return res'
-cache :: IORef (ClockTime, ByteString)
+cache :: IORef (UTCTime, Strict.ByteString)
cache = unsafePerformIO $
- newIORef (TOD 0 0, undefined)
+ newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined)
{-# NOINLINE cache #-}
-getCurrentDate :: IO ByteString
-getCurrentDate = do now@(TOD curSec _) <- getClockTime
- (TOD cachedSec _, cachedStr) <- readIORef cache
+getCurrentDate :: IO Strict.ByteString
+getCurrentDate = do now <- getCurrentTime
+ (cachedTime, cachedStr) <- readIORef cache
- if curSec == cachedSec then
+ if now `mostlyEq` cachedTime then
return cachedStr
else
do let dateStr = C8.pack $ formatHTTPDateTime now
writeIORef cache (now, dateStr)
- return dateStr
\ No newline at end of file
+ return dateStr
+ where
+ mostlyEq :: UTCTime -> UTCTime -> Bool
+ mostlyEq a b
+ = if utctDay a == utctDay b then
+ fromEnum (utctDayTime a) == fromEnum (utctDayTime b)
+ else
+ False
import Control.Concurrent.STM
import Control.Monad
-import Data.ByteString.Base (ByteString)
-import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Char
import Data.Maybe
import Network.HTTP.Lucu.Config
PUT -> writeItr itr itrRequestHasBody True
_ -> setStatus NotImplemented
- preprocessHeader itr req
+ preprocessHeader req
where
setStatus :: StatusCode -> STM ()
setStatus status
do let conf = itrConfig itr
host = cnfServerHost conf
port = case cnfServerPort conf of
- PortNumber n -> Just $ fromIntegral n
+ PortNumber n -> Just (fromIntegral n :: Int)
_ -> Nothing
portStr
= case port of
Nothing -> setStatus BadRequest
- parseHost :: ByteString -> (ByteString, ByteString)
+ parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
parseHost = C8.break (== ':')
- updateAuthority :: ByteString -> ByteString -> STM ()
+ updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
updateAuthority host portStr
= host `seq` portStr `seq`
updateItr itr itrRequest
}
- preprocessHeader :: Interaction -> Request -> STM ()
- preprocessHeader itr req
- = itr `seq` req `seq`
+ preprocessHeader :: Request -> STM ()
+ preprocessHeader req
+ = req `seq`
do case getHeader (C8.pack "Expect") req of
Nothing -> return ()
Just value -> if value `noCaseEq` C8.pack "100-continue" then
where
import Control.Monad
-import Data.ByteString.Base (LazyByteString)
+import Data.Time
+import Data.Time.Calendar.WeekDate
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Parser
-import System.Time
+import Prelude hiding (min)
-month :: [String]
-month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
-week :: [String]
-week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+monthStr :: [String]
+monthStr = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+
+weekStr :: [String]
+weekStr = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
-- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time
-- string.
-formatRFC1123DateTime :: CalendarTime -> String
-formatRFC1123DateTime time
- = time `seq`
-
- id (week !! fromEnum (ctWDay time))
- ++ ", " ++
- fmtDec 2 (ctDay time)
- ++ " " ++
- id (month !! fromEnum (ctMonth time))
- ++ " " ++
- fmtDec 4 (ctYear time)
- ++ " " ++
- fmtDec 2 (ctHour time)
- ++ ":" ++
- fmtDec 2 (ctMin time)
- ++ ":" ++
- fmtDec 2 (ctSec time)
- ++ " " ++
- id (ctTZName time)
+formatRFC1123DateTime :: ZonedTime -> String
+formatRFC1123DateTime zonedTime
+ = let localTime = zonedTimeToLocalTime zonedTime
+ timeZone = zonedTimeZone zonedTime
+ (year, month, day) = toGregorian (localDay localTime)
+ (_, _, week) = toWeekDate (localDay localTime)
+ timeOfDay = localTimeOfDay localTime
+ in
+ id (weekStr !! (week - 1))
+ ++ ", " ++
+ fmtDec 2 day
+ ++ " " ++
+ id (monthStr !! (month - 1))
+ ++ " " ++
+ fmtDec 4 (fromInteger year)
+ ++ " " ++
+ fmtDec 2 (todHour timeOfDay)
+ ++ ":" ++
+ fmtDec 2 (todMin timeOfDay)
+ ++ ":" ++
+ fmtDec 2 (floor (todSec timeOfDay))
+ ++ " " ++
+ id (timeZoneName timeZone)
-- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone
-- will be always UTC but prints as GMT.
-formatHTTPDateTime :: ClockTime -> String
-formatHTTPDateTime time
- = time `seq`
- formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time
+formatHTTPDateTime :: UTCTime -> String
+formatHTTPDateTime utcTime
+ = let timeZone = TimeZone 0 False "GMT"
+ zonedTime = utcToZonedTime timeZone utcTime
+ in
+ formatRFC1123DateTime zonedTime
+
-- |Parse an HTTP Date and Time.
--
-- ...but currently this function only supports the RFC 1123
-- format. This is a violation of RFC 2616 so this should be fixed
-- later. What a bother!
-parseHTTPDateTime :: LazyByteString -> Maybe ClockTime
+parseHTTPDateTime :: Lazy.ByteString -> Maybe UTCTime
parseHTTPDateTime src
= case parse httpDateTime src of
(# Success ct, _ #) -> Just ct
(# _ , _ #) -> Nothing
-httpDateTime :: Parser ClockTime
-httpDateTime = do foldl (<|>) failP (map string week)
+httpDateTime :: Parser UTCTime
+httpDateTime = do foldl (<|>) failP (map string weekStr)
char ','
char ' '
day <- liftM read (count 2 digit)
char ' '
- mon <- foldl (<|>) failP (map tryEqToFst (zip month [1..]))
+ mon <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..]))
char ' '
year <- liftM read (count 4 digit)
char ' '
char ':'
min <- liftM read (count 2 digit)
char ':'
- sec <- liftM read (count 2 digit)
+ sec <- liftM read (count 2 digit) :: Parser Int
char ' '
string "GMT"
eof
- return $ toClockTime $ CalendarTime {
- ctYear = year
- , ctMonth = toEnum (mon - 1)
- , ctDay = day
- , ctHour = hour
- , ctMin = min
- , ctSec = sec
- , ctPicosec = 0
- , ctTZ = 0
- , ctWDay = undefined
- , ctYDay = undefined
- , ctTZName = undefined
- , ctIsDST = undefined
- }
+ let julianDay = fromGregorian year mon day
+ timeOfDay = TimeOfDay hour min (fromIntegral sec)
+ utcTime = UTCTime julianDay (timeOfDayToTime timeOfDay)
+ return utcTime
where
tryEqToFst :: (String, a) -> Parser a
tryEqToFst (str, a) = string str >> return a
import Control.Concurrent.STM
import Control.Monad.Reader
import Data.Bits
-import Data.ByteString.Base (ByteString, LazyByteString(..))
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import Data.Char
import Data.List
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ContentCoding
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
-import Network.Socket
-import Network.URI
-import System.Time
+import Network.Socket hiding (accept)
+import Network.URI hiding (path)
-- |The 'Resource' monad. This monad implements
-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
getRemoteAddr' = do addr <- getRemoteAddr
case addr of
-- Network.Socket は IPv6 を考慮してゐないやうだ…
- (SockAddrInet _ v4addr)
+ SockAddrInet _ v4addr
-> let b1 = (v4addr `shiftR` 24) .&. 0xFF
b2 = (v4addr `shiftR` 16) .&. 0xFF
b3 = (v4addr `shiftR` 8) .&. 0xFF
b4 = v4addr .&. 0xFF
in
return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]
- (SockAddrUnix path)
+ SockAddrUnix path
-> return path
+ _
+ -> undefined
-- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
-- greedy. See 'getResourcePath'.
getPathInfo :: Resource [String]
getPathInfo = do rsrcPath <- getResourcePath
- reqURI <- getRequestURI
- let reqPathStr = uriPath reqURI
+ uri <- getRequestURI
+ let reqPathStr = uriPath uri
reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
-- rsrcPath と reqPath の共通する先頭部分を reqPath か
-- ら全部取り除くと、それは PATH_INFO のやうなものにな
-- application\/x-www-form-urlencoded, and parse it. This action
-- doesn't parse the request body. See 'inputForm'.
getQueryForm :: Resource [(String, String)]
-getQueryForm = do reqURI <- getRequestURI
- return $! parseWWWFormURLEncoded $ uriQuery reqURI
+getQueryForm = do uri <- getRequestURI
+ return $! parseWWWFormURLEncoded $ uriQuery uri
-- |Get a value of given request header. Comparison of header name is
-- case-insensitive. Note that this action is not intended to be used
-- so frequently: there should be actions like 'getContentType' for
-- every common headers.
-getHeader :: ByteString -> Resource (Maybe ByteString)
+getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
getHeader name = name `seq`
do req <- getRequest
return $! H.getHeader name req
Nothing
-> return []
Just accept
- -> case parse mimeTypeListP (LPS [accept]) of
+ -> case parse mimeTypeListP (L8.fromChunks [accept]) of
(# Success xs, _ #) -> return xs
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Accept: " ++ C8.unpack accept)
case ver of
HttpVersion 1 0 -> return [("identity", Nothing)]
HttpVersion 1 1 -> return [("*" , Nothing)]
+ _ -> undefined
Just value
-> if C8.null value then
-- identity のみが許される。
return [("identity", Nothing)]
else
- case parse acceptEncodingListP (LPS [value]) of
+ case parse acceptEncodingListP (L8.fromChunks [value]) of
(# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
Nothing
-> return Nothing
Just cType
- -> case parse mimeTypeP (LPS [cType]) of
+ -> case parse mimeTypeP (L8.fromChunks [cType]) of
(# Success t, _ #) -> return $ Just t
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
--
-- If this is a GET or HEAD request, 'foundEntity' automatically puts
-- \"ETag\" and \"Last-Modified\" headers into the response.
-foundEntity :: ETag -> ClockTime -> Resource ()
+foundEntity :: ETag -> UTCTime -> Resource ()
foundEntity tag timeStamp
= tag `seq` timeStamp `seq`
do driftTo ExaminingRequest
Just value -> if value == C8.pack "*" then
return ()
else
- case parse eTagListP (LPS [value]) of
+ case parse eTagListP (L8.fromChunks [value]) of
(# Success tags, _ #)
-- tags の中に一致するものが無ければ
-- PreconditionFailed で終了。
Just value -> if value == C8.pack "*" then
abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
else
- case parse eTagListP (LPS [value]) of
+ case parse eTagListP (L8.fromChunks [value]) of
(# Success tags, _ #)
-> when (any (== tag) tags)
$ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
--
-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
-foundTimeStamp :: ClockTime -> Resource ()
+foundTimeStamp :: UTCTime -> Resource ()
foundTimeStamp timeStamp
= timeStamp `seq`
do driftTo ExaminingRequest
-- If-Modified-Since があればそれを見る。
ifModSince <- getHeader (C8.pack "If-Modified-Since")
case ifModSince of
- Just str -> case parseHTTPDateTime (LPS [str]) of
+ Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
Just lastTime
-> when (timeStamp <= lastTime)
$ abort statusForIfModSince []
-- If-Unmodified-Since があればそれを見る。
ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
case ifUnmodSince of
- Just str -> case parseHTTPDateTime (LPS [str]) of
+ Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of
Just lastTime
-> when (timeStamp > lastTime)
$ abort PreconditionFailed []
-- | This is mostly the same as 'input' but is more
--- efficient. 'inputLBS' returns a
--- 'Data.ByteString.Base.LazyByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
--- 'inputLBS', not at the evaluation of the
--- 'Data.ByteString.Base.LazyByteString'. The same goes for
+-- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString'
+-- but it's not really lazy: reading from the socket just happens at
+-- the computation of 'inputLBS', not at the evaluation of the
+-- 'Data.ByteString.Lazy.ByteString'. The same goes for
-- 'inputChunkLBS'.
-inputLBS :: Int -> Resource LazyByteString
+inputLBS :: Int -> Resource Lazy.ByteString
inputLBS limit
= limit `seq`
do driftTo GettingBody
return L8.empty
return chunk
where
- askForInput :: Interaction -> Resource LazyByteString
+ askForInput :: Interaction -> Resource Lazy.ByteString
askForInput itr
= itr `seq`
- do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit <= 0 then
- defaultLimit
- else
- limit
+ do let confLimit = cnfMaxEntityLength $ itrConfig itr
+ actualLimit = if limit <= 0 then
+ confLimit
+ else
+ limit
when (actualLimit <= 0)
$ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
-- | This is mostly the same as 'inputChunk' but is more
-- efficient. See 'inputLBS'.
-inputChunkLBS :: Int -> Resource LazyByteString
+inputChunkLBS :: Int -> Resource Lazy.ByteString
inputChunkLBS limit
= limit `seq`
do driftTo GettingBody
return L8.empty
return chunk
where
- askForInput :: Interaction -> Resource LazyByteString
+ askForInput :: Interaction -> Resource Lazy.ByteString
askForInput itr
= itr `seq`
- do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
- actualLimit = if limit < 0 then
- defaultLimit
+ do let confLimit = cnfMaxEntityLength $! itrConfig itr
+ actualLimit = if limit < 0 then
+ confLimit
else
limit
when (actualLimit <= 0)
-- 20 bytes long. In this case the client shall only accept the first
-- 10 bytes of response body and thinks that the residual 10 bytes is
-- a part of header of the next response.
-setHeader :: ByteString -> ByteString -> Resource ()
+setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
setHeader name value
= name `seq` value `seq`
driftTo DecidingHeader >> setHeader' name value
-setHeader' :: ByteString -> ByteString -> Resource ()
+setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
setHeader' name value
= name `seq` value `seq`
do itr <- getInteraction
let tr = case ver of
HttpVersion 1 0 -> unnormalizeCoding
HttpVersion 1 1 -> id
+ _ -> undefined
setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
{-# INLINE output #-}
-- | This is mostly the same as 'output' but is more efficient.
-outputLBS :: LazyByteString -> Resource ()
+outputLBS :: Lazy.ByteString -> Resource ()
outputLBS str = do outputChunkLBS str
driftTo Done
{-# INLINE outputLBS #-}
{-# INLINE outputChunk #-}
-- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkLBS :: LazyByteString -> Resource ()
-outputChunkLBS str
- = str `seq`
+outputChunkLBS :: Lazy.ByteString -> Resource ()
+outputChunkLBS wholeChunk
+ = wholeChunk `seq`
do driftTo DecidingBody
itr <- getInteraction
readItr itr itrWillDiscardBody id
unless (discardBody)
- $ sendChunks str limit
+ $ sendChunks wholeChunk limit
- unless (L8.null str)
+ unless (L8.null wholeChunk)
$ liftIO $ atomically $
writeItr itr itrBodyIsNull False
where
-- チャンクの大きさは Config で制限されてゐる。もし例へば
- -- "/dev/zero" を L8.readFile して作った LazyByteString をそのまま
+ -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
-- ResponseWriter に渡したりすると大變な事が起こる。何故なら
-- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
-- く爲にチャンクの大きさを測る。
- sendChunks :: LazyByteString -> Int -> Resource ()
+ sendChunks :: Lazy.ByteString -> Int -> Resource ()
sendChunks str limit
| L8.null str = return ()
| otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Utils
-import Network.URI
+import Network.URI hiding (path)
import System.IO
import System.IO.Error hiding (catch)
import Prelude hiding (catch)
-- ]
-- @
mkResTree :: [ ([String], ResourceDef) ] -> ResTree
-mkResTree list = list `seq` processRoot list
+mkResTree xs = xs `seq` processRoot xs
where
processRoot :: [ ([String], ResourceDef) ] -> ResTree
processRoot list
where
walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
- walkTree subtree (name:[]) soFar
- = case M.lookup name subtree of
+ walkTree tree (name:[]) soFar
+ = case M.lookup name tree of
Nothing -> Nothing
Just (ResNode defM _) -> do def <- defM
return (soFar ++ [name], def)
- walkTree subtree (x:xs) soFar
- = case M.lookup x subtree of
+ walkTree tree (x:xs) soFar
+ = case M.lookup x tree of
Nothing -> Nothing
Just (ResNode defM children) -> case defM of
Just (ResourceDef { resIsGreedy = True })
POST -> resPost def
PUT -> resPut def
DELETE -> resDelete def
+ _ -> undefined
notAllowed :: Resource ()
notAllowed = do setStatus MethodNotAllowed
ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg
IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE
DynException dynE -> case fromDynamic dynE of
- Just (abo :: Abortion) -> abo
+ Just (a :: Abortion) -> a
Nothing
-> Abortion InternalServerError emptyHeaders
$ Just $ show exc
)
where
-import Data.ByteString.Base (ByteString)
-import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import Data.Dynamic
import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Headers
-- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
-- representation of @sc@.
-statusCode :: StatusCode -> (# Int, ByteString #)
+statusCode :: StatusCode -> (# Int, Strict.ByteString #)
statusCode Continue = (# 100, C8.pack "Continue" #)
statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #)
= {-# SCC "awaitSomethingToWrite" #-}
do action
<- atomically $!
- do -- キューが空でなくなるまで待つ
- queue <- readTVar tQueue
- when (S.null queue)
- retry
-
+ -- キューが空でなくなるまで待つ
+ do queue <- readTVar tQueue
-- GettingBody 状態にあり、Continue が期待され
-- てゐて、それがまだ送信前なのであれば、
-- Continue を送信する。
case S.viewr queue of
+ EmptyR -> retry
_ :> itr -> do state <- readItr itr itrState id
if state == GettingBody then
do queue <- readTVar tQueue
case S.viewr queue of
+ EmptyR -> return () -- this should never happen
remaining :> _ -> writeTVar tQueue remaining
readItr itr itrWillClose id
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Lazy.Char8 as B
+import Data.Time.Clock.POSIX
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
-import System.Directory
import System.Posix.Files
handleStaticFile :: FilePath -> Resource ()
handleStaticFile path
= path `seq`
- do isFile <- liftIO $ doesFileExist path
- if isFile then
+ do exists <- liftIO $ fileExist path
+ if exists then
-- 存在はした。讀めるかどうかは知らない。
- do readable <- liftIO $ fileAccess path True False False
- unless readable
+ do stat <- liftIO $ getFileStatus path
+ if isRegularFile stat then
+ do readable <- liftIO $ fileAccess path True False False
+ unless readable
-- 讀めない
$ abort Forbidden [] Nothing
+ -- 讀める
+ tag <- liftIO $ generateETagFromFile path
+ lastMod <- return $ posixSecondsToUTCTime $ toEnum $ fromEnum $ modificationTime stat
+ foundEntity tag lastMod
- -- 讀める
- tag <- liftIO $ generateETagFromFile path
- lastMod <- liftIO $ getModificationTime path
- foundEntity tag lastMod
+ -- MIME Type を推定
+ conf <- getConfig
+ case guessTypeByFileName (cnfExtToMIMEType conf) path of
+ Nothing -> return ()
+ Just mime -> setContentType mime
- -- MIME Type を推定
- conf <- getConfig
- case guessTypeByFileName (cnfExtToMIMEType conf) path of
- Nothing -> return ()
- Just mime -> setContentType mime
-
- -- 實際にファイルを讀んで送る
- (liftIO $ B.readFile path) >>= outputLBS
- else
- do isDir <- liftIO $ doesDirectoryExist path
- if isDir then
- abort Forbidden [] Nothing
+ -- 實際にファイルを讀んで送る
+ (liftIO $ B.readFile path) >>= outputLBS
else
- foundNoEntity Nothing
+ abort Forbidden [] Nothing
+ else
+ foundNoEntity Nothing
+
-- |Computation of @'generateETagFromFile' fpath@ generates a strong
-- entity tag from a file. The file doesn't necessarily have to be a
)
where
-import Data.Char
-import Data.List
+import Data.List hiding (last)
import Network.URI
+import Prelude hiding (last)
-- |> splitBy (== ':') "ab:c:def"
-- > ==> ["ab", "c", "def"]
splitBy :: (a -> Bool) -> [a] -> [[a]]
-splitBy isSeparator src
- = isSeparator `seq`
- case break isSeparator src
- of (last , [] ) -> last : []
- (first, sep:rest) -> first : splitBy isSeparator rest
+splitBy isSep src
+ = case break isSep src
+ of (last , [] ) -> last : []
+ (first, _sep:rest) -> first : splitBy isSep rest
-- |> joinWith ":" ["ab", "c", "def"]
-- > ==> "ab:c:def"
return ( unEscapeString key
, unEscapeString $ case value of
('=':val) -> val
- "" -> ""
+ val -> val
)
projects / Lucu.git / commitdiff