import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import Data.Monoid.Unicode
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http hiding (token)
import Network.HTTP.Lucu.Utils
import Prelude.Unicode
parseETag ∷ Ascii → ETag
{-# INLINEABLE parseETag #-}
parseETag str
- = case parseOnly p $ A.toByteString str of
+ = case parseOnly (finishOff eTag) $ A.toByteString str of
Right et → et
Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err)
- where
- p ∷ Parser ETag
- {-# INLINE p #-}
- p = do et ← eTag
- endOfInput
- return et
-- |This is equivalent to @'ETag' 'False'@. If you want to generate an
-- ETag from a file, try using
import Data.Map (Map)
import Data.Monoid.Unicode
import Data.Text (Text)
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.RFC2231
import Prelude hiding (min)
parseMIMEType ∷ Ascii → MIMEType
{-# INLINEABLE parseMIMEType #-}
parseMIMEType str
- = case parseOnly p $ A.toByteString str of
+ = case parseOnly (finishOff mimeType) $ A.toByteString str of
Right t → t
Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
- where
- p ∷ Parser MIMEType
- {-# INLINE p #-}
- p = do t ← mimeType
- endOfInput
- return t
-- |'Parser' for an 'MIMEType'.
mimeType ∷ Parser MIMEType
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exts.Syntax
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Parser
import Prelude.Unicode
import System.FilePath
-- |Guess the MIME Type of a file.
guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
-guessTypeByFileName extMap fpath
+guessTypeByFileName em fpath
= case takeExtension fpath of
[] → Nothing
- (_:ext) → M.lookup (T.pack ext) extMap
+ (_:ext) → M.lookup (T.pack ext) em
-- |Read an Apache mime.types and parse it.
parseExtMapFile ∷ FilePath → IO ExtMap
parseExtMapFile fpath
= do file ← B.readFile fpath
- case LP.parse extMapP file of
+ case LP.parse (finishOff extMap) file of
LP.Done _ xs
→ case compile xs of
Right m → return m
LP.Fail _ _ e
→ fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
-extMapP ∷ Parser [ (MIMEType, [Text]) ]
-extMapP = do xs ← P.many (try comment <|> try validLine <|> emptyLine)
- endOfInput
- return $ catMaybes xs
+extMap ∷ Parser [ (MIMEType, [Text]) ]
+extMap = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)
where
isSpc ∷ Char → Bool
isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is
-- surely generated using this function.
serializeExtMap ∷ ExtMap → String → String → String
-serializeExtMap extMap moduleName variableName
+serializeExtMap em moduleName variableName
= let hsModule = Module (⊥) (ModuleName moduleName) modPragma
Nothing (Just exports) imports decls
modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
comment ⧺ prettyPrint hsModule ⧺ "\n"
where
records ∷ [Exp]
- records = map record $ M.assocs extMap
+ records = map record $ M.assocs em
record ∷ (Text, MIMEType) → Exp
record (ext, mime)
import qualified Data.Text as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.RFC2231
import Prelude.Unicode
"prologue"
epilogue ∷ Parser ()
-epilogue = ( (string "--" <?> "suffix")
- *>
- crlf
- *>
- endOfInput
- )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
<?>
"epilogue"
Nothing
→ throwError "Content-Disposition is missing"
Just str
- → case parseOnly p $ A.toByteString str of
+ → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
Right d → return d
Left err → throwError $ "malformed Content-Disposition: "
⧺ A.toString str
⧺ ": "
⧺ err
- where
- p = do dispo ← contentDisposition
- endOfInput
- return dispo
contentDisposition ∷ Parser ContDispo
contentDisposition
Nothing
→ return Nothing
Just str
- → case parseOnly p $ A.toByteString str of
+ → case parseOnly (finishOff mimeType) $ A.toByteString str of
Right d → return $ Just d
Left err → throwError $ "malformed Content-Type: "
⧺ A.toString str
⧺ ": "
⧺ err
- where
- p = do t ← mimeType
- endOfInput
- return t
getBody ∷ MonadError String m
⇒ Ascii
-- use this module directly.
module Network.HTTP.Lucu.Parser
( atMost
+ , finishOff
)
where
import Control.Applicative
import Control.Applicative.Unicode
+import Control.Monad.Unicode
+import Data.Attoparsec
+import Prelude.Unicode
-- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
-- @n@ times.
-atMost ∷ Alternative f ⇒ Int → f a → f [a]
+atMost ∷ Alternative f ⇒ Int → f α → f [α]
{-# INLINE atMost #-}
atMost 0 _ = pure []
atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
<|>
pure []
+
+-- |@'finishOff' p@ is equivalent to @p '>>=' \a -> endOfInput '>>'
+-- 'return' a@.
+finishOff ∷ Parser α → Parser α
+{-# INLINE finishOff #-}
+finishOff = ((endOfInput *>) ∘ return =≪)
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.MultipartForm
+import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Response
Nothing
→ return []
Just accept
- → case P.parseOnly p (A.toByteString accept) of
+ → case P.parseOnly (finishOff mimeTypeList) (A.toByteString accept) of
Right xs → return xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept: " ⊕ A.toText accept
- where
- p = do xs ← mimeTypeList
- P.endOfInput
- return xs
-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
-- value of request header \"Accept-Encoding\". The list is sorted in
-- identity のみが許される。
return [("identity", Nothing)]
else
- case P.parseOnly p (A.toByteString ae) of
+ case P.parseOnly (finishOff acceptEncodingList) (A.toByteString ae) of
Right xs → return $ map toTuple $ reverse $ sort xs
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Accept-Encoding: " ⊕ A.toText ae
where
- p = do xs ← acceptEncodingList
- P.endOfInput
- return xs
-
toTuple (AcceptEncoding {..})
= (aeEncoding, aeQValue)
Nothing
→ return Nothing
Just cType
- → case P.parseOnly p (A.toByteString cType) of
+ → case P.parseOnly (finishOff mimeType) (A.toByteString cType) of
Right t → return $ Just t
Left _ → abort $ mkAbortion' BadRequest
$ "Unparsable Content-Type: " ⊕ A.toText cType
- where
- p = do t ← mimeType
- P.endOfInput
- return t
-- |Return the value of request header \"Authorization\" as
-- 'AuthCredential'.
Nothing
→ return Nothing
Just auth
- → case P.parseOnly p (A.toByteString auth) of
+ → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
Right ac → return $ Just ac
Left _ → return Nothing
- where
- p = do ac ← authCredential
- P.endOfInput
- return ac
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. If this is a GET or HEAD request, a found entity means
-- If-Match があればそれを見る。
ifMatch ← getHeader "If-Match"
case ifMatch of
- Nothing → return ()
- Just value → if value ≡ "*" then
- return ()
- else
- case P.parseOnly p (A.toByteString value) of
- Right tags
- -- tags の中に一致するものが無ければ
- -- PreconditionFailed で終了。
- → when ((¬) (any (≡ tag) tags))
- $ abort
- $ mkAbortion' PreconditionFailed
- $ "The entity tag doesn't match: " ⊕ A.toText value
- Left _
- → abort $ mkAbortion' BadRequest
- $ "Unparsable If-Match: " ⊕ A.toText value
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ return ()
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ A.toText value
let statusForNoneMatch
= if method ≡ GET ∨ method ≡ HEAD then
-- If-None-Match があればそれを見る。
ifNoneMatch ← getHeader "If-None-Match"
case ifNoneMatch of
- Nothing → return ()
- Just value → if value ≡ "*" then
- abort $ mkAbortion' statusForNoneMatch
- $ "The entity tag matches: *"
- else
- case P.parseOnly p (A.toByteString value) of
- Right tags
- → when (any (≡ tag) tags)
- $ abort
- $ mkAbortion' statusForNoneMatch
- $ "The entity tag matches: " ⊕ A.toText value
- Left _
- → abort $ mkAbortion' BadRequest
- $ "Unparsable If-None-Match: " ⊕ A.toText value
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ A.toText value
driftTo ReceivingBody
- where
- p = do xs ← eTagList
- P.endOfInput
- return xs
-- |Tell the system that the 'Resource' found an entity for the
-- request URI. The only difference from 'foundEntity' is that
projects / Lucu.git / commitdiff