Code clean-up using convertible-text.

[Lucu.git] / Network / HTTP / Lucu / MultipartForm.hs

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index a28a80461ede0d502d4de626121731c232c940cc..2d1b3470f1cf62a797a1336c183e8d54999589b9 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,17 +1,18 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , FlexibleInstances

   , FlexibleContexts
   , FlexibleContexts

+  , MultiParamTypeClasses

   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables
   , OverloadedStrings
   , QuasiQuotes
   , RecordWildCards
   , ScopedTypeVariables

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
 -- |Parse \"multipart/form-data\" based on RFC 2388:
 -- <http://tools.ietf.org/html/rfc2388>
   , UnicodeSyntax
   , ViewPatterns
   #-}
 -- |Parse \"multipart/form-data\" based on RFC 2388:
 -- <http://tools.ietf.org/html/rfc2388>

---
--- You usually don't have to use this module directly.

 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)
     , parseMultipartFormData
 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)
     , parseMultipartFormData


@@ -19,24 +20,24 @@ module Network.HTTP.Lucu.MultipartForm
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))
     where
 import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))

-import Control.Monad.Error
+import Control.Monad.Error (MonadError, throwError)

 import Control.Monad.Unicode
 import Control.Monad.Unicode

-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt

 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search

-import Data.Foldable
-import Data.List
-import qualified Data.Map as M
+import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Ascii ()
+import Data.Convertible.Utils
+import Data.List (intercalate)

 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import Data.Sequence.Unicode hiding ((∅))

 import Data.Text (Text)
 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 (MIMEType)
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.MIMEParams
 import Network.HTTP.Lucu.MIMEType (MIMEType)


@@ -44,6 +45,8 @@ import qualified Network.HTTP.Lucu.MIMEType as MT
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.MIMEType.TH
 import Network.HTTP.Lucu.Parser
 import Network.HTTP.Lucu.Parser.Http

+import Network.HTTP.Lucu.Utils
+import Prelude hiding (lookup, mapM)

 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file
 import Prelude.Unicode
 
 -- |'FormData' represents a form value and possibly an uploaded file


@@ -71,12 +74,18 @@ data ContDispo
       , dParams ∷ !MIMEParams
       }
 
       , dParams ∷ !MIMEParams
       }
 

-printContDispo ∷ ContDispo → Ascii
-printContDispo d
-    = A.fromAsciiBuilder
-      ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
-        ⊕
-        printMIMEParams (dParams d) )
+instance ConvertSuccess ContDispo Ascii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
+
+instance ConvertSuccess ContDispo AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (ContDispo {..})
+        = cs dType ⊕ cs dParams
+
+deriveAttempts [ ([t| ContDispo |], [t| Ascii        |])
+               , ([t| ContDispo |], [t| AsciiBuilder |])
+               ]

 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following
 
 -- |Parse \"multipart/form-data\" and return either @'Left' err@ or
 -- @'Right' result@. Note that there are currently the following


@@ -126,7 +135,7 @@ prologue ∷ Ascii → Parser ()
 prologue boundary
     = ( (string "--" <?> "prefix")
         *>
 prologue boundary
     = ( (string "--" <?> "prefix")
         *>

-        (string (A.toByteString boundary) <?> "boundary")
+        (string (cs boundary) <?> "boundary")

         *>
         pure ()
       )
         *>
         pure ()
       )


@@ -170,16 +179,16 @@ getContDispo hdrs
         Nothing
             → throwError "Content-Disposition is missing"
         Just str
         Nothing
             → throwError "Content-Disposition is missing"
         Just str

-            → case parseOnly (finishOff contentDisposition) $ A.toByteString str of
+            → case parseOnly (finishOff contentDisposition) $ cs str of

                  Right  d → return d
                  Left err → throwError $ "malformed Content-Disposition: "
                  Right  d → return d
                  Left err → throwError $ "malformed Content-Disposition: "

-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
+                                       â\8a\95 cs str
+                                       â\8a\95 ": "
+                                       â\8a\95 err

 
 contentDisposition ∷ Parser ContDispo
 contentDisposition
 
 contentDisposition ∷ Parser ContDispo
 contentDisposition

-    = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
+    = (ContDispo <$> (cs <$> token) ⊛ mimeParams)

       <?>
       "contentDisposition"
 
       <?>
       "contentDisposition"
 


@@ -190,19 +199,19 @@ getContType hdrs
         Nothing
             → return Nothing
         Just str
         Nothing
             → return Nothing
         Just str

-            → case parseOnly (finishOff MT.mimeType) $ A.toByteString str of
+            → case parseOnly (finishOff MT.mimeType) $ cs str of

                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "
                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "

-                                       ⧺ A.toString str
-                                       ⧺ ": "
-                                       ⧺ err
+                                       â\8a\95 cs str
+                                       â\8a\95 ": "
+                                       â\8a\95 err

 
 getBody ∷ MonadError String m
         ⇒ Ascii
         → LS.ByteString
         → m (LS.ByteString, LS.ByteString)
 {-# INLINEABLE getBody #-}
 
 getBody ∷ MonadError String m
         ⇒ Ascii
         → LS.ByteString
         → m (LS.ByteString, LS.ByteString)
 {-# INLINEABLE getBody #-}

-getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src
+getBody (("\r\n--" ⊕) ∘ cs → boundary) src

     = case breakOn boundary src of
         (before, after)
             | LS.null after
     = case breakOn boundary src of
         (before, after)
             | LS.null after


@@ -226,24 +235,20 @@ partToFormPair pt@(Part {..})
              return (name, fd)
     | otherwise
         = throwError $ "disposition type is not \"form-data\": "
              return (name, fd)
     | otherwise
         = throwError $ "disposition type is not \"form-data\": "

-                     ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)
+                     â\8a\95 cs (dType ptContDispo)

 
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})
 
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})

-    = case M.lookup "name" params of
+    = case lookup "name" $ dParams ptContDispo of

         Just name
         Just name

-            → case A.fromText name of
-                 Just a  → return a
-                 Nothing → throwError $ "Non-ascii part name: "
-                                      ⧺ T.unpack name
+            → case ca name of
+                 Success a → return a
+                 Failure e → throwError $ show e

         Nothing
             → throwError $ "form-data without name: "
         Nothing
             → throwError $ "form-data without name: "

-                         ⧺ A.toString (printContDispo ptContDispo)
-    where
-      params = case dParams ptContDispo of
-                 MIMEParams m → m
+                         ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo

 
 partFileName ∷ Part → Maybe Text
 
 partFileName ∷ Part → Maybe Text

-partFileName (dParams ∘ ptContDispo → MIMEParams m)
-    = M.lookup "filename" m
+partFileName (ptContDispo → ContDispo {..})
+    = lookup "filename" dParams