network == 2.3.*,
stm == 2.2.*,
stringsearch == 0.3.*,
+ template-haskell == 2.5.*,
text == 0.11.*,
time == 1.2.*,
time-http == 0.2.*,
Network.HTTP.Lucu.ETag
Network.HTTP.Lucu.HttpVersion
Network.HTTP.Lucu.Httpd
+ Network.HTTP.Lucu.MIMEParams
Network.HTTP.Lucu.MIMEType
Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
Network.HTTP.Lucu.MIMEType.Guess
+ Network.HTTP.Lucu.MIMEType.TH
Network.HTTP.Lucu.MultipartForm
Network.HTTP.Lucu.Parser.Http
Network.HTTP.Lucu.Parser
- Network.HTTP.Lucu.RFC2231
Network.HTTP.Lucu.Request
Network.HTTP.Lucu.Resource
Network.HTTP.Lucu.Resource.Tree
{-# LANGUAGE
- DoAndIfThenElse
+ DeriveDataTypeable
+ , DoAndIfThenElse
+ , GeneralizedNewtypeDeriving
, OverloadedStrings
, RecordWildCards
+ , TemplateHaskell
, UnicodeSyntax
#-}
--- |Provide functionalities to encode/decode MIME parameter values in
--- character sets other than US-ASCII. See:
--- <http://www.faqs.org/rfcs/rfc2231.html>
---
--- You usually don't have to use this module directly.
-module Network.HTTP.Lucu.RFC2231
- ( printMIMEParams
+-- |Parsing and printing MIME parameter values
+-- (<http://tools.ietf.org/html/rfc2231>).
+module Network.HTTP.Lucu.MIMEParams
+ ( MIMEParams(..)
+ , printMIMEParams
, mimeParams
)
where
import Data.Bits
import qualified Data.ByteString.Char8 as BS
import Data.Char
+import Data.Data
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as M
+import Data.Monoid
import Data.Monoid.Unicode
import Data.Sequence (Seq, ViewL(..))
import qualified Data.Sequence as S
import Data.Text.Encoding.Error
import Data.Traversable
import Data.Word
+import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.Utils
import Prelude hiding (concat, mapM, takeWhile)
import Prelude.Unicode
+-- |A map from MIME parameter attributes to values. Attributes are
+-- always case-insensitive according to RFC 2045
+-- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
+newtype MIMEParams
+ = MIMEParams (Map CIAscii Text)
+ deriving (Eq, Show, Read, Monoid, Typeable)
+
+instance Lift MIMEParams where
+ lift (MIMEParams m) = [| MIMEParams $(liftParams m) |]
+ where
+ liftParams ∷ Map CIAscii Text → Q Exp
+ liftParams = liftMap liftCIAscii liftText
+
-- |Convert MIME parameter values to an 'AsciiBuilder'.
-printMIMEParams ∷ Map CIAscii Text → AsciiBuilder
+printMIMEParams ∷ MIMEParams → AsciiBuilder
{-# INLINEABLE printMIMEParams #-}
-printMIMEParams m = M.foldlWithKey f (∅) m
+printMIMEParams (MIMEParams m) = M.foldlWithKey f (∅) m
-- THINKME: Use foldlWithKey' for newer Data.Map
where
f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
section ep = epSection ep
-- |'Parser' for MIME parameter values.
-mimeParams ∷ Parser (Map CIAscii Text)
+mimeParams ∷ Parser MIMEParams
{-# INLINEABLE mimeParams #-}
mimeParams = decodeParams =≪ P.many (try paramP)
{-# INLINE rawChars #-}
rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%')
-decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
+decodeParams ∷ (Functor m, Monad m) ⇒ [ExtendedParam] → m MIMEParams
{-# INLINE decodeParams #-}
-decodeParams = (mapM decodeSections =≪) ∘ sortBySection
+decodeParams = (MIMEParams <$>) ∘ (mapM decodeSections =≪) ∘ sortBySection
sortBySection ∷ Monad m
⇒ [ExtendedParam]
{-# LANGUAGE
- OverloadedStrings
+ DeriveDataTypeable
+ , OverloadedStrings
+ , RecordWildCards
+ , TemplateHaskell
, UnicodeSyntax
#-}
-
--- |MIME Types
+-- |Parsing and printing MIME Media Types
+-- (<http://tools.ietf.org/html/rfc2046>).
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
, mkMIMEType
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
-import Data.Map (Map)
import Data.Monoid.Unicode
-import Data.Text (Text)
+import Data.Typeable
+import Language.Haskell.TH.Syntax
+import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.RFC2231
-import Prelude hiding (min)
+import Network.HTTP.Lucu.Utils
import Prelude.Unicode
--- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\"), ...]@
--- represents \"major\/minor; name=value; ...\".
-data MIMEType = MIMEType {
- mtMajor ∷ !CIAscii
- , mtMinor ∷ !CIAscii
- , mtParams ∷ !(Map CIAscii Text)
- } deriving (Eq)
+-- |A media type, subtype, and parameters.
+data MIMEType
+ = MIMEType {
+ mtMedia ∷ !CIAscii
+ , mtSub ∷ !CIAscii
+ , mtParams ∷ !MIMEParams
+ }
+ deriving (Eq, Show, Read, Typeable)
-instance Show MIMEType where
- show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
+instance Lift MIMEType where
+ lift (MIMEType {..})
+ = [| MIMEType {
+ mtMedia = $(liftCIAscii mtMedia)
+ , mtSub = $(liftCIAscii mtSub)
+ , mtParams = $(lift mtParams)
+ }
+ |]
--- |@'mkMIMEType' major minor@ returns a 'MIMEType' with the given
--- @major@ and @minor@ types but without any parameters.
+-- |@'mkMIMEType' media sub@ returns a 'MIMEType' with the given
+-- @media@ and @sub@ types but without any parameters.
mkMIMEType ∷ CIAscii → CIAscii → MIMEType
{-# INLINE mkMIMEType #-}
-mkMIMEType maj min
- = MIMEType maj min (∅)
+mkMIMEType = flip flip (∅) ∘ MIMEType
-- |Convert a 'MIMEType' to an 'AsciiBuilder'.
printMIMEType ∷ MIMEType → AsciiBuilder
{-# INLINEABLE printMIMEType #-}
-printMIMEType (MIMEType maj min params)
- = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
+printMIMEType (MIMEType {..})
+ = A.toAsciiBuilder (A.fromCIAscii mtMedia) ⊕
A.toAsciiBuilder "/" ⊕
- A.toAsciiBuilder (A.fromCIAscii min) ⊕
- printMIMEParams params
+ A.toAsciiBuilder (A.fromCIAscii mtSub) ⊕
+ printMIMEParams mtParams
-- |Parse 'MIMEType' from an 'Ascii'. This function throws an
--- exception for parse error.
+-- exception for parse error. For literals consider using
+-- 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
parseMIMEType ∷ Ascii → MIMEType
{-# INLINEABLE parseMIMEType #-}
parseMIMEType str
-- |'Parser' for an 'MIMEType'.
mimeType ∷ Parser MIMEType
{-# INLINEABLE mimeType #-}
-mimeType = do maj ← A.toCIAscii <$> token
+mimeType = do media ← A.toCIAscii <$> token
_ ← char '/'
- min ← A.toCIAscii <$> token
+ sub ← A.toCIAscii <$> token
params ← mimeParams
- return $ MIMEType maj min params
+ return $ MIMEType media sub params
-- |'Parser' for a list of 'MIMEType's.
mimeTypeList ∷ Parser [MIMEType]
--- /dev/null
+{-# LANGUAGE
+ UnicodeSyntax
+ , ViewPatterns
+ #-}
+module Network.HTTP.Lucu.MIMEType.TH
+ ( mimeType
+ )
+ where
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+
+-- |A 'QuasiQuoter' for 'MIMEType' literals.
+--
+-- @
+-- textPlain :: 'MIMEType'
+-- textPlain = ['mimeType'| text/plain; charset="UTF-8" |]
+-- @
+mimeType ∷ QuasiQuoter
+mimeType = QuasiQuoter {
+ quoteExp = (lift ∘ parseMIMEType =≪) ∘ toAscii
+ , quotePat = const unsupported
+ , quoteType = const unsupported
+ , quoteDec = const unsupported
+ }
+ where
+ toAscii ∷ Monad m ⇒ String → m Ascii
+ toAscii (A.fromChars ∘ trim → Just a) = return a
+ toAscii str = fail $ "Malformed MIME Type: " ⧺ str
+
+ unsupported ∷ Monad m ⇒ m α
+ unsupported = fail "Unsupported usage of mimeType quasi-quoter."
, ViewPatterns
#-}
-- |Parse \"multipart/form-data\" based on RFC 2388:
--- <http://www.faqs.org/rfcs/rfc2388.html>
+-- <http://tools.ietf.org/html/rfc2388>
--
-- You usually don't have to use this module directly.
module Network.HTTP.Lucu.MultipartForm
import Data.ByteString.Lazy.Search
import Data.Foldable
import Data.List
-import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.RFC2231
import Prelude.Unicode
-- |'FormData' represents a form value and possibly an uploaded file
data ContDispo
= ContDispo {
dType ∷ !CIAscii
- , dParams ∷ !(Map CIAscii Text)
+ , dParams ∷ !MIMEParams
}
printContDispo ∷ ContDispo → Ascii
--
-- * \"Content-Transfer-Encoding\" is always ignored.
--
--- * RFC 2388 says that non-ASCII field names are encoded according
--- to the method in RFC 2047
--- <http://www.faqs.org/rfcs/rfc2047.html>, but they won't be
--- decoded.
+-- * RFC 2388 (<http://tools.ietf.org/html/rfc2388#section-3>) says
+-- that non-ASCII field names are encoded according to the method in
+-- RFC 2047 (<http://tools.ietf.org/html/rfc2047>), but they won't
+-- be decoded.
parseMultipartFormData ∷ Ascii -- ^boundary
→ LS.ByteString -- ^input
→ Either String [(Ascii, FormData)]
partName ∷ MonadError String m ⇒ Part → m Ascii
{-# INLINEABLE partName #-}
partName (Part {..})
- = case M.lookup "name" $ dParams ptContDispo of
+ = case M.lookup "name" params of
Just name
→ case A.fromText name of
Just a → return a
Nothing
→ throwError $ "form-data without name: "
⧺ A.toString (printContDispo ptContDispo)
+ where
+ params = case dParams ptContDispo of
+ MIMEParams m → m
partFileName ∷ Part → Maybe Text
-partFileName (Part {..})
- = M.lookup "filename" $ dParams ptContDispo
+partFileName (dParams ∘ ptContDispo → MIMEParams m)
+ = M.lookup "filename" m
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Utils
import Network.Socket hiding (accept)
Just a → return a
Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
- readMultipartFormData params
- = case M.lookup "boundary" params of
+ readMultipartFormData (MIMEParams m)
+ = case M.lookup "boundary" m of
Nothing
→ abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
Just boundary
{-# LANGUAGE
DoAndIfThenElse
, OverloadedStrings
+ , QuasiQuotes
, UnicodeSyntax
#-}
-- | Handling static files on the filesystem.
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ETag
-import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.MIMEType.TH
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
}
octetStream ∷ MIMEType
-{-# NOINLINE octetStream #-}
-octetStream = parseMIMEType "application/octet-stream"
+octetStream = [mimeType| application/octet-stream |]
handleStaticFile ∷ Bool → FilePath → Resource ()
handleStaticFile sendContent path
{-# LANGUAGE
OverloadedStrings
+ , TemplateHaskell
, UnicodeSyntax
#-}
-- |Utility functions used internally in the Lucu httpd. These
, parseWWWFormURLEncoded
, splitPathInfo
, show3
+ , trim
+ , liftCIAscii
+ , liftText
+ , liftMap
)
where
import Blaze.ByteString.Builder.ByteString as B
import Blaze.Text.Int as BT
import Control.Monad
-import Data.Ascii (Ascii, AsciiBuilder)
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
+import Data.Char
import Data.List hiding (last)
+import Data.Map (Map)
+import qualified Data.Map as M
import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
import Network.URI
import Prelude hiding (last)
import Prelude.Unicode
--- |> splitBy (== ':') "ab:c:def"
--- > ==> ["ab", "c", "def"]
+-- |>>> splitBy (== ':') "ab:c:def"
+-- ["ab", "c", "def"]
splitBy ∷ (a → Bool) → [a] → [[a]]
{-# INLINEABLE splitBy #-}
splitBy isSep src
(last , [] ) → [last]
(first, _sep:rest) → first : splitBy isSep rest
--- |> quoteStr "abc"
--- > ==> "\"abc\""
+-- |>>> quoteStr "abc"
+-- "\"abc\""
--
--- > quoteStr "ab\"c"
--- > ==> "\"ab\\\"c\""
+-- >>> quoteStr "ab\"c"
+-- "\"ab\\\"c\""
quoteStr ∷ Ascii → AsciiBuilder
quoteStr str = A.toAsciiBuilder "\"" ⊕
go (A.toByteString str) (∅) ⊕
b2ab ∷ BS.ByteString → AsciiBuilder
b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
--- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
--- > ==> [("aaa", "bbb"), ("ccc", "ddd")]
+-- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
+-- [("aaa", "bbb"), ("ccc", "ddd")]
parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
parseWWWFormURLEncoded src
-- THINKME: We could gain some performance by using attoparsec
plusToSpace '+' = ' '
plusToSpace c = c
--- |> splitPathInfo "http://example.com/foo/bar"
--- > ==> ["foo", "bar"]
+-- |>>> splitPathInfo "http://example.com/foo/bar"
+-- ["foo", "bar"]
splitPathInfo ∷ URI → [ByteString]
splitPathInfo uri
= let reqPathStr = uriPath uri
in
map BS.pack reqPath
--- |> show3 5
--- > ==> "005"
+-- |>>> show3 5
+-- "005"
show3 ∷ Integral n ⇒ n → AsciiBuilder
{-# INLINEABLE show3 #-}
show3 = A.unsafeFromBuilder ∘ go
| otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)
-- FIXME: Drop this function as soon as possible, to eliminate the
-- dependency on blaze-textual.
+
+-- |>>> trim " ab c d "
+-- "ab c d"
+trim ∷ String → String
+trim = reverse ∘ f ∘ reverse ∘ f
+ where
+ f = dropWhile isSpace
+
+-- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
+liftCIAscii ∷ CIAscii → Q Exp
+liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |]
+ where
+ strLit ∷ CIAscii → Q Exp
+ strLit = liftString ∘ A.toString ∘ A.fromCIAscii
+
+-- |Convert a 'Text' to an 'Exp' representing it as a literal.
+liftText ∷ Text → Q Exp
+liftText t = [| T.pack $(strLit t) |]
+ where
+ strLit ∷ Text → Q Exp
+ strLit = liftString ∘ T.unpack
+
+-- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
+-- literal, using a given key lifter and a value lifter.
+liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
+liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |]
+ where
+ liftPairs = listE ∘ map liftPair
+ liftPair (k, v) = tupE [liftK k, liftV v]
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-10-31 22:25:21.576787 Z
references: []
- PHO <pho@cielonegro.org>
- created
- ""
-git_branch:
+- - 2011-11-01 22:31:41.771947 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: template-haskell
projects / Lucu.git / commitdiff