    module Happstack.Server.Internal.Multipart where

    import           Control.Monad                   (MonadPlus(mplus))
    import           Data.ByteString.Base64.Lazy
    import qualified Data.ByteString.Lazy.Char8      as L
    import           Data.ByteString.Lazy.Internal   (ByteString(Chunk, Empty))
    import qualified Data.ByteString.Lazy.UTF8       as LU
    import qualified Data.ByteString.Char8           as S
    import           Data.Maybe                      (fromMaybe)
    import           Data.Int                        (Int64)
    import           Text.ParserCombinators.Parsec   (parse)
    import           Happstack.Server.Internal.Types (Input(..))
    import           Happstack.Server.Internal.RFC822Headers
    import           System.IO                        (Handle, hClose, openBinaryTempFile)

    -- | similar to the normal 'span' function, except the predicate gets the whole rest of the lazy bytestring, not just one character.
    --
    -- TODO: this function has not been profiled.
    spanS :: (L.ByteString -> Bool) -> L.ByteString -> (L.ByteString, L.ByteString)
    spanS :: (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
    spanS ByteString -> Bool
    f ByteString
    cs0 = Int -> ByteString -> (ByteString, ByteString)
    spanS' Int
    0 ByteString
    cs0
      where spanS' :: Int -> ByteString -> (ByteString, ByteString)
    spanS' Int
    _ ByteString
    Empty = (ByteString
    Empty, ByteString
    Empty)
            spanS' Int
    n bs :: ByteString
    bs@(Chunk StrictByteString
    c ByteString
    cs)
                | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= StrictByteString -> Int
    S.length StrictByteString
    c =
                    let (ByteString
    x, ByteString
    y) = Int -> ByteString -> (ByteString, ByteString)
    spanS' Int
    0 ByteString
    cs
                    in (StrictByteString -> ByteString -> ByteString
    Chunk StrictByteString
    c ByteString
    x, ByteString
    y)
                | Bool -> Bool
    not (ByteString -> Bool
    f (StrictByteString -> ByteString -> ByteString
    Chunk (Int -> StrictByteString -> StrictByteString
    S.drop Int
    n StrictByteString
    c) ByteString
    cs)) = Int64 -> ByteString -> (ByteString, ByteString)
    L.splitAt (Int -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    n) ByteString
    bs
                | Bool
    otherwise = (Int -> ByteString -> (ByteString, ByteString)
    spanS' (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ByteString
    bs)
    {-# INLINE spanS #-}

    takeWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
    takeWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
    takeWhileS ByteString -> Bool
    f ByteString
    cs0 = Int -> ByteString -> ByteString
    takeWhile' Int
    0 ByteString
    cs0
      where takeWhile' :: Int -> ByteString -> ByteString
    takeWhile' Int
    _ ByteString
    Empty = ByteString
    Empty
            takeWhile' Int
    n bs :: ByteString
    bs@(Chunk StrictByteString
    c ByteString
    cs)
                | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    >= StrictByteString -> Int
    S.length StrictByteString
    c = StrictByteString -> ByteString -> ByteString
    Chunk StrictByteString
    c (Int -> ByteString -> ByteString
    takeWhile' Int
    0 ByteString
    cs)
                | Bool -> Bool
    not (ByteString -> Bool
    f (StrictByteString -> ByteString -> ByteString
    Chunk (Int -> StrictByteString -> StrictByteString
    S.drop Int
    n StrictByteString
    c) ByteString
    cs)) = (StrictByteString -> ByteString -> ByteString
    Chunk (Int -> StrictByteString -> StrictByteString
    S.take Int
    n StrictByteString
    c) ByteString
    Empty)
                | Bool
    otherwise = Int -> ByteString -> ByteString
    takeWhile' (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) ByteString
    bs

    crlf :: L.ByteString
    crlf :: ByteString
    crlf = String -> ByteString
    L.pack String
    "\r\n"

    crlfcrlf :: L.ByteString
    crlfcrlf :: ByteString
    crlfcrlf = String -> ByteString
    L.pack String
    "\r\n\r\n"

    blankLine :: L.ByteString
    blankLine :: ByteString
    blankLine = String -> ByteString
    L.pack String
    "\r\n\r\n"

    dropWhileS :: (L.ByteString -> Bool) -> L.ByteString -> L.ByteString
    dropWhileS :: (ByteString -> Bool) -> ByteString -> ByteString
    dropWhileS ByteString -> Bool
    f ByteString
    cs0 = ByteString -> ByteString
    dropWhile' ByteString
    cs0
        where dropWhile' :: ByteString -> ByteString
    dropWhile' ByteString
    bs
                  | ByteString -> Bool
    L.null ByteString
    bs  = ByteString
    bs
                  | ByteString -> Bool
    f ByteString
    bs       = ByteString -> ByteString
    dropWhile' (Int64 -> ByteString -> ByteString
    L.drop Int64
    1 ByteString
    bs)
                  | Bool
    otherwise  = ByteString
    bs

    data BodyPart = BodyPart L.ByteString L.ByteString  -- ^ headers body
        deriving (BodyPart -> BodyPart -> Bool
    (BodyPart -> BodyPart -> Bool)
    -> (BodyPart -> BodyPart -> Bool) -> Eq BodyPart
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: BodyPart -> BodyPart -> Bool
    == :: BodyPart -> BodyPart -> Bool
    $c/= :: BodyPart -> BodyPart -> Bool
    /= :: BodyPart -> BodyPart -> Bool
    Eq, Eq BodyPart
    Eq BodyPart =>
    (BodyPart -> BodyPart -> Ordering)
    -> (BodyPart -> BodyPart -> Bool)
    -> (BodyPart -> BodyPart -> Bool)
    -> (BodyPart -> BodyPart -> Bool)
    -> (BodyPart -> BodyPart -> Bool)
    -> (BodyPart -> BodyPart -> BodyPart)
    -> (BodyPart -> BodyPart -> BodyPart)
    -> Ord BodyPart
    BodyPart -> BodyPart -> Bool
    BodyPart -> BodyPart -> Ordering
    BodyPart -> BodyPart -> BodyPart
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: BodyPart -> BodyPart -> Ordering
    compare :: BodyPart -> BodyPart -> Ordering
    $c< :: BodyPart -> BodyPart -> Bool
    < :: BodyPart -> BodyPart -> Bool
    $c<= :: BodyPart -> BodyPart -> Bool
    <= :: BodyPart -> BodyPart -> Bool
    $c> :: BodyPart -> BodyPart -> Bool
    > :: BodyPart -> BodyPart -> Bool
    $c>= :: BodyPart -> BodyPart -> Bool
    >= :: BodyPart -> BodyPart -> Bool
    $cmax :: BodyPart -> BodyPart -> BodyPart
    max :: BodyPart -> BodyPart -> BodyPart
    $cmin :: BodyPart -> BodyPart -> BodyPart
    min :: BodyPart -> BodyPart -> BodyPart
    Ord, ReadPrec [BodyPart]
    ReadPrec BodyPart
    Int -> ReadS BodyPart
    ReadS [BodyPart]
    (Int -> ReadS BodyPart)
    -> ReadS [BodyPart]
    -> ReadPrec BodyPart
    -> ReadPrec [BodyPart]
    -> Read BodyPart
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS BodyPart
    readsPrec :: Int -> ReadS BodyPart
    $creadList :: ReadS [BodyPart]
    readList :: ReadS [BodyPart]
    $creadPrec :: ReadPrec BodyPart
    readPrec :: ReadPrec BodyPart
    $creadListPrec :: ReadPrec [BodyPart]
    readListPrec :: ReadPrec [BodyPart]
    Read, Int -> BodyPart -> ShowS
    [BodyPart] -> ShowS
    BodyPart -> String
    (Int -> BodyPart -> ShowS)
    -> (BodyPart -> String) -> ([BodyPart] -> ShowS) -> Show BodyPart
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> BodyPart -> ShowS
    showsPrec :: Int -> BodyPart -> ShowS
    $cshow :: BodyPart -> String
    show :: BodyPart -> String
    $cshowList :: [BodyPart] -> ShowS
    showList :: [BodyPart] -> ShowS
    Show)

    data Work
        = BodyWork ContentType [(String, String)] L.ByteString
        | HeaderWork L.ByteString

    type InputWorker = Work -> IO InputIter

    data InputIter
        = Failed (Maybe (String, Input)) String
        | BodyResult (String, Input) InputWorker
        | HeaderResult [Header] InputWorker

    type FileSaver = FilePath               -- ^ tempdir
                    -> Int64                -- ^ quota
                    -> FilePath             -- ^ filename of field
                    -> L.ByteString         -- ^ content to save
                    -> IO (Bool, Int64 , FilePath)  -- ^ truncated?, saved bytes, saved filename

    defaultFileSaver :: FilePath -> Int64 -> FilePath -> ByteString -> IO (Bool, Int64, FilePath)
    defaultFileSaver :: String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    defaultFileSaver String
    tmpDir Int64
    diskQuota String
    filename ByteString
    b
      | String -> Bool
    pathSeparator String
    filename = String -> IO (Bool, Int64, String)
    forall a. HasCallStack => String -> a
    error (String
    "Filename contains path separators: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ShowS
    forall a. Show a => a -> String
    show String
    filename)
      | Bool
    otherwise =
        do (fn, h) <- String -> String -> IO (String, Handle)
    openBinaryTempFile String
    tmpDir String
    filename
           (trunc, len) <- hPutLimit diskQuota h b
           hClose h
           return (trunc, len, fn)
     where
       pathSeparator :: String -> Bool
       pathSeparator :: String -> Bool
    pathSeparator String
    template = (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\Char
    x-> Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '/' Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\\') String
    template

    defaultInputIter :: FileSaver -> FilePath -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Int64 -> Work -> IO InputIter
    defaultInputIter :: (String
     -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
    -> String
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Work
    -> IO InputIter
    defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    fileSaver String
    tmpDir Int64
    diskCount Int64
    ramCount Int64
    headerCount Int64
    maxDisk Int64
    maxRAM Int64
    maxHeader (BodyWork ContentType
    ctype [(String, String)]
    ps ByteString
    b)
        | Int64
    diskCount Int64 -> Int64 -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int64
    maxDisk = InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing (String
    "diskCount (" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    diskCount String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ") is greater than maxDisk (" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    maxDisk  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
        | Int64
    ramCount  Int64 -> Int64 -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int64
    maxRAM  = InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing (String
    "ramCount ("  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    ramCount  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ") is greater than maxRAM ("  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    maxRAM   String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
        | Bool
    otherwise =
            case String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    "filename" [(String, String)]
    ps of
              Maybe String
    Nothing ->
                  let (ByteString
    b',ByteString
    rest) = Int64 -> ByteString -> (ByteString, ByteString)
    L.splitAt (Int64
    maxRAM Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    ramCount) ByteString
    b
                      input :: (String, Input)
    input = (String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    "" (Maybe String -> String) -> Maybe String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    "name" [(String, String)]
    ps
                              , Input { inputValue :: Either String ByteString
    inputValue       = (ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right ByteString
    b')
                                      , inputFilename :: Maybe String
    inputFilename    = Maybe String
    forall a. Maybe a
    Nothing
                                      , inputContentType :: ContentType
    inputContentType = ContentType
    ctype })
                  in if ByteString -> Bool
    L.null ByteString
    rest
                      then InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ (String, Input) -> (Work -> IO InputIter) -> InputIter
    BodyResult (String, Input)
    input ((String
     -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
    -> String
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Work
    -> IO InputIter
    defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    fileSaver String
    tmpDir Int64
    diskCount (Int64
    ramCount Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    + ByteString -> Int64
    L.length ByteString
    b) Int64
    headerCount Int64
    maxDisk Int64
    maxRAM Int64
    maxHeader)
                      else InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed ((String, Input) -> Maybe (String, Input)
    forall a. a -> Maybe a
    Just (String, Input)
    input) (String
    "Reached RAM quota of " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    maxRAM String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " bytes.")

              (Just String
    filename) ->
                  do (trunc, len, fn) <- String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    fileSaver String
    tmpDir (Int64
    maxDisk Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    diskCount) String
    filename ByteString
    b
                     let input = ( String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    "" (Maybe String -> String) -> Maybe String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    "name" [(String, String)]
    ps
                                 , Input { inputValue :: Either String ByteString
    inputValue       = String -> Either String ByteString
    forall a b. a -> Either a b
    Left String
    fn
                                         , inputFilename :: Maybe String
    inputFilename    = (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    filename)
                                         , inputContentType :: ContentType
    inputContentType = ContentType
    ctype })
                     if trunc
                        then return $ Failed (Just input) ("Reached disk quota of " ++ show maxDisk ++ " bytes.")
                        else return $ BodyResult input (defaultInputIter fileSaver tmpDir (diskCount + len) ramCount headerCount maxDisk maxRAM maxHeader)

    defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    fileSaver String
    tmpDir Int64
    diskCount Int64
    ramCount Int64
    headerCount Int64
    maxDisk Int64
    maxRAM Int64
    maxHeader (HeaderWork ByteString
    bs) =
        case Int64 -> ByteString -> (ByteString, ByteString)
    L.splitAt (Int64
    maxHeader Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    headerCount) ByteString
    bs of
          (ByteString
    _hs, ByteString
    rest)
              | Bool -> Bool
    not (ByteString -> Bool
    L.null ByteString
    rest) -> InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing (String
    "Reached header quota of " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show Int64
    maxHeader String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " bytes.")
              | Bool
    otherwise ->
                  case Parsec String () [(String, String)]
    -> String -> String -> Either ParseError [(String, String)]
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> String -> s -> Either ParseError a
    parse Parsec String () [(String, String)]
    pHeaders (ByteString -> String
    LU.toString ByteString
    bs) (ByteString -> String
    LU.toString ByteString
    bs) of
                    (Left ParseError
    e) -> InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing (ParseError -> String
    forall a. Show a => a -> String
    show ParseError
    e)
                    (Right [(String, String)]
    hs) ->
                        InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ [(String, String)] -> (Work -> IO InputIter) -> InputIter
    HeaderResult [(String, String)]
    hs
                                   ((String
     -> Int64 -> String -> ByteString -> IO (Bool, Int64, String))
    -> String
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Work
    -> IO InputIter
    defaultInputIter String -> Int64 -> String -> ByteString -> IO (Bool, Int64, String)
    fileSaver String
    tmpDir Int64
    diskCount Int64
    ramCount (Int64
    headerCount Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    + (ByteString -> Int64
    L.length ByteString
    bs)) Int64
    maxDisk Int64
    maxRAM Int64
    maxHeader)
    {-# INLINE defaultInputIter #-}

    hPutLimit :: Int64 -> Handle -> L.ByteString -> IO (Bool, Int64)
    hPutLimit :: Int64 -> Handle -> ByteString -> IO (Bool, Int64)
    hPutLimit Int64
    maxCount Handle
    h ByteString
    bs = Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
    hPutLimit' Int64
    maxCount Handle
    h Int64
    0 ByteString
    bs
    {-# INLINE hPutLimit #-}

    hPutLimit' :: Int64 -> Handle -> Int64 -> L.ByteString -> IO (Bool, Int64)
    hPutLimit' :: Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
    hPutLimit' Int64
    _maxCount Handle
    _h Int64
    count ByteString
    Empty = (Bool, Int64) -> IO (Bool, Int64)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Int64
    count)
    hPutLimit'  Int64
    maxCount Handle
    h  Int64
    count (Chunk StrictByteString
    c ByteString
    cs)
        | (Int64
    count Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    + Int -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (StrictByteString -> Int
    S.length StrictByteString
    c)) Int64 -> Int64 -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int64
    maxCount =
            do Handle -> StrictByteString -> IO ()
    S.hPut Handle
    h (Int -> StrictByteString -> StrictByteString
    S.take (Int64 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int64
    maxCount Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    - Int64
    count)) StrictByteString
    c)
               (Bool, Int64) -> IO (Bool, Int64)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Int64
    maxCount)
        | Bool
    otherwise =
            do Handle -> StrictByteString -> IO ()
    S.hPut Handle
    h StrictByteString
    c
               Int64 -> Handle -> Int64 -> ByteString -> IO (Bool, Int64)
    hPutLimit' Int64
    maxCount Handle
    h (Int64
    count Int64 -> Int64 -> Int64
    forall a. Num a => a -> a -> a
    + Int -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (StrictByteString -> Int
    S.length StrictByteString
    c)) ByteString
    cs
    {-# INLINE hPutLimit' #-}

    -- FIXME: can we safely use L.unpack, or do we need to worry about encoding issues in the headers?
    bodyPartToInput :: InputWorker -> BodyPart -> IO InputIter -- (Either String (String,Input))
    bodyPartToInput :: (Work -> IO InputIter) -> BodyPart -> IO InputIter
    bodyPartToInput Work -> IO InputIter
    inputWorker (BodyPart ByteString
    rawHS ByteString
    b) =
        do r <- Work -> IO InputIter
    inputWorker (ByteString -> Work
    HeaderWork ByteString
    rawHS)
           case r of
             (Failed Maybe (String, Input)
    i String
    e) -> InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    i String
    e
             (HeaderResult [(String, String)]
    hs Work -> IO InputIter
    cont) ->
              let ctype :: ContentType
    ctype = ContentType -> Maybe ContentType -> ContentType
    forall a. a -> Maybe a -> a
    fromMaybe ContentType
    defaultInputType ([(String, String)] -> Maybe ContentType
    forall (m :: * -> *).
    MonadFail m =>
    [(String, String)] -> m ContentType
    getContentType [(String, String)]
    hs) in
              case [(String, String)] -> Maybe ContentDisposition
    forall (m :: * -> *).
    MonadFail m =>
    [(String, String)] -> m ContentDisposition
    getContentDisposition [(String, String)]
    hs of
                  Just (ContentDisposition String
    "form-data" [(String, String)]
    ps) -> do
                      let eb' :: Either String ByteString
    eb' = case [(String, String)] -> Maybe ContentTransferEncoding
    forall (m :: * -> *).
    MonadFail m =>
    [(String, String)] -> m ContentTransferEncoding
    getContentTransferEncoding [(String, String)]
    hs of
                                Maybe ContentTransferEncoding
    Nothing -> ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right ByteString
    b
                                Just (ContentTransferEncoding String
    "7bit") ->
                                    -- We don't bother checking that the data
                                    -- really is 7bit-only
                                    ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right ByteString
    b
                                Just (ContentTransferEncoding String
    "8bit") ->
                                    ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right ByteString
    b
                                Just (ContentTransferEncoding String
    "binary") ->
                                    ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right ByteString
    b
                                Just (ContentTransferEncoding String
    "base64") ->
                                    ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right (ByteString -> Either String ByteString)
    -> ByteString -> Either String ByteString
    forall a b. (a -> b) -> a -> b
    $ ByteString -> ByteString
    decodeLenient ByteString
    b
                                -- TODO: Support quoted-printable
                                Just ContentTransferEncoding
    cte ->
                                    String -> Either String ByteString
    forall a b. a -> Either a b
    Left (String
    "Bad content-transfer-encoding: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ContentTransferEncoding -> String
    forall a. Show a => a -> String
    show ContentTransferEncoding
    cte)
                      case Either String ByteString
    eb' of
                          Right ByteString
    b' ->
                              Work -> IO InputIter
    cont (ContentType -> [(String, String)] -> ByteString -> Work
    BodyWork ContentType
    ctype [(String, String)]
    ps ByteString
    b')
                          Left String
    err ->
                              InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing String
    err
                  Maybe ContentDisposition
    cd -> InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing (String
    "Expected content-disposition: form-data but got " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Maybe ContentDisposition -> String
    forall a. Show a => a -> String
    show Maybe ContentDisposition
    cd)
             (BodyResult {}) -> InputIter -> IO InputIter
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (InputIter -> IO InputIter) -> InputIter -> IO InputIter
    forall a b. (a -> b) -> a -> b
    $ Maybe (String, Input) -> String -> InputIter
    Failed Maybe (String, Input)
    forall a. Maybe a
    Nothing String
    "bodyPartToInput: Got unexpected BodyResult."

    bodyPartsToInputs :: InputWorker -> [BodyPart] -> IO ([(String,Input)], Maybe String)
    bodyPartsToInputs :: (Work -> IO InputIter)
    -> [BodyPart] -> IO ([(String, Input)], Maybe String)
    bodyPartsToInputs Work -> IO InputIter
    _ [] =
        ([(String, Input)], Maybe String)
    -> IO ([(String, Input)], Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Maybe String
    forall a. Maybe a
    Nothing)
    bodyPartsToInputs Work -> IO InputIter
    inputWorker (BodyPart
    b:[BodyPart]
    bs) =
        do r <- (Work -> IO InputIter) -> BodyPart -> IO InputIter
    bodyPartToInput Work -> IO InputIter
    inputWorker BodyPart
    b
           case r of
             (Failed Maybe (String, Input)
    mInput String
    e) ->
                 case Maybe (String, Input)
    mInput of
                   Maybe (String, Input)
    Nothing  -> ([(String, Input)], Maybe String)
    -> IO ([(String, Input)], Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], String -> Maybe String
    forall a. a -> Maybe a
    Just String
    e)
                   (Just (String, Input)
    i) -> ([(String, Input)], Maybe String)
    -> IO ([(String, Input)], Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(String, Input)
    i], String -> Maybe String
    forall a. a -> Maybe a
    Just String
    e)
             (BodyResult (String, Input)
    i Work -> IO InputIter
    cont) ->
                 do (is, err) <- (Work -> IO InputIter)
    -> [BodyPart] -> IO ([(String, Input)], Maybe String)
    bodyPartsToInputs Work -> IO InputIter
    cont [BodyPart]
    bs
                    return (i:is, err)
             (HeaderResult [(String, String)]
    _ Work -> IO InputIter
    _) ->
                 ([(String, Input)], Maybe String)
    -> IO ([(String, Input)], Maybe String)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "InputWorker is broken. Returned a HeaderResult when a BodyResult was required.")

    multipartBody :: InputWorker -> L.ByteString -> L.ByteString -> IO ([(String, Input)], Maybe String)
    multipartBody :: (Work -> IO InputIter)
    -> ByteString -> ByteString -> IO ([(String, Input)], Maybe String)
    multipartBody Work -> IO InputIter
    inputWorker ByteString
    boundary ByteString
    s =
        do let ([BodyPart]
    bodyParts, Maybe String
    mErr) = ByteString -> ByteString -> ([BodyPart], Maybe String)
    parseMultipartBody ByteString
    boundary ByteString
    s
           (inputs, mErr2) <- (Work -> IO InputIter)
    -> [BodyPart] -> IO ([(String, Input)], Maybe String)
    bodyPartsToInputs Work -> IO InputIter
    inputWorker [BodyPart]
    bodyParts
           return (inputs, mErr2 `mplus` mErr)

    -- | Packs a string into an Input of type "text/plain"
    simpleInput :: String -> Input
    simpleInput :: String -> Input
    simpleInput String
    v
        = Input { inputValue :: Either String ByteString
    inputValue       = ByteString -> Either String ByteString
    forall a b. b -> Either a b
    Right (String -> ByteString
    L.pack String
    v)
                , inputFilename :: Maybe String
    inputFilename    = Maybe String
    forall a. Maybe a
    Nothing
                , inputContentType :: ContentType
    inputContentType = ContentType
    defaultInputType
                }

    -- | The default content-type for variables.
    defaultInputType :: ContentType
    defaultInputType :: ContentType
    defaultInputType = String -> String -> [(String, String)] -> ContentType
    ContentType String
    "text" String
    "plain" [] -- FIXME: use some default encoding?

    parseMultipartBody :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
    parseMultipartBody :: ByteString -> ByteString -> ([BodyPart], Maybe String)
    parseMultipartBody ByteString
    boundary ByteString
    s =
        case ByteString -> ByteString -> (ByteString, Maybe String)
    dropPreamble ByteString
    boundary ByteString
    s of
          (ByteString
    _partData, Just String
    e)  -> ([], String -> Maybe String
    forall a. a -> Maybe a
    Just String
    e)
          (ByteString
    partData,  Maybe String
    Nothing) -> ByteString -> ByteString -> ([BodyPart], Maybe String)
    splitParts ByteString
    boundary ByteString
    partData

    dropPreamble :: L.ByteString -> L.ByteString -> (L.ByteString, Maybe String)
    dropPreamble :: ByteString -> ByteString -> (ByteString, Maybe String)
    dropPreamble ByteString
    b ByteString
    s | ByteString -> ByteString -> Bool
    isBoundary ByteString
    b ByteString
    s = (ByteString -> ByteString
    dropLine ByteString
    s, Maybe String
    forall a. Maybe a
    Nothing)
                     | ByteString -> Bool
    L.null ByteString
    s = (ByteString
    s, String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String
    "Boundary " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> String
    L.unpack ByteString
    b String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " not found.")
                     | Bool
    otherwise = ByteString -> ByteString -> (ByteString, Maybe String)
    dropPreamble ByteString
    b (ByteString -> ByteString
    dropLine ByteString
    s)

    dropLine :: L.ByteString -> L.ByteString
    dropLine :: ByteString -> ByteString
    dropLine = Int64 -> ByteString -> ByteString
    L.drop Int64
    2 (ByteString -> ByteString)
    -> (ByteString -> ByteString) -> ByteString -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ByteString -> Bool) -> ByteString -> ByteString
    dropWhileS (Bool -> Bool
    not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString -> Bool
    L.isPrefixOf ByteString
    crlf)

    -- | Check whether a string starts with two dashes followed by
    --   the given boundary string.
    isBoundary :: L.ByteString -- ^ The boundary, without the initial dashes
               -> L.ByteString
               -> Bool
    isBoundary :: ByteString -> ByteString -> Bool
    isBoundary ByteString
    b ByteString
    s = ByteString -> Bool
    startsWithDashes ByteString
    s Bool -> Bool -> Bool
    && ByteString
    b ByteString -> ByteString -> Bool
    `L.isPrefixOf` Int64 -> ByteString -> ByteString
    L.drop Int64
    2 ByteString
    s

    -- | Checks whether a string starts with two dashes.
    startsWithDashes :: L.ByteString -> Bool
    startsWithDashes :: ByteString -> Bool
    startsWithDashes ByteString
    s = String -> ByteString
    L.pack String
    "--" ByteString -> ByteString -> Bool
    `L.isPrefixOf` ByteString
    s

    splitParts :: L.ByteString -> L.ByteString -> ([BodyPart], Maybe String)
    splitParts :: ByteString -> ByteString -> ([BodyPart], Maybe String)
    splitParts ByteString
    boundary ByteString
    s =
    --    | not (isBoundary boundary s) = ([], Just $ "Missing boundary: " ++ L.unpack boundary ++ "\n" ++ L.unpack s)
        case ByteString -> Bool
    L.null ByteString
    s of
          Bool
    True -> ([], Maybe String
    forall a. Maybe a
    Nothing)
          Bool
    False ->
              case ByteString -> ByteString -> (BodyPart, ByteString)
    splitPart ByteString
    boundary ByteString
    s of
                (BodyPart
    p, ByteString
    s') ->
                    let ([BodyPart]
    ps,Maybe String
    e) = ByteString -> ByteString -> ([BodyPart], Maybe String)
    splitParts ByteString
    boundary ByteString
    s'
                    in (BodyPart
    pBodyPart -> [BodyPart] -> [BodyPart]
    forall a. a -> [a] -> [a]
    :[BodyPart]
    ps, Maybe String
    e)
    {-# INLINE splitParts #-}

    splitPart :: L.ByteString -> L.ByteString -> (BodyPart, L.ByteString)
    splitPart :: ByteString -> ByteString -> (BodyPart, ByteString)
    splitPart ByteString
    boundary ByteString
    s =
        case ByteString -> (ByteString, ByteString)
    splitBlank ByteString
    s of
          (ByteString
    headers, ByteString
    rest) ->
              case ByteString -> ByteString -> (ByteString, ByteString)
    splitBoundary ByteString
    boundary (Int64 -> ByteString -> ByteString
    L.drop Int64
    4 ByteString
    rest) of
                (ByteString
    body, ByteString
    rest') -> (ByteString -> ByteString -> BodyPart
    BodyPart (ByteString -> ByteString -> ByteString
    L.append ByteString
    headers ByteString
    crlf) ByteString
    body, ByteString
    rest')
    {-# INLINE splitPart #-}

    splitBlank :: L.ByteString -> (L.ByteString, L.ByteString)
    splitBlank :: ByteString -> (ByteString, ByteString)
    splitBlank ByteString
    s = (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
    spanS (Bool -> Bool
    not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString -> Bool
    L.isPrefixOf ByteString
    crlfcrlf) ByteString
    s
    {-# INLINE splitBlank #-}

    splitBoundary :: L.ByteString -> L.ByteString -> (L.ByteString, L.ByteString)
    splitBoundary :: ByteString -> ByteString -> (ByteString, ByteString)
    splitBoundary ByteString
    boundary ByteString
    s =
        case (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
    spanS (Bool -> Bool
    not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString -> Bool
    L.isPrefixOf (String -> ByteString
    L.pack String
    "\r\n--" ByteString -> ByteString -> ByteString
    `L.append` ByteString
    boundary)) ByteString
    s of
          (ByteString
    x,ByteString
    y) | (String -> ByteString
    L.pack String
    "\r\n--" ByteString -> ByteString -> ByteString
    `L.append` ByteString
    boundary ByteString -> ByteString -> ByteString
    `L.append` (String -> ByteString
    L.pack String
    "--"))
                    ByteString -> ByteString -> Bool
    `L.isPrefixOf` ByteString
    y -> (ByteString
    x, ByteString
    L.empty)
                | Bool
    otherwise -> (ByteString
    x, ByteString -> ByteString
    dropLine (Int64 -> ByteString -> ByteString
    L.drop Int64
    2 ByteString
    y))
    {-# INLINE splitBoundary #-}

    splitAtEmptyLine :: L.ByteString -> Maybe (L.ByteString, L.ByteString)
    splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)
    splitAtEmptyLine ByteString
    s =
        case ByteString -> (ByteString, ByteString)
    splitBlank ByteString
    s of
          (ByteString
    before, ByteString
    after) | ByteString -> Bool
    L.null ByteString
    after -> Maybe (ByteString, ByteString)
    forall a. Maybe a
    Nothing
                          | Bool
    otherwise    -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
    forall a. a -> Maybe a
    Just (ByteString -> ByteString -> ByteString
    L.append ByteString
    before ByteString
    crlf, Int64 -> ByteString -> ByteString
    L.drop Int64
    4 ByteString
    after)
    {-# INLINE splitAtEmptyLine #-}

    -- | Split a string at the first CRLF. The CRLF is not included
    --   in any of the returned strings.
    splitAtCRLF :: ByteString -- ^ String to split.
                -> Maybe (ByteString,ByteString)
                -- ^  Returns 'Nothing' if there is no CRLF.
    splitAtCRLF :: ByteString -> Maybe (ByteString, ByteString)
    splitAtCRLF ByteString
    s =
        case (ByteString -> Bool) -> ByteString -> (ByteString, ByteString)
    spanS (Bool -> Bool
    not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> ByteString -> Bool
    L.isPrefixOf ByteString
    crlf) ByteString
    s of
          (ByteString
    before, ByteString
    after) | ByteString -> Bool
    L.null ByteString
    after -> Maybe (ByteString, ByteString)
    forall a. Maybe a
    Nothing
                          | Bool
    otherwise    -> (ByteString, ByteString) -> Maybe (ByteString, ByteString)
    forall a. a -> Maybe a
    Just (ByteString
    before, Int64 -> ByteString -> ByteString
    L.drop Int64
    2 ByteString
    after)
    {-# INLINE splitAtCRLF #-}