Merge branch 'convertible'

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

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

+  , FlexibleInstances

   , FlexibleContexts
   , FlexibleContexts

+  , MultiParamTypeClasses

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

+  , TemplateHaskell

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -19,20 +22,22 @@ import Control.Applicative hiding (many)
 import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad.Error (MonadError, throwError)
 import Control.Monad.Unicode
 import Control.Applicative.Unicode hiding ((∅))
 import Control.Monad.Error (MonadError, throwError)
 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.Collections
 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.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.Text (Text)
 import Data.List (intercalate)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 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)


@@ -69,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


@@ -124,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 ()
       )


@@ -168,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"
 


@@ -188,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


@@ -224,20 +235,19 @@ 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 {..})
     = case lookup "name" $ dParams ptContDispo of
         Just name
 
 partName ∷ MonadError String m ⇒ Part → m Ascii
 {-# INLINEABLE partName #-}
 partName (Part {..})
     = case lookup "name" $ dParams ptContDispo of
         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)
+                         â\8a\95 convertSuccessVia ((â\8a¥) â\88· Ascii) ptContDispo

 
 partFileName ∷ Part → Maybe Text
 partFileName (ptContDispo → ContDispo {..})
 
 partFileName ∷ Part → Maybe Text
 partFileName (ptContDispo → ContDispo {..})