{-# LANGUAGE
    DoAndIfThenElse
  , FlexibleContexts
  , OverloadedStrings
  , QuasiQuotes
  , RecordWildCards
  , ScopedTypeVariables
  , 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)
import qualified Data.Ascii as A
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 qualified Data.Text as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.MIMEType (MIMEType)
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.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
      }

-- FIXME
printContDispo ∷ ContDispo → Ascii
printContDispo d
    = A.fromAsciiBuilder
      ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
        ⊕
        cs (dParams d) )

-- |Parse \"multipart/form-data\" and return either @'Left' err@ or
-- @'Right' result@. 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 they won't
--   be decoded.
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 (A.toByteString 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
partHeader = crlf *> headers

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) $ A.toByteString str of
                 Right  d → return d
                 Left err → throwError $ "malformed Content-Disposition: "
                                       ⧺ A.toString str
                                       ⧺ ": "
                                       ⧺ err

contentDisposition ∷ Parser ContDispo
contentDisposition
    = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)
      <?>
      "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 MT.mimeType) $ A.toByteString str of
                 Right  d → return $ Just d
                 Left err → throwError $ "malformed Content-Type: "
                                       ⧺ A.toString str
                                       ⧺ ": "
                                       ⧺ err

getBody ∷ MonadError String m
        ⇒ Ascii
        → LS.ByteString
        → m (LS.ByteString, LS.ByteString)
{-# INLINEABLE getBody #-}
getBody (("\r\n--" ⊕) ∘ A.toByteString → 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\": "
                     ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)

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
        Nothing
            → throwError $ "form-data without name: "
                         ⧺ A.toString (printContDispo ptContDispo)

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