{-# LANGUAGE
    UnboxedTuples
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.MultipartForm
    ( FormData(..)
    , multipartFormP
    )
    where

import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.Char
import           Data.List
import           Network.HTTP.Lucu.Abortion
import           Network.HTTP.Lucu.Headers
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Response
import           Network.HTTP.Lucu.Utils


data Part = Part Headers L8.ByteString

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

instance HasHeaders Part where
    getHeaders (Part hs _)    = hs
    setHeaders (Part _  b) hs = Part hs b


data ContDispo = ContDispo String [(String, String)]

instance Show ContDispo where
    show (ContDispo dType dParams)
        = dType ++
          if null dParams then
              ""
          else
              "; " ++ joinWith "; " (map showPair dParams)
        where
          showPair :: (String, String) -> String
          showPair (name, value)
              = name ++ "=" ++ if any (not . isToken) value then
                                   quoteStr value
                               else
                                   value


multipartFormP :: String -> Parser [(String, FormData)]
multipartFormP boundary
    = do parts <- many (partP boundary)
         _     <- string "--"
         _     <- string boundary
         _     <- string "--"
         _     <- crlf
         eof
         return $ map partToFormPair parts


partP :: String -> Parser Part
partP boundary
    = do _    <- string "--"
         _    <- string boundary
         _    <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
         hs   <- headersP
         body <- bodyP boundary
         return $ Part hs body


bodyP :: String -> Parser L8.ByteString
bodyP boundary
    = do body <- manyChar $
                 do notFollowedBy $ ( crlf         >>
                                      string "--"  >>
                                      string boundary )
                    anyChar
         _    <- crlf
         return body


partToFormPair :: Part -> (String, FormData)
partToFormPair part@(Part _ body)
    = let name  = partName part
          fname = partFileName part
          fd    = FormData {
                    fdFileName = fname
                  , fdContent  = body
                  }
      in (name, fd)

partName :: Part -> String
partName = getName' . getContDispoFormData
    where
      getName' :: ContDispo -> String
      getName' dispo@(ContDispo _ dParams)
          = case find ((== "name") . map toLower . fst) dParams of
              Just (_, name) -> name
              Nothing   
                  -> abortPurely BadRequest []
                     (Just $ "form-data without name: " ++ show dispo)


partFileName :: Part -> Maybe String
partFileName = getFileName' . getContDispoFormData
    where
      getFileName' :: ContDispo -> Maybe String
      getFileName' (ContDispo _ dParams)
          = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
               return fileName

getContDispoFormData :: Part -> ContDispo
getContDispoFormData part
    = let dispo@(ContDispo dType _) = getContDispo part
      in
        if map toLower dType == "form-data" then
            dispo
        else
            abortPurely BadRequest []
            (Just $ "Content-Disposition type is not form-data: " ++ dType)


getContDispo :: Part -> ContDispo
getContDispo part
    = case getHeader (C8.pack "Content-Disposition") part of
        Nothing  
            -> abortPurely BadRequest []
               (Just "There is a part without Content-Disposition in the multipart/form-data.")
        Just dispoStr
            -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                 (# Success dispo, _ #)
                     -> dispo
                 (# _, _ #)
                     -> abortPurely BadRequest []
                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)


contDispoP :: Parser ContDispo
contDispoP = do dispoType <- token
                params    <- allowEOF $ many paramP
                return $ ContDispo dispoType params
    where
      paramP :: Parser (String, String)
      paramP = do _     <- many lws
                  _     <- char ';'
                  _     <- many lws
                  name  <- token
                  _     <- char '='
                  value <- token <|> quotedStr
                  return (name, value)