{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.MultipartForm
    ( FormData(..)
    , multipartFormP
    )
    where
import Control.Applicative hiding (many)
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LS
import Data.Char
import Data.List
import Data.Map (Map)
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.Parser.Http
import Network.HTTP.Lucu.RFC2231
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Utils
import Prelude.Unicode

-- |This data type represents a form value and possibly an uploaded
-- file name.
data FormData
    = FormData {
        fdFileName ∷ Maybe Text
      , fdContent  ∷ LS.ByteString
      }

data Part
    = Part {
        ptHeaders   ∷ Headers
      , ptContDispo ∷ ContDispo
      , ptBody      ∷ LS.ByteString
      }

instance HasHeaders Part where
    getHeaders = ptHeaders
    setHeaders pt hs = pt { ptHeaders = hs }

data ContDispo
    = ContDispo {
        dType   ∷ !CIAscii
      , dParams ∷ !(Map CIAscii Text)
      }

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

multipartFormP ∷ Ascii → Parser [(Text, FormData)]
multipartFormP boundary
    = do parts ← many $ try $ partP boundary
         _     ← string "--"
         _     ← string $ A.toByteString boundary
         _     ← string "--"
         crlf
         catMaybes <$> mapM partToFormPair parts

partP ∷ Ascii → Parser Part
partP boundary
    = do _    ← string "--"
         _    ← string $ A.toByteString boundary
         crlf
         hs   ← headersP
         d    ← getContDispo hs
         body ← bodyP boundary
         return $ Part hs d body

bodyP ∷ Ascii → Parser LS.ByteString
bodyP boundary
    = do body ← manyCharsTill anyChar $
                    try $
                    do crlf
                       _ ← string "--"
                       _ ← string $ A.toByteString boundary
                       return ()
         crlf
         return body

partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
{-# INLINEABLE partToFormPair #-}
partToFormPair pt
    | dType (ptContDispo pt) ≡ "form-data"
        = do name  ← partName pt
             let fname = partFileName pt
             let fd    = FormData {
                           fdFileName = fname
                         , fdContent  = ptBody pt
                         }
             return $ Just (name, fd)
    | otherwise
        = return Nothing

partName ∷ Monad m ⇒ Part → m Text
{-# INLINEABLE partName #-}
partName pt
    = case find ((≡ "name") ∘ fst) $ dParams $ ptContDispo pt of
        Just (_, name)
            → return name
        Nothing
            → fail ("form-data without name: " ⧺
                    A.toString (printContDispo $ ptContDispo pt))

partFileName ∷ Part → Maybe Text
{-# INLINEABLE partFileName #-}
partFileName pt
    = snd <$> (find ((== "filename") ∘ fst) $ dParams $ ptContDispo pt)

getContDispo ∷ Monad m ⇒ Headers → m ContDispo
{-# INLINEABLE getContDispo #-}
getContDispo hdr
    = case getHeader "Content-Disposition" hdr of
        Nothing
            → fail ("There is a part without Content-Disposition in the multipart/form-data.")
        Just str
            → let p  = do d ← contDispoP
                          endOfInput
                          return d
                  bs = A.toByteString str
              in
                case parseOnly p bs of
                  Right  d → return d
                  Left err → fail (concat [ "Unparsable Content-Disposition: "
                                          , BS.unpack bs
                                          , ": "
                                          , err
                                          ])

contDispoP ∷ Parser ContDispo
contDispoP = try $
             do dispoType ← A.toCIAscii <$> token
                params    ← many paramP
                return $ ContDispo dispoType params
    where
      paramP ∷ Parser (CIAscii, Ascii)
      paramP = do skipMany lws
                  _     ← char ';'
                  skipMany lws
                  name  ← A.toCIAscii <$> token
                  _     ← char '='
                  value ← token <|> quotedStr
                  return (name, value)