module Network.HTTP.Lucu.MultipartForm
    ( 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 String

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, String)]
multipartFormP boundary
    = do parts <- many (partP boundary)
         string "--"
         string boundary
         string "--"
         crlf
         eof
         return $ map partToPair 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 String
bodyP boundary
    = do body <- many $
                 do notFollowedBy $ do crlf
                                       string "--"
                                       string boundary
                    anyChar
         crlf
         return body


partToPair :: Part -> (String, String)
partToPair part@(Part _ body)
    = 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, _ #)
                     -> (getName dispo, body)
                 (# _, _ #)
                     -> abortPurely BadRequest []
                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
      where
        getName :: ContDispo -> String
        getName dispo@(ContDispo dType dParams)
            | map toLower dType == "form-data"
                = case find ((== "name") . map toLower . fst) dParams of
                    Just (_, name) -> name
                    Nothing   
                        -> abortPurely BadRequest []
                           (Just $ "form-data without name: " ++ show dispo)
            | otherwise
                = abortPurely BadRequest []
                  (Just $ "Content-Disposition type is not form-data: " ++ dType)


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)