{-# LANGUAGE
    DoAndIfThenElse
  , FlexibleInstances
  , FlexibleContexts
  , MultiParamTypeClasses
  , OverloadedStrings
  , QuasiQuotes
  , RecordWildCards
  , ScopedTypeVariables
  , TemplateHaskell
  , UnicodeSyntax
  , ViewPatterns
  #-}
-- |Parse \"multipart/form-data\" based on RFC 2388:
-- <http://tools.ietf.org/html/rfc2388>
module Network.HTTP.Lucu.MultipartForm
    ( FormData(..)
    , parseMultipartFormData
    )
    where
import Control.Applicative hiding (many)
import Control.Applicative.Unicode hiding ((∅))
import Control.Monad.Error (MonadError, throwError)
import Control.Monad.Unicode
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.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.Default
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid.Unicode
import Data.Sequence (Seq)
import Data.Text (Text)
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.Utils
import Prelude hiding (lookup, mapM)
import Prelude.Unicode

-- |'FormData' represents a form value and possibly an uploaded file
-- name.
data FormData
    = FormData {
        -- | @'Nothing'@ for non-file values.
        fdFileName ∷ !(Maybe Text)
        -- | MIME Type of this value, defaulted to \"text/plain\".
      , fdMIMEType ∷ !MIMEType
        -- | The form value.
      , fdContent  ∷ !(LS.ByteString)
      }

data Part
    = Part {
        ptContDispo ∷ !ContDispo
      , ptContType  ∷ !MIMEType
      , ptBody      ∷ !LS.ByteString
      }

data ContDispo
    = ContDispo {
        dType   ∷ !CIAscii
      , dParams ∷ !MIMEParams
      }

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\" to a list of @(name,
-- formData)@. Note that there are currently the following
-- limitations:
--
--   * Multiple files embedded as \"multipart/mixed\" within the
--     \"multipart/form-data\" won't be decomposed.
--
--   * \"Content-Transfer-Encoding\" is always ignored.
--
--   * 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 this
--     function currently doesn't decode them.
parseMultipartFormData ∷ Ascii -- ^boundary
                       → LS.ByteString -- ^input
                       → Either String [(Ascii, FormData)]
parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go
    where
      go ∷ (Functor m, MonadError String m)
         ⇒ LS.ByteString
         → m [Part]
      {-# INLINEABLE go #-}
      go src
          = case LP.parse (prologue boundary) src of
              LP.Done src' _
                  → go' src' (∅)
              LP.Fail _ eCtx e
                  → throwError $ "Unparsable multipart/form-data: "
                               ⧺ intercalate ", " eCtx
                               ⧺ ": "
                               ⧺ e
      go' ∷ (Functor m, MonadError String m)
          ⇒ LS.ByteString
          → Seq Part
          → m [Part]
      {-# INLINEABLE go' #-}
      go' src xs
          = case LP.parse epilogue src of
              LP.Done _ _
                  → return $ toList xs
              LP.Fail _ _ _
                  → do (src', x) ← parsePart boundary src
                       go' src' $ xs ⊳ x

prologue ∷ Ascii → Parser ()
prologue boundary
    = ( (string "--" <?> "prefix")
        *>
        (string (cs boundary) <?> "boundary")
        *>
        pure ()
      )
      <?>
      "prologue"

epilogue ∷ Parser ()
epilogue = finishOff ((string "--" <?> "suffix") *> crlf)
           <?>
           "epilogue"

parsePart ∷ (Functor m, MonadError String m)
          ⇒ Ascii
          → LS.ByteString
          → m (LS.ByteString, Part)
{-# INLINEABLE parsePart #-}
parsePart boundary src
    = case LP.parse partHeader src of
        LP.Done src' hdrs
            → do dispo ← getContDispo hdrs
                 cType ← fromMaybe defaultCType <$> getContType hdrs
                 (body, src'')
                       ← getBody boundary src'
                 return (src'', Part dispo cType body)
        LP.Fail _ eCtx e
            → throwError $ "unparsable part: "
                         ⧺ intercalate ", " eCtx
                         ⧺ ": "
                         ⧺ e
      where
        defaultCType ∷ MIMEType
        defaultCType = [mimeType| text/plain |]

partHeader ∷ Parser Headers
{-# INLINE partHeader #-}
partHeader = crlf *> def

getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
{-# INLINEABLE getContDispo #-}
getContDispo hdrs
    = case getHeader "Content-Disposition" hdrs of
        Nothing
            → throwError "Content-Disposition is missing"
        Just str
            → case parseOnly (finishOff contentDisposition) $ cs str of
                 Right  d → return d
                 Left err → throwError $ "malformed Content-Disposition: "
                                       ⊕ cs str
                                       ⊕ ": "
                                       ⊕ err

contentDisposition ∷ Parser ContDispo
{-# INLINEABLE contentDisposition #-}
contentDisposition
    = (ContDispo <$> (cs <$> token) ⊛ def)
      <?>
      "contentDisposition"

getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
{-# INLINEABLE getContType #-}
getContType hdrs
    = case getHeader "Content-Type" hdrs of
        Nothing
            → return Nothing
        Just str
            → case parseOnly (finishOff def) $ cs str of
                 Right  d → return $ Just d
                 Left err → throwError $ "malformed Content-Type: "
                                       ⊕ cs str
                                       ⊕ ": "
                                       ⊕ err

getBody ∷ MonadError String m
        ⇒ Ascii
        → LS.ByteString
        → m (LS.ByteString, LS.ByteString)
{-# INLINEABLE getBody #-}
getBody (("\r\n--" ⊕) ∘ cs → boundary) src
    = case breakOn boundary src of
        (before, after)
            | LS.null after
                → throwError "missing boundary"
            | otherwise
                → let len    = fromIntegral $ BS.length boundary
                      after' = LS.drop len after
                  in
                    return (before, after')

partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)
{-# INLINEABLE partToFormPair #-}
partToFormPair pt@(Part {..})
    | dType ptContDispo ≡ "form-data"
        = do name ← partName pt
             let fd = FormData {
                        fdFileName = partFileName pt
                      , fdMIMEType = ptContType
                      , fdContent  = ptBody
                      }
             return (name, fd)
    | otherwise
        = throwError $ "disposition type is not \"form-data\": "
                     ⊕ cs (dType ptContDispo)

partName ∷ MonadError String m ⇒ Part → m Ascii
{-# INLINEABLE partName #-}
partName (Part {..})
    = case lookup "name" $ dParams ptContDispo of
        Just name
            → case ca name of
                 Success a → return a
                 Failure e → throwError $ show e
        Nothing
            → throwError $ "form-data without name: "
                         ⊕ convertSuccessVia ((⊥) ∷ Ascii) ptContDispo

partFileName ∷ Part → Maybe Text
partFileName (ptContDispo → ContDispo {..})
    = lookup "filename" dParams