{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.MultipartForm
    ( FormData(..)
    , multipartFormP
    )
    where
import Control.Applicative hiding (many)
import Data.Ascii (Ascii, CIAscii)
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.Map (Map)
import qualified Data.Map as M
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 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 (Part {..})
    = case M.lookup "name" $ dParams ptContDispo of
        Just name
            → return name
        Nothing
            → fail ("form-data without name: " ⧺
                    A.toString (printContDispo ptContDispo))

partFileName ∷ Part → Maybe Text
{-# INLINEABLE partFileName #-}
partFileName (Part {..})
    = M.lookup "filename" $ dParams ptContDispo

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 = do dispoType ← A.toCIAscii <$> token
                params    ← paramsP
                return $ ContDispo dispoType params