From: PHO <pho@cielonegro.org>
Date: Tue, 1 Nov 2011 14:40:51 +0000 (+0900)
Subject: code cleanup
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=e49345ce5e6c0190c826d130d51ec42ee9f09a67;p=Lucu.git

code cleanup
---

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index 76df183..d871000 100644
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -20,6 +20,7 @@ import Data.Ascii (Ascii, AsciiBuilder)
 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
@@ -52,15 +53,9 @@ printETag et
 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
diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index ab0e065..1aebc9f 100644
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -22,6 +22,7 @@ import Data.Attoparsec.Char8 as P
 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)
@@ -59,15 +60,9 @@ printMIMEType (MIMEType maj min params)
 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
diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index d8bca8e..10c11e4 100644
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -31,6 +31,7 @@ import Language.Haskell.Exts.Extension
 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
 
@@ -39,16 +40,16 @@ type ExtMap = Map Text MIMEType
 
 -- |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
@@ -60,10 +61,8 @@ parseExtMapFile fpath
            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'
@@ -116,7 +115,7 @@ compile = go (∅) ∘ concat ∘ map tr
 -- 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) ] ]
@@ -144,7 +143,7 @@ serializeExtMap extMap moduleName variableName
         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)
diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index a04b4a0..16d8f28 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -39,6 +39,7 @@ import Data.Text (Text)
 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
@@ -131,12 +132,7 @@ prologue boundary
       "prologue"
 
 epilogue ∷ Parser ()
-epilogue = ( (string "--" <?> "suffix")
-             *>
-             crlf
-             *>
-             endOfInput
-           )
+epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
            <?>
            "epilogue"
 
@@ -172,16 +168,12 @@ getContDispo hdrs
         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
@@ -196,16 +188,12 @@ getContType hdrs
         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
diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index ce43718..b31d4b8 100644
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -5,16 +5,26 @@
 -- 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 =≪)
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index aee29d5..474f79a 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -169,6 +169,7 @@ import qualified Network.HTTP.Lucu.Headers as H
 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
@@ -256,14 +257,10 @@ getAccept
            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
@@ -288,15 +285,11 @@ getAcceptEncoding
                       -- 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)
 
@@ -316,14 +309,10 @@ getContentType
            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'.
@@ -334,13 +323,9 @@ getAuthorization
            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
@@ -395,21 +380,23 @@ foundETag tag
          -- 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
@@ -420,26 +407,24 @@ foundETag tag
          -- 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