^dist($|/)
^run\.sh$
^Setup$
+^\.setup-config$
+^.installed-pkg-config$
Stability: experimental
Homepage: http://ccm.sherry.jp/lucu/
Category: Network
-Tested-With: GHC == 6.6
+Tested-With: GHC == 6.6.1
Build-Depends:
base, mtl, network, stm, hxt, haskell-src, unix
Exposed-Modules:
Network.HTTP.Lucu.Config
Network.HTTP.Lucu.DefaultPage
Network.HTTP.Lucu.ETag
+ Network.HTTP.Lucu.Format
Network.HTTP.Lucu.Headers
Network.HTTP.Lucu.HttpVersion
Network.HTTP.Lucu.Httpd
data/mime.types
examples/HelloWorld.hs
examples/Makefile
-ghc-options: -fglasgow-exts -O3
+ghc-options: -fglasgow-exts -fwarn-missing-signatures -funbox-strict-fields -O3
--Executable: HelloWorld
--Main-Is: HelloWorld.hs
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import {-# SOURCE #-} Network.HTTP.Lucu.Resource
import System.IO.Unsafe
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
data Abortion = Abortion {
- aboStatus :: StatusCode
- , aboHeaders :: Headers
- , aboMessage :: Maybe String
+ aboStatus :: !StatusCode
+ , aboHeaders :: !Headers
+ , aboMessage :: !(Maybe String)
} deriving (Show, Typeable)
-- | Computation of @'abort' status headers msg@ aborts the
-- > (Just "It has been moved to example.net")
abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
abort status headers msg
- = let abo = Abortion status headers msg
+ = status `seq` headers `seq` msg `seq`
+ let abo = Abortion status headers msg
exc = DynException (toDyn abo)
in
liftIO $ throwIO exc
+{-# SPECIALIZE abort :: StatusCode -> [ (String, String) ] -> Maybe String -> Resource a #-}
-- | Computation of @'abortSTM' status headers msg@ just computes
-- 'abort' in a STM monad.
abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a
abortSTM status headers msg
- = unsafeIOToSTM $ abort status headers msg
+ = status `seq` headers `seq` msg `seq`
+ unsafeIOToSTM $! abort status headers msg
-- | Computation of @'abortA' -< (status, (headers, msg))@ just
-- computes 'abort' in an ArrowIO.
abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
abortA
= arrIO3 abort
-
+{-# SPECIALIZE abortA :: IOSArrow (StatusCode, ([ (String, String) ], Maybe String)) c #-}
-- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
-- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
-- ければならない。
abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
abortPage conf reqM res abo
- = case aboMessage abo of
+ = conf `seq` reqM `seq` res `seq` abo `seq`
+ case aboMessage abo of
Just msg
-> let [html] = unsafePerformIO
$ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
char '='
token <|> quotedStr
return ()
+{-# SPECIALIZE chunkHeaderP :: Parser Int #-}
chunkFooterP :: Parser ()
-- '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 :: String
+ cnfServerSoftware :: !String
-- |The host name of the server. This value will be used in
-- built-in pages like \"404 Not Found\".
- , cnfServerHost :: HostName
+ , cnfServerHost :: !HostName
-- |A port ID to listen to HTTP clients.
- , cnfServerPort :: PortID
+ , cnfServerPort :: !PortID
-- |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
-- Type of static files. Note that MIME Types are currently
-- a 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
}
-- |The default configuration. Generally you can use this value as-is,
import Data.Maybe
import Network
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
import System.IO.Unsafe
-import Text.Printf
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
getDefaultPage :: Config -> Maybe Request -> Response -> String
getDefaultPage conf req res
- = let msgA = getMsg req res
+ = conf `seq` req `seq` res `seq`
+ let msgA = getMsg req res
in
unsafePerformIO $
do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
writeDefaultPage :: Interaction -> STM ()
writeDefaultPage itr
- = do wroteHeader <- readTVar (itrWroteHeader itr)
+ = itr `seq`
+ do wroteHeader <- readTVar (itrWroteHeader itr)
-- Content-Type が正しくなければ補完できない。
res <- readItr itr itrResponse id
mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
mkDefaultPage conf status msgA
- = let (sCode, sMsg) = statusCode status
+ = conf `seq` status `seq` msgA `seq`
+ let (sCode, sMsg) = statusCode status
sig = cnfServerSoftware conf
++ " at "
++ cnfServerHost conf
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (printf "%03d %s" sCode sMsg)
+ += txt (fmtDec 3 sCode ++ " " ++ sMsg)
))
+= ( eelem "body"
+= ( eelem "h1"
+= ( 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 req res
- = case resStatus res of
+ = req `seq` res `seq`
+ case resStatus res of
-- 1xx は body を持たない
-- 2xx の body は補完しない
-- 3xx
MovedPermanently
- -> txt (printf "The resource at %s has been moved to " path)
+ -> txt ("The resource at " ++ path ++ " has been moved to ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt " permanently."
Found
- -> txt (printf "The resource at %s is currently located at " path)
+ -> 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 (printf "The resource at %s can be found at " path)
+ -> txt ("The resource at " ++ path ++ " can be found at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt "."
TemporaryRedirect
- -> txt (printf "The resource at %s is temporarily located at " path)
+ -> txt ("The resource at " ++ path ++ " is temporarily located at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
-> txt "The server could not understand the request you sent."
Unauthorized
- -> txt (printf "You need a valid authentication to access %s" path)
+ -> txt ("You need a valid authentication to access " ++ path)
Forbidden
- -> txt (printf "You don't have permission to access %s" path)
+ -> txt ("You don't have permission to access " ++ path)
NotFound
- -> txt (printf "The requested URL %s was not found on this server." path)
+ -> txt ("The requested URL " ++ path ++ " was not found on this server.")
Gone
- -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
+ -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
RequestEntityTooLarge
- -> txt (printf "The request entity you sent for %s was too big to accept." path)
+ -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
RequestURITooLarge
-> txt "The request URI you sent was too big to accept."
-- 5xx
InternalServerError
- -> txt (printf "An internal server error has occured during the process of your request to %s" 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."
where
path :: String
- path = let uri = reqURI $ fromJust req
+ path = let uri = reqURI $! fromJust req
in
uriPath uri
loc :: String
- loc = fromJust $ getHeader "Location" res
+ loc = fromJust $! getHeader "Location" res
+
+{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file
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
+ , etagToken :: !String
} deriving (Eq)
instance Show ETag where
eTagListP :: Parser [ETag]
eTagListP = allowEOF
- $ do xs <- listOf eTagP
- when (null xs)
- $ fail ""
- return xs
+ $! do xs <- listOf eTagP
+ when (null xs)
+ $ fail ""
+ return xs
--- /dev/null
+-- #hide
+
+-- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの
+-- で駄目だが、それ以外のモジュールを探しても見付からなかった。
+
+module Network.HTTP.Lucu.Format
+ ( fmtInt
+
+ , fmtDec
+ , 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
+ in
+ sign ++ padded
+ where
+ fmt' :: Int -> String
+ fmt' n
+ | n < base = (intToChar upperCase n) : []
+ | otherwise = (intToChar upperCase $! n `mod` base) : fmt' (n `div` base)
+
+
+fmtDec :: Int -> Int -> String
+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 #-}
+
+
+fmtDec2 :: Int -> String
+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
+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
+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'
\ No newline at end of file
getHeader :: String -> a -> Maybe String
getHeader key a
- = fmap snd $ find (noCaseEq key . fst) (getHeaders a)
+ = key `seq` a `seq`
+ fmap snd $ find (noCaseEq' key . fst) (getHeaders a)
deleteHeader :: String -> a -> a
deleteHeader key a
- = setHeaders a $ filter (not . noCaseEq key . fst) (getHeaders a)
+ = key `seq` a `seq`
+ setHeaders a $ filter (not . noCaseEq' key . fst) (getHeaders a)
addHeader :: String -> String -> a -> a
addHeader key val a
- = setHeaders a $ (getHeaders a) ++ [(key, val)]
+ = key `seq` val `seq` a `seq`
+ setHeaders a $ (getHeaders a) ++ [(key, val)]
setHeader :: String -> String -> a -> a
setHeader key val a
- = let list = getHeaders a
- deleted = filter (not . noCaseEq key . fst) list
+ = key `seq` val `seq` a `seq`
+ let list = getHeaders a
+ deleted = filter (not . noCaseEq' key . fst) list
added = deleted ++ [(key, val)]
in
setHeaders a added
hPutHeaders :: Handle -> Headers -> IO ()
-hPutHeaders h hds = mapM_ putH hds >> hPutStr h "\r\n"
+hPutHeaders h hds
+ = h `seq` hds `seq`
+ mapM_ putH hds >> hPutStr h "\r\n"
where
- putH (name, value) = do hPutStr h name
- hPutStr h ": "
- hPutStr h value
- hPutStr h "\r\n"
+ putH :: (String, String) -> IO ()
+ putH (name, value)
+ = name `seq` value `seq`
+ do hPutStr h name
+ hPutStr h ": "
+ hPutStr h value
+ hPutStr h "\r\n"
import System.IO
-- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\".
-data HttpVersion = HttpVersion Int Int
+data HttpVersion = HttpVersion !Int !Int
deriving (Eq)
instance Show HttpVersion where
hPutHttpVersion :: Handle -> HttpVersion -> IO ()
hPutHttpVersion h (HttpVersion maj min)
- = do hPutStr h "HTTP/"
+ = h `seq`
+ do hPutStr h "HTTP/"
hPutStr h (show maj)
hPutChar h '.'
hPutStr h (show min)
\ No newline at end of file
-- > }
runHttpd :: Config -> ResTree -> IO ()
runHttpd cnf tree
- = withSocketsDo $
+ = cnf `seq` tree `seq`
+ withSocketsDo $
do installHandler sigPIPE Ignore Nothing
so <- listenOn (cnfServerPort cnf)
loop so
loop so
-- 本當は Network.accept を使ひたいが、このアクションは勝手に
-- リモートのIPを逆引きするので、使へない。
- = do (h, addr) <- accept' so
+ = so `seq`
+ do (h, addr) <- accept' so
tQueue <- newInteractionQueue
readerTID <- forkIO $ requestReader cnf tree h addr tQueue
writerTID <- forkIO $ responseWriter cnf h tQueue readerTID
accept' :: Socket -> IO (Handle, So.SockAddr)
accept' soSelf
- = do (soPeer, addr) <- So.accept soSelf
+ = soSelf `seq`
+ do (soPeer, addr) <- So.accept soSelf
hPeer <- So.socketToHandle soPeer ReadWriteMode
return (hPeer, addr)
import Network.HTTP.Lucu.Response
data Interaction = Interaction {
- itrConfig :: Config
- , itrRemoteAddr :: SockAddr
- , itrResourcePath :: Maybe [String]
- , itrRequest :: TVar (Maybe Request)
- , itrResponse :: TVar Response
+ itrConfig :: !Config
+ , itrRemoteAddr :: !SockAddr
+ , itrResourcePath :: !(Maybe [String])
+ , itrRequest :: !(TVar (Maybe Request))
+ , itrResponse :: !(TVar Response)
-- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
-- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
-- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
-- からにすべき。
- , itrRequestHasBody :: TVar Bool
- , itrRequestIsChunked :: TVar Bool
- , itrExpectedContinue :: TVar Bool
+ , 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 ByteString -- Resource が受領した部分は削除される
+ , itrReqChunkLength :: !(TVar (Maybe Int))
+ , itrReqChunkRemaining :: !(TVar (Maybe Int))
+ , itrReqChunkIsOver :: !(TVar Bool)
+ , itrReqBodyWanted :: !(TVar (Maybe Int))
+ , itrReqBodyWasteAll :: !(TVar Bool)
+ , itrReceivedBody :: !(TVar ByteString) -- Resource が受領した部分は削除される
- , itrWillReceiveBody :: TVar Bool
- , itrWillChunkBody :: TVar Bool
- , itrWillDiscardBody :: TVar Bool
- , itrWillClose :: TVar Bool
+ , itrWillReceiveBody :: !(TVar Bool)
+ , itrWillChunkBody :: !(TVar Bool)
+ , itrWillDiscardBody :: !(TVar Bool)
+ , itrWillClose :: !(TVar Bool)
- , itrBodyToSend :: TVar ByteString
- , itrBodyIsNull :: TVar Bool
+ , itrBodyToSend :: !(TVar ByteString)
+ , itrBodyIsNull :: !(TVar Bool)
- , itrState :: TVar InteractionState
+ , itrState :: !(TVar InteractionState)
- , itrWroteContinue :: TVar Bool
- , itrWroteHeader :: TVar Bool
+ , itrWroteContinue :: !(TVar Bool)
+ , itrWroteHeader :: !(TVar Bool)
}
-- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
newInteraction conf addr req
- = do request <- newTVarIO $ req
+ = conf `seq` addr `seq` req `seq`
+ do request <- newTVarIO $ req
responce <- newTVarIO $ Response {
resVersion = HttpVersion 1 1
, resStatus = Ok
writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
writeItr itr accessor value
- = writeTVar (accessor itr) value
+ = itr `seq` accessor `seq` value `seq`
+ writeTVar (accessor itr) value
readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
readItr itr accessor reader
- = readTVar (accessor itr) >>= return . reader
+ = itr `seq` accessor `seq` reader `seq`
+ readTVar (accessor itr) >>= return . reader
-readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
readItrF itr accessor reader
- = readItr itr accessor (fmap reader)
+ = itr `seq` accessor `seq` reader `seq`
+ 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
+ = itr `seq` accessor `seq` updator `seq`
+ do old <- readItr itr accessor id
writeItr itr accessor (updator old)
-updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
updateItrF itr accessor updator
- = updateItr itr accessor (fmap updator)
+ = itr `seq` accessor `seq` updator `seq`
+ updateItr itr accessor (fmap updator)
+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file
-- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@
-- represents \"major\/minor; name=value\".
data MIMEType = MIMEType {
- mtMajor :: String
- , mtMinor :: String
- , mtParams :: [ (String, String) ]
+ mtMajor :: !String
+ , mtMinor :: !String
+ , mtParams :: ![ (String, String) ]
} deriving (Eq)
-- |This operator appends a @(name, value)@ pair to a MIME Type.
(<:>) :: MIMEType -> (String, String) -> MIMEType
mt@(MIMEType _ _ params) <:> pair
- = mt {
+ = pair `seq`
+ mt {
mtParams = mtParams mt ++ [pair]
}
mimeTypeP :: Parser MIMEType
-mimeTypeP = allowEOF $
+mimeTypeP = allowEOF $!
do maj <- token
char '/'
min <- token
return (name, value)
mimeTypeListP :: Parser [MIMEType]
-mimeTypeListP = allowEOF $ listOf mimeTypeP
+mimeTypeListP = allowEOF $! listOf mimeTypeP
-- |Guess the MIME Type of file.
guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
guessTypeByFileName extMap fpath
- = let ext = last $ splitBy (== '.') fpath
+ = extMap `seq` fpath `seq`
+ let ext = last $ splitBy (== '.') fpath
in
M.lookup ext extMap >>= return
-- |Read an Apache mime.types and parse it.
parseExtMapFile :: FilePath -> IO ExtMap
parseExtMapFile fpath
- = do file <- B.readFile 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'
import Data.ByteString.Lazy.Char8 (ByteString)
-- |@Parser a@ is obviously a parser which parses and returns @a@.
-data Parser a = Parser {
+newtype Parser a = Parser {
runParser :: State ParserState (ParserResult a)
}
type IsEOFFatal = Bool
-data ParserResult a = Success a
+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@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存
- result <- runParser p
- case result of
- Success a -> runParser (f a)
- IllegalInput -> do put saved -- 状態を復歸
- return IllegalInput
- ReachedEOF -> do unless isEOFFatal
- $ put saved -- 状態を復歸
- return ReachedEOF
- return = Parser . return . Success
- fail _ = Parser $ return IllegalInput
+ p >>= f = Parser $! do saved@(_, isEOFFatal) <- get -- 失敗した時の爲に状態を保存
+ result <- runParser p
+ case result of
+ Success a -> a `seq` runParser (f a)
+ IllegalInput -> do put saved -- 状態を復歸
+ return IllegalInput
+ ReachedEOF -> do unless isEOFFatal
+ $ put saved -- 状態を復歸
+ return ReachedEOF
+ return x = x `seq` Parser $! return $! Success x
+ fail _ = Parser $! return $! IllegalInput
-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
-- remaining)@.
parse :: Parser a -> ByteString -> (ParserResult a, ByteString)
-parse p input = let (result, (input', _)) = runState (runParser p) (input, True)
- in
- (result, input')
+parse p input -- input は lazy である必要有り。
+ = p `seq`
+ let (result, (input', _)) = runState (runParser p) (input, True)
+ in
+ result `seq` (result, input') -- input' も lazy である必要有り。
-- |@'parseStr' p str@ packs @str@ and parses it.
parseStr :: Parser a -> String -> (ParserResult a, ByteString)
-parseStr p input = parse p $ B.pack input
+parseStr p input
+ = p `seq` -- input は lazy である必要有り。
+ parse p $! B.pack input
anyChar :: Parser Char
-anyChar = Parser $ do (input, isEOFFatal) <- get
- if B.null input then
- return ReachedEOF
- else
- do let c = B.head input
- put (B.tail input, isEOFFatal)
- return (Success c)
+anyChar = Parser $!
+ do (input, isEOFFatal) <- get
+ if B.null input then
+ return ReachedEOF
+ else
+ do let c = B.head input
+ put (B.tail input, isEOFFatal)
+ return (Success c)
eof :: Parser ()
-eof = Parser $ do (input, _) <- get
- if B.null input then
- return $ Success ()
- else
- return IllegalInput
+eof = Parser $!
+ do (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 (input, isEOFFatal) <- get
- put (input, False)
+allowEOF f = f `seq`
+ Parser $! do (input, isEOFFatal) <- get
+ put (input, False)
- result <- runParser f
+ result <- runParser f
- (input', _) <- get
- put (input', isEOFFatal)
+ (input', _) <- get
+ put (input', isEOFFatal)
- return result
+ return result
satisfy :: (Char -> Bool) -> Parser Char
-satisfy f = do c <- anyChar
+satisfy f = f `seq`
+ do c <- anyChar
unless (f c) (fail "")
return c
char :: Char -> Parser Char
-char c = satisfy (== c)
+char c = c `seq` satisfy (== c)
string :: String -> Parser String
-string str = do mapM_ char str
+string str = str `seq`
+ do mapM_ char str
return str
-- |This is the backtracking alternation. There is no non-backtracking
-- equivalent.
(<|>) :: Parser a -> Parser a -> Parser a
-f <|> g = Parser $ do saved@(_, isEOFFatal) <- get -- 状態を保存
- result <- runParser f
- case result of
- Success a -> return $ Success a
- IllegalInput -> do put saved -- 状態を復歸
- runParser g
- ReachedEOF -> if isEOFFatal then
- return ReachedEOF
- else
- do put saved
- runParser g
+f <|> g
+ = f `seq` g `seq`
+ Parser $! do saved@(_, isEOFFatal) <- get -- 状態を保存
+ result <- runParser f
+ case result of
+ Success a -> return $ Success a
+ IllegalInput -> do put saved -- 状態を復歸
+ runParser g
+ ReachedEOF -> if isEOFFatal then
+ return ReachedEOF
+ else
+ do put saved
+ runParser g
oneOf :: [Char] -> Parser Char
notFollowedBy :: Parser a -> Parser ()
-notFollowedBy p = p >>= fail "" <|> return ()
+notFollowedBy p = p `seq`
+ p >>= fail "" <|> return ()
digit :: Parser Char
many :: Parser a -> Parser [a]
-many p = do x <- p
+many p = p `seq`
+ do x <- p
xs <- many p
return (x:xs)
<|>
many1 :: Parser a -> Parser [a]
-many1 p = do ret <- many p
+many1 p = p `seq`
+ do ret <- many p
case ret of
[] -> fail ""
xs -> return xs
manyTill :: Parser a -> Parser end -> Parser [a]
-manyTill p end = many $ do x <- p
- end
- return x
+manyTill p end
+ = p `seq` end `seq`
+ many $! do x <- p
+ end
+ return x
many1Till :: Parser a -> Parser end -> Parser [a]
-many1Till p end = many1 $ do x <- p
- end
- return x
+many1Till p end
+ = p `seq` end `seq`
+ many1 $! do x <- p
+ end
+ return x
count :: Int -> Parser a -> Parser [a]
count 0 _ = return []
-count n p = do x <- p
+count n p = n `seq` p `seq`
+ do x <- p
xs <- count (n-1) p
return (x:xs)
-
+-- def may be a _|_
option :: a -> Parser a -> Parser a
-option def p = p <|> return def
+option def p = p `seq`
+ p <|> return def
sepBy :: Parser a -> Parser sep -> Parser [a]
-sepBy p sep = sepBy1 p sep <|> return []
+sepBy p sep = p `seq` sep `seq`
+ sepBy1 p sep <|> return []
sepBy1 :: Parser a -> Parser sep -> Parser [a]
-sepBy1 p sep = do x <- p
- xs <- many $ sep >> p
+sepBy1 p sep = p `seq` sep `seq`
+ do x <- p
+ xs <- many $! sep >> p
return (x:xs)
isCtl c
| c < '\x1f' = True
| c >= '\x7f' = True
- | otherwise = False
+ | otherwise = False
-- |@'isSeparator' c@ is True iff c is one of HTTP separators.
isSeparator :: Char -> Bool
-isSeparator c = elem c "()<>@,;:\\\"/[]?={} \t"
+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
-- |@'isChar' c@ is True iff @c <= 0x7f@.
isChar :: Char -> Bool
-- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
-- c)@
isToken :: Char -> Bool
-isToken c = not (isCtl c || isSeparator c)
+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)
+listOf p = p `seq`
+ 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
+token = many1 $! satisfy isToken
-- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
-- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
postprocess :: Interaction -> STM ()
postprocess itr
- = do reqM <- readItr itr itrRequest id
+ = itr `seq`
+ do reqM <- readItr itr itrRequest id
res <- readItr itr itrResponse id
let sc = resStatus res
where
relyOnRequest :: Interaction -> STM ()
relyOnRequest itr
- = do status <- readItr itr itrResponse resStatus
+ = itr `seq`
+ do status <- readItr itr itrResponse resStatus
req <- readItr itr itrRequest fromJust
let reqVer = reqVersion req
status == ResetContent ||
status == NotModified )
- updateRes itr $ deleteHeader "Content-Length"
- updateRes itr $ deleteHeader "Transfer-Encoding"
+ updateRes itr $! deleteHeader "Content-Length"
+ updateRes itr $! deleteHeader "Transfer-Encoding"
cType <- readHeader itr "Content-Type"
when (cType == Nothing)
if canHaveBody then
when (reqVer == HttpVersion 1 1)
- $ do updateRes itr $ setHeader "Transfer-Encoding" "chunked"
+ $ do updateRes itr $! setHeader "Transfer-Encoding" "chunked"
writeItr itr itrWillChunkBody True
else
-- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す
when (reqMethod req /= HEAD)
- $ do updateRes itr $ deleteHeader "Content-Type"
- updateRes itr $ deleteHeader "Etag"
- updateRes itr $ deleteHeader "Last-Modified"
+ $ do updateRes itr $! deleteHeader "Content-Type"
+ updateRes itr $! deleteHeader "Etag"
+ updateRes itr $! deleteHeader "Last-Modified"
conn <- readHeader itr "Connection"
case fmap (map toLower) conn of
willClose <- readItr itr itrWillClose id
when willClose
- $ updateRes itr $ setHeader "Connection" "close"
+ $ updateRes itr $! setHeader "Connection" "close"
when (reqMethod req == HEAD || not canHaveBody)
$ writeTVar (itrWillDiscardBody itr) True
readHeader :: Interaction -> String -> STM (Maybe String)
readHeader itr name
- = readItr itr itrResponse $ getHeader name
+ = itr `seq` name `seq`
+ readItr itr itrResponse $ getHeader name
updateRes :: Interaction -> (Response -> Response) -> STM ()
updateRes itr updator
- = updateItr itr itrResponse updator
+ = itr `seq` updator `seq`
+ updateItr itr itrResponse updator
completeUnconditionalHeaders :: Config -> Response -> IO Response
completeUnconditionalHeaders conf res
- = return res >>= compServer >>= compDate >>= return
+ = conf `seq` res `seq`
+ return res >>= compServer >>= compDate >>= return
where
compServer res
= case getHeader "Server" res of
preprocess :: Interaction -> STM ()
preprocess itr
- = do req <- readItr itr itrRequest fromJust
+ = itr `seq`
+ do req <- readItr itr itrRequest fromJust
let reqVer = reqVersion req
where
setStatus :: StatusCode -> STM ()
setStatus status
- = updateItr itr itrResponse
- $ \ res -> res {
- resStatus = status
- }
+ = status `seq`
+ updateItr itr itrResponse
+ $! \ res -> res {
+ resStatus = status
+ }
completeAuthority :: Request -> STM ()
completeAuthority req
- = when (uriAuthority (reqURI req) == Nothing)
+ = req `seq`
+ when (uriAuthority (reqURI req) == Nothing)
$ if reqVersion req == HttpVersion 1 0 then
-- HTTP/1.0 なので Config から補完
do let conf = itrConfig itr
updateAuthority :: String -> String -> STM ()
updateAuthority host portStr
- = updateItr itr itrRequest
- $ \ (Just req) -> Just req {
- reqURI = let uri = reqURI req
- in uri {
- uriAuthority = Just URIAuth {
- uriUserInfo = ""
- , uriRegName = host
- , uriPort = portStr
- }
- }
- }
+ = host `seq` portStr `seq`
+ updateItr itr itrRequest
+ $! \ (Just req) -> Just req {
+ reqURI = let uri = reqURI req
+ in uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = host
+ , uriPort = portStr
+ }
+ }
+ }
+ preprocessHeader :: Interaction -> (String, String) -> STM ()
preprocessHeader itr (name, value)
- = case map toLower name of
+ = itr `seq` name `seq` value `seq`
+ case map toLower name of
"expect"
- -> if value `noCaseEq` "100-continue" then
+ -> if value `noCaseEq'` "100-continue" then
writeItr itr itrExpectedContinue True
else
setStatus ExpectationFailed
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B
import Data.ByteString.Lazy.Char8 (ByteString)
+import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Parser
import System.Time
import System.Locale
-import Text.Printf
-month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
-week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+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"]
-- |Format a @CalendarTime@ to RFC 1123 Date and Time string.
formatRFC1123DateTime :: CalendarTime -> String
formatRFC1123DateTime time
- = printf "%s, %02d %s %04d %02d:%02d:%02d %s"
- (week !! fromEnum (ctWDay time))
- (ctDay time)
- (month !! fromEnum (ctMonth time))
- (ctYear time)
- (ctHour time)
- (ctMin time)
- (ctSec time)
- (ctTZName 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)
+
-- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be
-- always UTC but prints as GMT.
formatHTTPDateTime :: ClockTime -> String
-formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime
+formatHTTPDateTime time
+ = time `seq`
+ formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time
-- |Parse an HTTP Date and Time.
--
| DELETE
| TRACE
| CONNECT
- | ExtensionMethod String
+ | ExtensionMethod !String
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)
requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
requestReader cnf tree h addr tQueue
- = do catch (do input <- B.hGetContents h
+ = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
+ do catch (do input <- B.hGetContents h
acceptRequest input) $ \ exc ->
case exc of
IOException _ -> return ()
-- the httpd.
getConfig :: Resource Config
getConfig = do itr <- ask
- return $ itrConfig itr
+ return $! itrConfig itr
-- |Get the SockAddr of the remote host. If you want a string
-- representation instead of SockAddr, use 'getRemoteAddr''.
getRemoteAddr :: Resource SockAddr
getRemoteAddr = do itr <- ask
- return $ itrRemoteAddr itr
+ return $! itrRemoteAddr itr
-- |Get the string representation of the address of remote host. If
-- the request header. In general you don't have to use this action.
getRequest :: Resource Request
getRequest = do itr <- ask
- req <- liftIO $ atomically $ readItr itr itrRequest fromJust
+ req <- liftIO $! atomically $! readItr itr itrRequest fromJust
return req
-- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
getMethod :: Resource Method
getMethod = do req <- getRequest
- return $ reqMethod req
+ return $! reqMethod req
-- |Get the URI of the request.
getRequestURI :: Resource URI
getRequestURI = do req <- getRequest
- return $ reqURI req
+ return $! reqURI req
-- |Get the path of this 'Resource' (to be exact,
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
-- > }
getResourcePath :: Resource [String]
getResourcePath = do itr <- ask
- return $ fromJust $ itrResourcePath itr
+ return $! fromJust $! itrResourcePath itr
-- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
-- る。rsrcPath は全部一致してゐるに決まってゐる（でな
-- ければこの Resource が撰ばれた筈が無い）ので、
-- rsrcPath の長さの分だけ削除すれば良い。
- return $ drop (length rsrcPath) reqPath
+ return $! drop (length rsrcPath) reqPath
-- | Assume the query part of request URI as
-- 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
+ return $! parseWWWFormURLEncoded $ uriQuery reqURI
-- |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 :: String -> Resource (Maybe String)
-getHeader name = do req <- getRequest
- return $ H.getHeader name req
+getHeader name = name `seq`
+ do req <- getRequest
+ return $! H.getHeader name req
-- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
-- header \"Accept\".
-- \"ETag\" and \"Last-Modified\" headers into the response.
foundEntity :: ETag -> ClockTime -> Resource ()
foundEntity tag timeStamp
- = do driftTo ExaminingRequest
+ = tag `seq` timeStamp `seq`
+ do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+ $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundEntity for POST request.")
-- possible.
foundETag :: ETag -> Resource ()
foundETag tag
- = do driftTo ExaminingRequest
+ = tag `seq`
+ do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "ETag" $ show tag
+ $ setHeader' "ETag" $! show tag
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundETag for POST request.")
-- PreconditionFailed で終了。
-> when (not $ any (== tag) tags)
$ abort PreconditionFailed []
- $ Just ("The entity tag doesn't match: " ++ list)
- _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
+ $! Just ("The entity tag doesn't match: " ++ list)
+ _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
ifNoneMatch <- getHeader "If-None-Match"
case ifNoneMatch of
Nothing -> return ()
- Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
+ Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
Just list -> case parseStr eTagListP list of
(Success tags, _)
-> when (any (== tag) tags)
- $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
- _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
+ $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list)
+ _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list)
driftTo GettingBody
-- possible.
foundTimeStamp :: ClockTime -> Resource ()
foundTimeStamp timeStamp
- = do driftTo ExaminingRequest
+ = timeStamp `seq`
+ do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
- $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
+ $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundTimeStamp for POST request.")
Just lastTime
-> when (timeStamp <= lastTime)
$ abort statusForIfModSince []
- $ Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
Just lastTime
-> when (timeStamp > lastTime)
$ abort PreconditionFailed []
- $ Just ("The entity has not been modified since " ++ str)
+ $! Just ("The entity has not been modified since " ++ str)
Nothing
-> return () -- 不正な時刻は無視
Nothing -> return ()
-- 'foundNoEntity' always aborts with status \"404 Not Found\".
foundNoEntity :: Maybe String -> Resource ()
foundNoEntity msgM
- = do driftTo ExaminingRequest
+ = msgM `seq`
+ do driftTo ExaminingRequest
method <- getMethod
when (method /= PUT)
-- Note that 'inputBS' is more efficient than 'input' so you should
-- use it whenever possible.
input :: Int -> Resource String
-input limit = inputBS limit >>= return . B.unpack
+input limit = limit `seq`
+ inputBS limit >>= return . B.unpack
-- | This is mostly the same as 'input' but is more
-- goes for 'inputChunkBS'.
inputBS :: Int -> Resource ByteString
inputBS limit
- = do driftTo GettingBody
+ = limit `seq`
+ do driftTo GettingBody
itr <- ask
- hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
+ hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
chunk <- if hasBody then
askForInput itr
else
where
askForInput :: Interaction -> Resource ByteString
askForInput itr
- = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+ = itr `seq`
+ do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
actualLimit = if limit <= 0 then
defaultLimit
else
when (actualLimit <= 0)
$ fail ("inputBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
- liftIO $ atomically
- $ do chunkLen <- readItr itr itrReqChunkLength id
- writeItr itr itrWillReceiveBody True
- if fmap (> actualLimit) chunkLen == Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeItr itr itrReqBodyWanted $ Just actualLimit
+ liftIO $! atomically
+ $! do chunkLen <- readItr itr itrReqChunkLength id
+ writeItr itr itrWillReceiveBody True
+ if fmap (> actualLimit) chunkLen == Just True then
+ -- 受信前から多過ぎる事が分かってゐる
+ tooLarge actualLimit
+ else
+ writeItr itr itrReqBodyWanted $ Just actualLimit
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
- $ do chunk <- readItr itr itrReceivedBody id
- chunkIsOver <- readItr itr itrReqChunkIsOver id
- if B.length chunk < fromIntegral actualLimit then
- -- 要求された量に滿たなくて、まだ殘り
- -- があるなら再試行。
- unless chunkIsOver
- $ retry
- else
- -- 制限値一杯まで讀むやうに指示したの
- -- にまだ殘ってゐるなら、それは多過ぎ
- -- る。
- unless chunkIsOver
- $ tooLarge actualLimit
- -- 成功。itr 内にチャンクを置いたままにす
- -- るとメモリの無駄になるので除去。
- writeItr itr itrReceivedBody B.empty
- return chunk
+ chunk <- liftIO $! atomically
+ $! do chunk <- readItr itr itrReceivedBody id
+ chunkIsOver <- readItr itr itrReqChunkIsOver id
+ if B.length chunk < fromIntegral actualLimit then
+ -- 要求された量に滿たなくて、まだ殘り
+ -- があるなら再試行。
+ unless chunkIsOver
+ $ retry
+ else
+ -- 制限値一杯まで讀むやうに指示したの
+ -- にまだ殘ってゐるなら、それは多過ぎ
+ -- る。
+ unless chunkIsOver
+ $ tooLarge actualLimit
+ -- 成功。itr 内にチャンクを置いたままにす
+ -- るとメモリの無駄になるので除去。
+ writeItr itr itrReceivedBody B.empty
+ return chunk
driftTo DecidingHeader
return chunk
tooLarge :: Int -> STM ()
- tooLarge lim = abortSTM RequestEntityTooLarge []
- $ Just ("Request body must be smaller than "
- ++ show lim ++ " bytes.")
+ tooLarge lim = lim `seq`
+ abortSTM RequestEntityTooLarge []
+ $! Just ("Request body must be smaller than "
+ ++ show lim ++ " bytes.")
-- | Computation of @'inputChunk' limit@ attempts to read a part of
-- request body up to @limit@ bytes. You can read any large request by
-- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
-- should use it whenever possible.
inputChunk :: Int -> Resource String
-inputChunk limit = inputChunkBS limit >>= return . B.unpack
+inputChunk limit = limit `seq`
+ inputChunkBS limit >>= return . B.unpack
-- | This is mostly the same as 'inputChunk' but is more
-- efficient. See 'inputBS'.
inputChunkBS :: Int -> Resource ByteString
inputChunkBS limit
- = do driftTo GettingBody
+ = limit `seq`
+ do driftTo GettingBody
itr <- ask
hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
chunk <- if hasBody then
where
askForInput :: Interaction -> Resource ByteString
askForInput itr
- = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
+ = itr `seq`
+ do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
actualLimit = if limit < 0 then
defaultLimit
else
when (actualLimit <= 0)
$ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
- liftIO $ atomically
- $ do writeItr itr itrReqBodyWanted $ Just actualLimit
- writeItr itr itrWillReceiveBody True
+ liftIO $! atomically
+ $! do writeItr itr itrReqBodyWanted $! Just actualLimit
+ writeItr itr itrWillReceiveBody True
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
+ chunk <- liftIO $! atomically
$ do chunk <- readItr itr itrReceivedBody id
-- 要求された量に滿たなくて、まだ殘りがあ
-- るなら再試行。
-- it is not (yet) done.
inputForm :: Int -> Resource [(String, String)]
inputForm limit
- = do cTypeM <- getContentType
+ = limit `seq`
+ do cTypeM <- getContentType
case cTypeM of
Nothing
-> abort BadRequest [] (Just "Missing Content-Type")
Just (MIMEType "multipart" "form-data" _)
-> readMultipartFormData
Just cType
- -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
+ -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "
++ show cType)
where
readWWWFormURLEncoded
readMultipartFormData -- FIXME: 未對應
= abort UnsupportedMediaType []
- (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
+ (Just $! "Sorry, inputForm does not currently support multipart/form-data.")
-- | This is just a constant -1. It's better to say @'input'
-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
-- the status code will be defaulted to \"200 OK\".
setStatus :: StatusCode -> Resource ()
setStatus code
- = do driftTo DecidingHeader
+ = code `seq`
+ do driftTo DecidingHeader
itr <- ask
- liftIO $ atomically $ updateItr itr itrResponse
- $ \ res -> res {
- resStatus = code
- }
+ liftIO $! atomically $! updateItr itr itrResponse
+ $! \ res -> res {
+ resStatus = code
+ }
-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
-- a part of header of the next response.
setHeader :: String -> String -> Resource ()
setHeader name value
- = driftTo DecidingHeader >> setHeader' name value
+ = name `seq` value `seq`
+ driftTo DecidingHeader >> setHeader' name value
-setHeader' :: String -> String -> Resource()
+setHeader' :: String -> String -> Resource ()
setHeader' name value
- = do itr <- ask
+ = name `seq` value `seq`
+ do itr <- ask
liftIO $ atomically
$ updateItr itr itrResponse
$ H.setHeader name value
-- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
redirect :: StatusCode -> URI -> Resource ()
redirect code uri
- = do when (code == NotModified || not (isRedirection code))
+ = code `seq` uri `seq`
+ do when (code == NotModified || not (isRedirection code))
$ abort InternalServerError []
- $ Just ("Attempted to redirect with status " ++ show code)
+ $! Just ("Attempted to redirect with status " ++ show code)
setStatus code
setLocation uri
+{-# INLINE redirect #-}
+
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType :: MIMEType -> Resource ()
setContentType mType
- = setHeader "Content-Type" $ show mType
+ = setHeader "Content-Type" $! show mType
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
-- Note that 'outputBS' is more efficient than 'output' so you should
-- use it whenever possible.
output :: String -> Resource ()
-output = outputBS . B.pack
+output str = outputBS $! B.pack str
+{-# INLINE output #-}
-- | This is mostly the same as 'output' but is more efficient.
outputBS :: ByteString -> Resource ()
outputBS str = do outputChunkBS str
driftTo Done
+{-# INLINE outputBS #-}
-- | Computation of @'outputChunk' str@ writes @str@ as a part of
-- response body. You can compute this action multiple times to write
-- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
-- you should use it whenever possible.
outputChunk :: String -> Resource ()
-outputChunk = outputChunkBS . B.pack
+outputChunk str = outputChunkBS $! B.pack str
+{-# INLINE outputChunk #-}
-- | This is mostly the same as 'outputChunk' but is more efficient.
outputChunkBS :: ByteString -> Resource ()
outputChunkBS str
- = do driftTo DecidingBody
+ = str `seq`
+ do driftTo DecidingBody
itr <- ask
let limit = cnfMaxOutputChunkLength $ itrConfig itr
driftTo :: InteractionState -> Resource ()
driftTo newState
- = do itr <- ask
+ = newState `seq`
+ do itr <- ask
liftIO $ atomically $ do oldState <- readItr itr itrState id
if newState < oldState then
throwStateError oldState newState
--- /dev/null
+{- -*- haskell -*- -}
+module Network.HTTP.Lucu.Resource
+ where
+
+import Control.Monad.Reader
+import Network.HTTP.Lucu.Interaction
+
+type Resource a = ReaderT Interaction IO a
\ No newline at end of file
-- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
-- native thread (spawned using @forkOS@) or to run it on a user
-- thread (spanwed using @forkIO@). Generally you don't
- resUsesNativeThread :: Bool
+ resUsesNativeThread :: !Bool
-- | Whether to be greedy or not.
--
-- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
-- there is another resource at \/aaa\/bbb\/ccc. If the resource
-- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
-- resource is like a CGI script.
- , resIsGreedy :: Bool
+ , resIsGreedy :: !Bool
-- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET
-- request comes for the resource path. If 'resGet' is Nothing,
-- the system responds \"405 Method Not Allowed\" for GET
-- It also runs for HEAD request if the 'resHead' is Nothing. In
-- this case 'Network.HTTP.Lucu.Resource.output' and such like
-- don't actually write a response body.
- , resGet :: Maybe (Resource ())
+ , resGet :: !(Maybe (Resource ()))
-- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD
-- request comes for the resource path. If 'resHead' is Nothing,
-- the system runs 'resGet' instead. If 'resGet' is also Nothing,
-- the system responds \"405 Method Not Allowed\" for HEAD
-- requests.
- , resHead :: Maybe (Resource ())
+ , resHead :: !(Maybe (Resource ()))
-- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST
-- request comes for the resource path. If 'resPost' is Nothing,
-- the system responds \"405 Method Not Allowed\" for POST
-- requests.
- , resPost :: Maybe (Resource ())
+ , resPost :: !(Maybe (Resource ()))
-- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT
-- request comes for the resource path. If 'resPut' is Nothing,
-- the system responds \"405 Method Not Allowed\" for PUT
-- requests.
- , resPut :: Maybe (Resource ())
+ , resPut :: !(Maybe (Resource ()))
-- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a
-- DELETE request comes for the resource path. If 'resDelete' is
-- Nothing, the system responds \"405 Method Not Allowed\" for
-- DELETE requests.
- , resDelete :: Maybe (Resource ())
+ , resDelete :: !(Maybe (Resource ()))
}
-- | 'ResTree' is an opaque structure which is a map from resource
-- path to 'ResourceDef'.
type ResTree = ResNode -- root だから Map ではない
type ResSubtree = Map String ResNode
-data ResNode = ResNode (Maybe ResourceDef) ResSubtree
+data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree
-- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
--
-- ]
-- @
mkResTree :: [ ([String], ResourceDef) ] -> ResTree
-mkResTree list = processRoot list
+mkResTree list = list `seq` processRoot list
where
processRoot :: [ ([String], ResourceDef) ] -> ResTree
processRoot list
runResource :: ResourceDef -> Interaction -> IO ThreadId
runResource def itr
- = fork
- $ catch ( runReaderT ( do req <- getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
- )
- $ \ exc -> processException exc
+ = def `seq` itr `seq`
+ fork
+ $! catch ( runReaderT ( do req <- getRequest
+ fromMaybe notAllowed $ rsrc req
+ driftTo Done
+ ) itr
+ )
+ $ \ exc -> processException exc
where
fork :: IO () -> IO ThreadId
fork = if (resUsesNativeThread def)
where
import Data.Dynamic
+import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import System.IO
-import Text.Printf
-- |This is the definition of HTTP status code.
-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses
instance Show StatusCode where
show sc = let (num, msg) = statusCode sc
in
- printf "%03d %s" num msg
+ (fmtDec 3 num) ++ " " ++ msg
data Response = Response {
- resVersion :: HttpVersion
- , resStatus :: StatusCode
- , resHeaders :: Headers
+ resVersion :: !HttpVersion
+ , resStatus :: !StatusCode
+ , resHeaders :: !Headers
} deriving (Show, Eq)
hPutResponse :: Handle -> Response -> IO ()
-hPutResponse h res = do hPutHttpVersion h (resVersion res)
- hPutChar h ' '
- hPutStatus h (resStatus res)
- hPutStr h "\r\n"
- hPutHeaders h (resHeaders res)
+hPutResponse h res
+ = h `seq` res `seq`
+ do hPutHttpVersion h (resVersion res)
+ hPutChar h ' '
+ hPutStatus h (resStatus res)
+ hPutStr h "\r\n"
+ hPutHeaders h (resHeaders res)
hPutStatus :: Handle -> StatusCode -> IO ()
-hPutStatus h sc = let (num, msg) = statusCode sc
- in
- hPrintf h "%03d %s" num msg
+hPutStatus h sc
+ = h `seq` sc `seq`
+ hPutStr h (show sc)
-- |@'isInformational' sc@ is True iff @sc < 200@.
isInformational :: StatusCode -> Bool
import qualified Data.Sequence as S
import Data.Sequence (Seq, ViewR(..))
import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Prelude hiding (catch)
import System.IO
-import Text.Printf
import Control.Concurrent
import Debug.Trace
responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
responseWriter cnf h tQueue readerTID
- = catch awaitSomethingToWrite $ \ exc ->
+ = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
+ catch awaitSomethingToWrite $ \ exc ->
case exc of
IOException _ -> return ()
AsyncException ThreadKilled -> return ()
awaitSomethingToWrite :: IO ()
awaitSomethingToWrite
= do action
- <- atomically $
+ <- atomically $!
do -- キューが空でなくなるまで待つ
queue <- readTVar tQueue
when (S.null queue)
retry
- let _ :> itr = S.viewr queue
-
+
-- GettingBody 状態にあり、Continue が期待され
-- てゐて、それがまだ送信前なのであれば、
-- Continue を送信する。
- state <- readItr itr itrState id
-
- if state == GettingBody then
- writeContinueIfNecessary itr
- else
- if state >= DecidingBody then
- writeHeaderOrBodyIfNecessary itr
- else
- retry
+ case S.viewr queue of
+ _ :> itr -> do state <- readItr itr itrState id
+
+ if state == GettingBody then
+ writeContinueIfNecessary itr
+ else
+ if state >= DecidingBody then
+ writeHeaderOrBodyIfNecessary itr
+ else
+ retry
action
writeContinueIfNecessary :: Interaction -> STM (IO ())
writeContinueIfNecessary itr
- = do expectedContinue <- readItr itr itrExpectedContinue id
+ = itr `seq`
+ do expectedContinue <- readItr itr itrExpectedContinue id
if expectedContinue then
do wroteContinue <- readItr itr itrWroteContinue id
if wroteContinue then
-- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
-- 空でなければ、それを出力する。空である時は、もし状態が
-- Done であれば後処理をする。
- = do wroteHeader <- readItr itr itrWroteHeader id
+ = itr `seq`
+ do wroteHeader <- readItr itr itrWroteHeader id
if not wroteHeader then
return $ writeHeader itr
do state <- readItr itr itrState id
if state == Done then
- return $ finalize itr
+ return $! finalize itr
else
retry
else
- return $ writeBodyChunk itr
+ return $! writeBodyChunk itr
writeContinue :: Interaction -> IO ()
writeContinue itr
- = do let cont = Response {
+ = itr `seq`
+ do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
, resHeaders = []
cont' <- completeUnconditionalHeaders cnf cont
hPutResponse h cont'
hFlush h
- atomically $ writeItr itr itrWroteContinue True
+ atomically $! writeItr itr itrWroteContinue True
awaitSomethingToWrite
writeHeader :: Interaction -> IO ()
writeHeader itr
- = do res <- atomically $ do writeItr itr itrWroteHeader True
- readItr itr itrResponse id
+ = itr `seq`
+ do res <- atomically $! do writeItr itr itrWroteHeader True
+ readItr itr itrResponse id
hPutResponse h res
hFlush h
awaitSomethingToWrite
writeBodyChunk :: Interaction -> IO ()
writeBodyChunk itr
- = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $ readItr itr itrWillChunkBody id
- chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
- writeItr itr itrBodyToSend B.empty
- return chunk
+ = itr `seq`
+ do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
+ willChunkBody <- atomically $! readItr itr itrWillChunkBody id
+ chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
+ writeItr itr itrBodyToSend B.empty
+ return chunk
unless willDiscardBody
$ do if willChunkBody then
- do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
+ do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
+ hPutStr h "\r\n"
B.hPut h chunk
hPutStr h "\r\n"
else
finishBodyChunk :: Interaction -> IO ()
finishBodyChunk itr
- = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $ readItr itr itrWillChunkBody id
+ = itr `seq`
+ do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
+ willChunkBody <- atomically $! readItr itr itrWillChunkBody id
when (not willDiscardBody && willChunkBody)
$ hPutStr h "0\r\n\r\n" >> hFlush h
finalize :: Interaction -> IO ()
finalize itr
- = do finishBodyChunk itr
- willClose <- atomically $ do queue <- readTVar tQueue
+ = itr `seq`
+ do finishBodyChunk itr
+ willClose <- atomically $!
+ do queue <- readTVar tQueue
- let (remaining :> _) = S.viewr queue
- writeTVar tQueue remaining
+ case S.viewr queue of
+ remaining :> _ -> writeTVar tQueue remaining
- readItr itr itrWillClose id
+ readItr itr itrWillClose id
if willClose then
-- reader は恐らく hWaitForInput してゐる最中なので、
-- スレッドを豫め殺して置かないとをかしくなる。
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.MIMEType.Guess
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Tree
import Network.HTTP.Lucu.Utils
import System.Directory
import System.Posix.Files
-import Text.Printf
-- | @'staticFile' fpath@ is a
= ResourceDef {
resUsesNativeThread = False
, resIsGreedy = False
- , resGet = Just $ handleStaticFile path
+ , resGet = Just $! handleStaticFile path
, resHead = Nothing
, resPost = Nothing
, resPut = Nothing
-- 'staticFile' instead of this.
handleStaticFile :: FilePath -> Resource ()
handleStaticFile path
- = do isFile <- liftIO $ doesFileExist path
+ = path `seq`
+ do isFile <- liftIO $ doesFileExist path
if isFile then
-- 存在はした。讀めるかどうかは知らない。
do readable <- liftIO $ fileAccess path True False False
-- large (say, 1 TiB).
generateETagFromFile :: FilePath -> IO ETag
generateETagFromFile path
- = do stat <- getFileStatus path
- let inode = fromEnum $ fileID stat
- size = fromEnum $ fileSize stat
- lastmod = fromEnum $ modificationTime stat
- return $ strongETag $ printf "%x-%x-%x" inode size lastmod
+ = path `seq`
+ do stat <- getFileStatus path
+ let inode = fromEnum $! fileID stat
+ size = fromEnum $! fileSize stat
+ lastMod = fromEnum $! modificationTime stat
+ tag = fmtHex False 0 inode
+ ++ "-" ++
+ fmtHex False 0 size
+ ++ "-" ++
+ fmtHex False 0 lastMod
+ return $! strongETag tag
-- | @'staticDir' dir@ is a
-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
= ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
- , resGet = Just $ handleStaticDir path
+ , resGet = Just $! handleStaticDir path
, resHead = Nothing
, resPost = Nothing
, resPut = Nothing
-- 'staticDir' instead of this.
handleStaticDir :: FilePath -> Resource ()
handleStaticDir basePath
- = do extraPath <- getPathInfo
+ = basePath `seq`
+ do extraPath <- getPathInfo
securityCheck extraPath
let path = basePath ++ "/" ++ joinWith "/" extraPath
where
securityCheck :: Monad m => [String] -> m ()
securityCheck pathElems
- = when (any (== "..") pathElems) $ fail ("security error: "
+ = pathElems `seq`
+ when (any (== "..") pathElems) $ fail ("security error: "
++ joinWith "/" pathElems)
, joinWith
, trim
, noCaseEq
+ , noCaseEq'
, isWhiteSpace
, quoteStr
, parseWWWFormURLEncoded
-- > ==> ["ab", "c", "def"]
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy isSeparator src
- = case break isSeparator src
+ = isSeparator `seq`
+ case break isSeparator src
of (last , [] ) -> last : []
(first, sep:rest) -> first : splitBy isSeparator rest
-- > ==> "ab:c:def"
joinWith :: [a] -> [[a]] -> [a]
joinWith separator xs
- = foldr (++) [] $ intersperse separator xs
+ = separator `seq` xs `seq`
+ foldr (++) [] $! intersperse separator xs
-- |> trim (== '_') "__ab_c__def___"
-- > ==> "ab_c__def"
trim :: (a -> Bool) -> [a] -> [a]
-trim p = trimTail . trimHead
+trim p = p `seq` trimTail . trimHead
where
trimHead = dropWhile p
trimTail = reverse . trimHead . reverse
-- |@'noCaseEq' a b@ is equivalent to @(map toLower a) == (map toLower
--- b)@
+-- b)@. See 'noCaseEq''.
noCaseEq :: String -> String -> Bool
noCaseEq a b
= (map toLower a) == (map toLower b)
+{-# INLINE noCaseEq #-}
+
+-- |@'noCaseEq'' a b@ is a variant of 'noCaseEq' which first checks
+-- the length of two strings to avoid possibly unnecessary comparison.
+noCaseEq' :: String -> String -> Bool
+noCaseEq' a b
+ | length a /= length b = False
+ | otherwise = noCaseEq a b
+{-# INLINE noCaseEq' #-}
-- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF.
isWhiteSpace :: Char -> Bool
-isWhiteSpace = flip elem " \t\r\n"
+isWhiteSpace ' ' = True
+isWhiteSpace '\t' = True
+isWhiteSpace '\r' = True
+isWhiteSpace '\n' = True
+isWhiteSpace _ = False
+{-# INLINE isWhiteSpace #-}
-- |> quoteStr "abc"
-- > ==> "\"abc\""
-- > quoteStr "ab\"c"
-- > ==> "\"ab\\\"c\""
quoteStr :: String -> String
-quoteStr str = foldr (++) "" (["\""] ++ map quote str ++ ["\""])
+quoteStr str = str `seq`
+ foldr (++) "" (["\""] ++ map quote str ++ ["\""])
where
quote :: Char -> String
quote '"' = "\\\""
projects / Lucu.git / commitdiff