import Codec.Compression.GZip
import Control.Monad
import Data.Bits
-import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Base (LazyByteString)
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Digest.SHA1
exports = [HsEVar (UnQual (HsIdent symName))]
imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64")
False Nothing Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Lazy")
- False Nothing (Just (False, [HsIVar (HsIdent "ByteString")]))
+ , 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")
expOutputGunzipped
expOutputGZipped)
expOutputGunzipped
- = (HsApp (HsVar (UnQual (HsIdent "outputBS")))
+ = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
(HsParen
(HsApp (HsVar (UnQual (HsIdent "decompress")))
(HsVar (UnQual (HsIdent "gzippedData"))))))
= HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
(HsList [HsLit (HsString "gzip")]))
doOutputGZipped
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS")))
+ = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
(HsVar (UnQual (HsIdent "gzippedData"))))
in
HsApp (HsCon (UnQual (HsIdent "Just")))
= HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
(HsVar (UnQual (HsIdent "contentType"))))
doOutputRawData
- = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS")))
+ = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
(HsVar (UnQual (HsIdent "rawData"))))
in
HsApp (HsCon (UnQual (HsIdent "Just")))
declGZippedData
= [ HsTypeSig undefined [HsIdent "gzippedData"]
(HsQualType []
- (HsTyCon (UnQual (HsIdent "ByteString"))))
+ (HsTyCon (UnQual (HsIdent "LazyByteString"))))
, HsFunBind [HsMatch undefined (HsIdent "gzippedData")
[] (HsUnGuardedRhs defGZippedData) []]
]
declRawData
= [ HsTypeSig undefined [HsIdent "rawData"]
(HsQualType []
- (HsTyCon (UnQual (HsIdent "ByteString"))))
+ (HsTyCon (UnQual (HsIdent "LazyByteString"))))
, HsFunBind [HsMatch undefined (HsIdent "rawData")
[] (HsUnGuardedRhs defRawData) []]
]
getLastModified fpath = getModificationTime fpath
-getETag :: [CmdOpt] -> ByteString -> IO String
+getETag :: [CmdOpt] -> LazyByteString -> IO String
getETag opts input
= let eTagOpts = filter (\ x -> case x of
OptETag _ -> True
| n < 16 = (chr $ ord 'a' + n - 10)
-openInput :: FilePath -> IO ByteString
+openInput :: FilePath -> IO LazyByteString
openInput "-" = L.getContents
openInput fpath = L.readFile fpath
-}
module Foo.Bar.Baz (baz) where
import Codec.Binary.Base64
- import Data.ByteString.Lazy (ByteString)
+ import Data.ByteString.Base (LazyByteString)
import qualified Data.ByteString.Lazy as L
import Network.HTTP.Lucu
import System.Time
, resGet
= Just (do foundEntity entityTag lastModified
setContentType contentType
- outputBS rawData)
+ outputLBS rawData)
, resHead = Nothing
, resPost = Nothing
, resPut = Nothing
contentType :: MIMEType
contentType = read "image/png"
- rawData :: ByteString
+ rawData :: LazyByteString
rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")
------------------------------------------------------------------------------
mustGunzip <- liftM not (isEncodingAcceptable "gzip")
if mustGunzip then
- outputBS (decompress gzippedData)
+ outputLBS (decompress gzippedData)
else
do setContentEncoding ["gzip"]
- outputBS gzippedData
+ outputLBS gzippedData
, resHead = Nothing
, resPost = Nothing
, resPut = Nothing
}
-- rawData の代はりに gzippedData
- gzippedData :: ByteString
+ gzippedData :: LazyByteString
gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")
------------------------------------------------------------------------------
-}
import Network.HTTP.Lucu.Headers
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
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 'Control.Monad.STM.STM' monad.
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 を使ってデフォルトのメッセージを得な
mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
mkDefaultPage conf status msgA
= conf `seq` status `seq` msgA `seq`
- let (sCode, sMsg) = statusCode status
- sig = cnfServerSoftware conf
- ++ " at "
- ++ cnfServerHost conf
- ++ ( case cnfServerPort conf of
- Service serv -> ", service " ++ serv
- PortNumber num -> ", port " ++ show num
- UnixSocket path -> ", unix socket " ++ show path
- )
+ let (# sCode, sMsg #) = statusCode status
+ sig = cnfServerSoftware conf
+ ++ " at "
+ ++ cnfServerHost conf
+ ++ ( case cnfServerPort conf of
+ Service serv -> ", service " ++ serv
+ PortNumber num -> ", port " ++ show num
+ UnixSocket path -> ", unix socket " ++ show path
+ )
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
failP :: Parser a
failP = fail undefined
--- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(result,
--- remaining)@.
+-- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result,
+-- remaining #)@.
parse :: Parser a -> LazyByteString -> (# ParserResult a, LazyByteString #)
parse p input -- input は lazy である必要有り。
= p `seq`
import Data.List
import Network.HTTP.Lucu.Parser
--- |@'isCtl' c@ is False iff @0x20 <= @c@ < 0x7F@.
+-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
isCtl :: Char -> Bool
isCtl c
| c < '\x1f' = True
| c >= '\x7f' = True
| otherwise = False
--- |@'isSeparator' c@ is True iff c is one of HTTP separators.
+-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
+-- separators.
isSeparator :: Char -> Bool
isSeparator '(' = True
isSeparator ')' = True
isSeparator '\t' = True
isSeparator _ = False
--- |@'isChar' c@ is True iff @c <= 0x7f@.
+-- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
isChar :: Char -> Bool
isChar c
| c <= '\x7f' = True
week :: [String]
week = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
--- |Format a @CalendarTime@ to RFC 1123 Date and Time string.
+-- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time
+-- string.
formatRFC1123DateTime :: CalendarTime -> String
formatRFC1123DateTime time
= time `seq`
id (ctTZName time)
--- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be
--- always UTC but prints as GMT.
+-- |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`
-- #prune
-- |This is the Resource Monad; monadic actions to define the behavior
--- of each resources. The 'Resource' Monad is a kind of IO Monad thus
--- it implements MonadIO class. It is also a state machine.
+-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
+-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
+-- also a state machine.
--
-- Request Processing Flow:
--
(
-- * Monad
Resource
+ , runRes -- private
-- * Actions
-- Body/.
, input
, inputChunk
- , inputBS
- , inputChunkBS
+ , inputLBS
+ , inputChunkLBS
, inputForm
, defaultLimit
-- Body/.
, output
, outputChunk
- , outputBS
- , outputChunkBS
+ , outputLBS
+ , outputChunkLBS
, driftTo
)
import Control.Concurrent.STM
import Control.Monad.Reader
import Data.Bits
+import Data.ByteString.Base (LazyByteString)
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
import Data.List
import Data.Maybe
import Network.HTTP.Lucu.Abortion
import Network.URI
import System.Time
--- |The 'Resource' monad. /Interaction/ is an internal state thus it
--- is not exposed to users. This monad implements 'MonadIO' so it can
--- do any IO actions.
-type Resource a = ReaderT Interaction IO a
+-- |The 'Resource' monad. This monad implements
+-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO'
+-- actions.
+newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
+
+instance Functor Resource where
+ fmap f c = Resource (fmap f (unRes c))
+
+instance Monad Resource where
+ c >>= f = Resource (unRes c >>= unRes . f)
+ return = Resource . return
+ fail = Resource . fail
+
+instance MonadIO Resource where
+ liftIO = Resource . liftIO
+
+
+runRes :: Resource a -> Interaction -> IO a
+runRes r itr
+ = runReaderT (unRes r) itr
+
+
+getInteraction :: Resource Interaction
+getInteraction = Resource ask
+
-- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
-- the httpd.
getConfig :: Resource Config
-getConfig = do itr <- ask
+getConfig = do itr <- getInteraction
return $! itrConfig itr
--- |Get the SockAddr of the remote host. If you want a string
--- representation instead of SockAddr, use 'getRemoteAddr''.
+-- |Get the 'Network.Socket.SockAddr' of the remote host. If you want
+-- a string representation instead of 'Network.Socket.SockAddr', use
+-- 'getRemoteAddr''.
getRemoteAddr :: Resource SockAddr
-getRemoteAddr = do itr <- ask
+getRemoteAddr = do itr <- getInteraction
return $! itrRemoteAddr itr
-- |Get the string representation of the address of remote host. If
--- you want a SockAddr instead of String, use 'getRemoteAddr'.
+-- you want a 'Network.Socket.SockAddr' instead of String, use
+-- 'getRemoteAddr'.
getRemoteAddr' :: Resource String
getRemoteAddr' = do addr <- getRemoteAddr
case addr of
-- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
-- the request header. In general you don't have to use this action.
getRequest :: Resource Request
-getRequest = do itr <- ask
+getRequest = do itr <- getInteraction
req <- liftIO $! atomically $! readItr itr itrRequest fromJust
return req
-- > , ...
-- > }
getResourcePath :: Resource [String]
-getResourcePath = do itr <- ask
+getResourcePath = do itr <- getInteraction
return $! fromJust $! itrResourcePath itr
-- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
-- the response.
--
--- This action is not preferred. You should use 'foundEntity' when
+-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundETag :: ETag -> Resource ()
foundETag tag
-- modification time are unsafe because it is possible to mess up such
-- tests by modifying the entity twice in a second.
--
--- This action is not preferred. You should use 'foundEntity' when
+-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundTimeStamp :: ClockTime -> Resource ()
foundTimeStamp timeStamp
-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
--- Note that 'inputBS' is more efficient than 'input' so you should
+-- Note that 'inputLBS' is more efficient than 'input' so you should
-- use it whenever possible.
input :: Int -> Resource String
input limit = limit `seq`
- inputBS limit >>= return . B.unpack
+ inputLBS limit >>= return . B.unpack
-- | This is mostly the same as 'input' but is more
--- efficient. 'inputBS' returns a lazy ByteString but it's not really
--- lazy: reading from the socket just happens at the computation of
--- 'inputBS', not at the lazy evaluation of the ByteString. The same
--- goes for 'inputChunkBS'.
-inputBS :: Int -> Resource ByteString
-inputBS limit
+-- 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
+-- 'inputChunkLBS'.
+inputLBS :: Int -> Resource LazyByteString
+inputLBS limit
= limit `seq`
do driftTo GettingBody
- itr <- ask
+ itr <- getInteraction
hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
chunk <- if hasBody then
askForInput itr
return B.empty
return chunk
where
- askForInput :: Interaction -> Resource ByteString
+ askForInput :: Interaction -> Resource LazyByteString
askForInput itr
= itr `seq`
do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
else
limit
when (actualLimit <= 0)
- $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
+ $ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $! atomically
$! do chunkLen <- readItr itr itrReqChunkLength id
-- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See
-- 'defaultLimit'.
--
--- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you
+-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
-- should use it whenever possible.
inputChunk :: Int -> Resource String
inputChunk limit = limit `seq`
- inputChunkBS limit >>= return . B.unpack
+ inputChunkLBS limit >>= return . B.unpack
-- | This is mostly the same as 'inputChunk' but is more
--- efficient. See 'inputBS'.
-inputChunkBS :: Int -> Resource ByteString
-inputChunkBS limit
+-- efficient. See 'inputLBS'.
+inputChunkLBS :: Int -> Resource LazyByteString
+inputChunkLBS limit
= limit `seq`
do driftTo GettingBody
- itr <- ask
+ itr <- getInteraction
hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
chunk <- if hasBody then
askForInput itr
return B.empty
return chunk
where
- askForInput :: Interaction -> Resource ByteString
+ askForInput :: Interaction -> Resource LazyByteString
askForInput itr
= itr `seq`
do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
else
limit
when (actualLimit <= 0)
- $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
+ $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $! atomically
$! do writeItr itr itrReqBodyWanted $! Just actualLimit
= abort UnsupportedMediaType []
(Just $! "Sorry, inputForm does not currently support multipart/form-data.")
--- | This is just a constant -1. It's better to say @'input'
+-- | This is just a constant @-1@. It's better to say @'input'
-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
-- the same.
defaultLimit :: Int
setStatus code
= code `seq`
do driftTo DecidingHeader
- itr <- ask
+ itr <- getInteraction
liftIO $! atomically $! updateItr itr itrResponse
$! \ res -> res {
resStatus = code
setHeader' :: String -> String -> Resource ()
setHeader' name value
= name `seq` value `seq`
- do itr <- ask
+ do itr <- getInteraction
liftIO $ atomically
$ updateItr itr itrResponse
$ H.setHeader name value
-- | Computation of @'redirect' code uri@ sets the response status to
--- @code@ and \"Location\" header to @uri@. @code@ must satisfy
+-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
-- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
redirect :: StatusCode -> URI -> Resource ()
redirect code uri
-- apply 'output' to an infinite string, such as a lazy stream of
-- \/dev\/random.
--
--- Note that 'outputBS' is more efficient than 'output' so you should
+-- Note that 'outputLBS' is more efficient than 'output' so you should
-- use it whenever possible.
output :: String -> Resource ()
-output str = outputBS $! B.pack str
+output str = outputLBS $! 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 #-}
+outputLBS :: LazyByteString -> Resource ()
+outputLBS str = do outputChunkLBS str
+ driftTo Done
+{-# INLINE outputLBS #-}
-- | Computation of @'outputChunk' str@ writes @str@ as a part of
-- response body. You can compute this action multiple times to write
-- a body little at a time. It is safe to apply 'outputChunk' to an
-- infinite string.
--
--- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
+-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
-- you should use it whenever possible.
outputChunk :: String -> Resource ()
-outputChunk str = outputChunkBS $! B.pack str
+outputChunk str = outputChunkLBS $! B.pack str
{-# INLINE outputChunk #-}
-- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str
+outputChunkLBS :: LazyByteString -> Resource ()
+outputChunkLBS str
= str `seq`
do driftTo DecidingBody
- itr <- ask
+ itr <- getInteraction
let limit = cnfMaxOutputChunkLength $ itrConfig itr
when (limit <= 0)
$ liftIO $ atomically $
writeItr itr itrBodyIsNull False
where
- {- チャンクの大きさは Config で制限されてゐる。もし例へば
- /dev/zero を B.readFile して作った ByteString をそのまま
- ResponseWriter に渡したりすると大變な事が起こる。何故なら
- ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く
- 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ
- までも無い。 -}
- sendChunks :: ByteString -> Int -> Resource ()
+ -- チャンクの大きさは Config で制限されてゐる。もし例へば
+ -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま
+ -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
+ -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
+ -- く爲にチャンクの大きさを測る。
+ sendChunks :: LazyByteString -> Int -> Resource ()
sendChunks str limit
| B.null str = return ()
| otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
- itr <- ask
+ itr <- getInteraction
liftIO $ atomically $
do buf <- readItr itr itrBodyToSend id
if B.null buf then
driftTo :: InteractionState -> Resource ()
driftTo newState
= newState `seq`
- do itr <- ask
+ do itr <- getInteraction
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
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
-import Control.Monad.Reader
+import Control.Monad
import Data.Dynamic
import Data.List
import qualified Data.Map as M
-- | 'ResourceDef' is basically a set of
-- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods.
data ResourceDef = ResourceDef {
- -- | 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
+ -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a
+ -- native thread (spawned by 'Control.Concurrent.forkOS') or to
+ -- run it on a user thread (spanwed by
+ -- 'Control.Concurrent.forkIO'). Generally you don't need to set
+ -- this field to 'Prelude.True'.
resUsesNativeThread :: !Bool
-- | Whether to be greedy or not.
--
runResource def itr
= def `seq` itr `seq`
fork
- $! catch ( runReaderT ( do req <- getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
+ $! catch ( runRes ( do req <- getRequest
+ fromMaybe notAllowed $ rsrc req
+ driftTo Done
+ ) itr
)
$ \ exc -> processException exc
where
reqM <- atomically $ readItr itr itrRequest id
res <- atomically $ readItr itr itrResponse id
if state <= DecidingHeader then
- flip runReaderT itr
+ flip runRes itr
$ do setStatus $ aboStatus abo
-- FIXME: 同じ名前で複數の値があった時は、こ
-- れではまずいと思ふ。
when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
$ hPutStrLn stderr $ show abo
- flip runReaderT itr $ driftTo Done
+ flip runRes itr $ driftTo Done
formatIOE :: IOError -> String
formatIOE ioE = if isUserError ioE then
deriving (Typeable, Eq)
instance Show StatusCode where
- show sc = let (num, msg) = statusCode sc
+ show sc = let (# num, msg #) = statusCode sc
in
(fmtDec 3 num) ++ " " ++ msg
= h `seq` sc `seq`
hPutStr h (show sc)
--- |@'isInformational' sc@ is True iff @sc < 200@.
+-- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@.
isInformational :: StatusCode -> Bool
isInformational = doesMeet (< 200)
--- |@'isSuccessful' sc@ is True iff @200 <= sc < 300@.
+-- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@.
isSuccessful :: StatusCode -> Bool
isSuccessful = doesMeet (\ n -> n >= 200 && n < 300)
--- |@'isRedirection' sc@ is True iff @300 <= sc < 400@.
+-- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@.
isRedirection :: StatusCode -> Bool
isRedirection = doesMeet (\ n -> n >= 300 && n < 400)
--- |@'isError' sc@ is True iff @400 <= sc@
+-- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@
isError :: StatusCode -> Bool
isError = doesMeet (>= 400)
--- |@'isClientError' sc@ is True iff @400 <= sc < 500@.
+-- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@.
isClientError :: StatusCode -> Bool
isClientError = doesMeet (\ n -> n >= 400 && n < 500)
--- |@'isServerError' sc@ is True iff @500 <= sc@.
+-- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@.
isServerError :: StatusCode -> Bool
isServerError = doesMeet (>= 500)
doesMeet :: (Int -> Bool) -> StatusCode -> Bool
-doesMeet p sc = let (num, _) = statusCode sc
+doesMeet p sc = let (# num, _ #) = statusCode sc
in
p num
-- |@'statusCode' sc@ returns a tuple of numeric and textual
-- representation of @sc@.
-statusCode :: StatusCode -> (Int, String)
-statusCode Continue = (100, "Continue")
-statusCode SwitchingProtocols = (101, "Switching Protocols")
-statusCode Processing = (102, "Processing")
+statusCode :: StatusCode -> (# Int, String #)
+statusCode Continue = (# 100, "Continue" #)
+statusCode SwitchingProtocols = (# 101, "Switching Protocols" #)
+statusCode Processing = (# 102, "Processing" #)
--
-statusCode Ok = (200, "OK")
-statusCode Created = (201, "Created")
-statusCode Accepted = (202, "Accepted")
-statusCode NonAuthoritativeInformation = (203, "Non Authoritative Information")
-statusCode NoContent = (204, "No Content")
-statusCode ResetContent = (205, "Reset Content")
-statusCode PartialContent = (206, "Partial Content")
-statusCode MultiStatus = (207, "Multi Status")
+statusCode Ok = (# 200, "OK" #)
+statusCode Created = (# 201, "Created" #)
+statusCode Accepted = (# 202, "Accepted" #)
+statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #)
+statusCode NoContent = (# 204, "No Content" #)
+statusCode ResetContent = (# 205, "Reset Content" #)
+statusCode PartialContent = (# 206, "Partial Content" #)
+statusCode MultiStatus = (# 207, "Multi Status" #)
--
-statusCode MultipleChoices = (300, "Multiple Choices")
-statusCode MovedPermanently = (301, "Moved Permanently")
-statusCode Found = (302, "Found")
-statusCode SeeOther = (303, "See Other")
-statusCode NotModified = (304, "Not Modified")
-statusCode UseProxy = (305, "Use Proxy")
-statusCode TemporaryRedirect = (306, "Temporary Redirect")
+statusCode MultipleChoices = (# 300, "Multiple Choices" #)
+statusCode MovedPermanently = (# 301, "Moved Permanently" #)
+statusCode Found = (# 302, "Found" #)
+statusCode SeeOther = (# 303, "See Other" #)
+statusCode NotModified = (# 304, "Not Modified" #)
+statusCode UseProxy = (# 305, "Use Proxy" #)
+statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #)
--
-statusCode BadRequest = (400, "Bad Request")
-statusCode Unauthorized = (401, "Unauthorized")
-statusCode PaymentRequired = (402, "Payment Required")
-statusCode Forbidden = (403, "Forbidden")
-statusCode NotFound = (404, "Not Found")
-statusCode MethodNotAllowed = (405, "Method Not Allowed")
-statusCode NotAcceptable = (406, "Not Acceptable")
-statusCode ProxyAuthenticationRequired = (407, "Proxy Authentication Required")
-statusCode RequestTimeout = (408, "Request Timeout")
-statusCode Conflict = (409, "Conflict")
-statusCode Gone = (410, "Gone")
-statusCode LengthRequired = (411, "Length Required")
-statusCode PreconditionFailed = (412, "Precondition Failed")
-statusCode RequestEntityTooLarge = (413, "Request Entity Too Large")
-statusCode RequestURITooLarge = (414, "Request URI Too Large")
-statusCode UnsupportedMediaType = (415, "Unsupported Media Type")
-statusCode RequestRangeNotSatisfiable = (416, "Request Range Not Satisfiable")
-statusCode ExpectationFailed = (417, "Expectation Failed")
-statusCode UnprocessableEntitiy = (422, "Unprocessable Entity")
-statusCode Locked = (423, "Locked")
-statusCode FailedDependency = (424, "Failed Dependency")
+statusCode BadRequest = (# 400, "Bad Request" #)
+statusCode Unauthorized = (# 401, "Unauthorized" #)
+statusCode PaymentRequired = (# 402, "Payment Required" #)
+statusCode Forbidden = (# 403, "Forbidden" #)
+statusCode NotFound = (# 404, "Not Found" #)
+statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #)
+statusCode NotAcceptable = (# 406, "Not Acceptable" #)
+statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #)
+statusCode RequestTimeout = (# 408, "Request Timeout" #)
+statusCode Conflict = (# 409, "Conflict" #)
+statusCode Gone = (# 410, "Gone" #)
+statusCode LengthRequired = (# 411, "Length Required" #)
+statusCode PreconditionFailed = (# 412, "Precondition Failed" #)
+statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #)
+statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #)
+statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #)
+statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #)
+statusCode ExpectationFailed = (# 417, "Expectation Failed" #)
+statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #)
+statusCode Locked = (# 423, "Locked" #)
+statusCode FailedDependency = (# 424, "Failed Dependency" #)
--
-statusCode InternalServerError = (500, "Internal Server Error")
-statusCode NotImplemented = (501, "Not Implemented")
-statusCode BadGateway = (502, "Bad Gateway")
-statusCode ServiceUnavailable = (503, "Service Unavailable")
-statusCode GatewayTimeout = (504, "Gateway Timeout")
-statusCode HttpVersionNotSupported = (505, "HTTP Version Not Supported")
-statusCode InsufficientStorage = (507, "Insufficient Storage")
\ No newline at end of file
+statusCode InternalServerError = (# 500, "Internal Server Error" #)
+statusCode NotImplemented = (# 501, "Not Implemented" #)
+statusCode BadGateway = (# 502, "Bad Gateway" #)
+statusCode ServiceUnavailable = (# 503, "Service Unavailable" #)
+statusCode GatewayTimeout = (# 504, "Gateway Timeout" #)
+statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #)
+statusCode InsufficientStorage = (# 507, "Insufficient Storage" #)
\ No newline at end of file
Just mime -> setContentType mime
-- 實際にファイルを讀んで送る
- (liftIO $ B.readFile path) >>= outputBS
+ (liftIO $ B.readFile path) >>= outputLBS
else
do isDir <- liftIO $ doesDirectoryExist path
if isDir then
trimHead = dropWhile p
trimTail = reverse . trimHead . reverse
--- |@'noCaseEq' a b@ is equivalent to @(map toLower a) == (map toLower
+-- |@'noCaseEq' a b@ is equivalent to @('Prelude.map'
+-- 'Data.Char.toLower' a) == ('Prelude.map' 'Data.Char.toLower'
-- b)@. See 'noCaseEq''.
noCaseEq :: String -> String -> Bool
noCaseEq a b
| otherwise = noCaseEq a b
{-# INLINE noCaseEq' #-}
--- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF.
+-- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR
+-- and LF.
isWhiteSpace :: Char -> Bool
isWhiteSpace ' ' = True
isWhiteSpace '\t' = True
projects / Lucu.git / commitdiff