    {-# LANGUAGE FlexibleInstances #-}

    module Happstack.Server.Internal.MessageWrap (
            module Happstack.Server.Internal.MessageWrap
            ,defaultInputIter
       ) where

    import Control.Concurrent.MVar (tryTakeMVar, tryPutMVar, putMVar)
    import Control.Monad.Trans (MonadIO(liftIO))
    import qualified Data.ByteString.Char8 as P
    import qualified Data.ByteString.Lazy.Char8 as L
    import qualified Data.ByteString.UTF8  as U (toString)
    import Data.Int (Int64)
    import Happstack.Server.Internal.Types as H
    import Happstack.Server.Internal.Multipart
    import Happstack.Server.Internal.RFC822Headers (parseContentType)
    import Happstack.Server.SURI as SURI

    queryInput :: SURI -> [(String, Input)]
    queryInput :: SURI -> [(String, Input)]
    queryInput SURI
    uri = String -> [(String, Input)]
    formDecode (case SURI -> String
    SURI.query SURI
    uri of
                                   Char
    '?':String
    r -> String
    r
                                   String
    xs    -> String
    xs)

    -- | see 'defaultBodyPolicy'
    data BodyPolicy
        = BodyPolicy { BodyPolicy -> Int64 -> Int64 -> Int64 -> InputWorker
    inputWorker :: Int64 -> Int64 -> Int64 -> InputWorker
                     , BodyPolicy -> Int64
    maxDisk     :: Int64 -- ^ maximum bytes for files uploaded in this 'Request'
                     , BodyPolicy -> Int64
    maxRAM      :: Int64 -- ^ maximum bytes for all non-file values in the 'Request' body
                     , BodyPolicy -> Int64
    maxHeader   :: Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@
                     }

    -- | create a 'BodyPolicy' for use with decodeBody
    defaultBodyPolicy :: FilePath -- ^ temporary directory for file uploads
                      -> Int64 -- ^ maximum bytes for files uploaded in this 'Request'
                      -> Int64 -- ^ maximum bytes for all non-file values in the 'Request' body
                      -> Int64 -- ^ maximum bytes of overhead for headers in @multipart/form-data@
                      -> BodyPolicy
    defaultBodyPolicy :: String -> Int64 -> Int64 -> Int64 -> BodyPolicy
    defaultBodyPolicy String
    tmpDir Int64
    md Int64
    mr Int64
    mh =
        BodyPolicy { inputWorker :: Int64 -> Int64 -> Int64 -> InputWorker
    inputWorker = FileSaver
    -> String
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> Int64
    -> InputWorker
    defaultInputIter FileSaver
    defaultFileSaver String
    tmpDir Int64
    0 Int64
    0 Int64
    0
                   , maxDisk :: Int64
    maxDisk   = Int64
    md
                   , maxRAM :: Int64
    maxRAM    = Int64
    mr
                   , maxHeader :: Int64
    maxHeader = Int64
    mh
                   }

    bodyInput :: (MonadIO m) => BodyPolicy -> Request -> m ([(String, Input)], Maybe String)
    bodyInput :: forall (m :: * -> *).
    MonadIO m =>
    BodyPolicy -> Request -> m ([(String, Input)], Maybe String)
    bodyInput BodyPolicy
    _ Request
    req | (Bool -> Bool
    not (Method -> Bool
    canHaveBody (Request -> Method
    rqMethod Request
    req))) Bool -> Bool -> Bool
    || (Bool -> Bool
    not (Maybe ContentType -> Bool
    isDecodable Maybe ContentType
    ctype)) =
        do _ <- IO Bool -> m Bool
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
    forall a b. (a -> b) -> a -> b
    $ MVar [(String, Input)] -> [(String, Input)] -> IO Bool
    forall a. MVar a -> a -> IO Bool
    tryPutMVar (Request -> MVar [(String, Input)]
    rqInputsBody Request
    req) []
           return ([], Nothing)
        where
          ctype :: Maybe ContentType
          ctype :: Maybe ContentType
    ctype = String -> Maybe ContentType
    forall (m :: * -> *). MonadFail m => String -> m ContentType
    parseContentType (String -> Maybe ContentType)
    -> (ByteString -> String) -> ByteString -> Maybe ContentType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> String
    P.unpack (ByteString -> Maybe ContentType)
    -> Maybe ByteString -> Maybe ContentType
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Request -> Maybe ByteString
    forall r. HasHeaders r => String -> r -> Maybe ByteString
    getHeader String
    "content-type" Request
    req
          isDecodable :: Maybe ContentType -> Bool
          isDecodable :: Maybe ContentType -> Bool
    isDecodable Maybe ContentType
    Nothing                                                      = Bool
    True -- assume it is application/x-www-form-urlencoded
          isDecodable (Just (ContentType String
    "application" String
    "x-www-form-urlencoded" [(String, String)]
    _)) = Bool
    True
          isDecodable (Just (ContentType String
    "multipart" String
    "form-data" [(String, String)]
    _ps))             = Bool
    True
          isDecodable (Just ContentType
    _)                                                     = Bool
    False

    bodyInput BodyPolicy
    bodyPolicy Request
    req =
      IO ([(String, Input)], Maybe String)
    -> m ([(String, Input)], Maybe String)
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ([(String, Input)], Maybe String)
     -> m ([(String, Input)], Maybe String))
    -> IO ([(String, Input)], Maybe String)
    -> m ([(String, Input)], Maybe String)
    forall a b. (a -> b) -> a -> b
    $
        do let ctype :: Maybe ContentType
    ctype = String -> Maybe ContentType
    forall (m :: * -> *). MonadFail m => String -> m ContentType
    parseContentType (String -> Maybe ContentType)
    -> (ByteString -> String) -> ByteString -> Maybe ContentType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> String
    P.unpack (ByteString -> Maybe ContentType)
    -> Maybe ByteString -> Maybe ContentType
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Request -> Maybe ByteString
    forall r. HasHeaders r => String -> r -> Maybe ByteString
    getHeader String
    "content-type" Request
    req
           mbi <- MVar [(String, Input)] -> IO (Maybe [(String, Input)])
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar (Request -> MVar [(String, Input)]
    rqInputsBody Request
    req)
           case mbi of
             (Just [(String, Input)]
    bi) ->
                 do MVar [(String, Input)] -> [(String, Input)] -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar (Request -> MVar [(String, Input)]
    rqInputsBody Request
    req) [(String, Input)]
    bi
                    ([(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)]
    bi, Maybe String
    forall a. Maybe a
    Nothing)
             Maybe [(String, Input)]
    Nothing ->
                 do rqbody <- Request -> IO (Maybe RqBody)
    forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
    takeRequestBody Request
    req
                    case rqbody of
                      Maybe RqBody
    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 -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String
    "bodyInput: Request body was already consumed.")
                      (Just (Body ByteString
    bs)) ->
                          do r@(inputs, _err) <- BodyPolicy
    -> Maybe ContentType
    -> ByteString
    -> IO ([(String, Input)], Maybe String)
    decodeBody BodyPolicy
    bodyPolicy Maybe ContentType
    ctype ByteString
    bs
                             putMVar (rqInputsBody req) inputs
                             return r

    -- | Decodes application\/x-www-form-urlencoded inputs.
    -- TODO: should any of the [] be error conditions?
    formDecode :: String -> [(String, Input)]
    formDecode :: String -> [(String, Input)]
    formDecode [] = []
    formDecode String
    qString =
        if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    pairString then [(String, Input)]
    rest else
               (String -> String
    SURI.unEscapeQS String
    name,String -> Input
    simpleInput (String -> Input) -> String -> Input
    forall a b. (a -> b) -> a -> b
    $ String -> String
    SURI.unEscapeQS String
    val)(String, Input) -> [(String, Input)] -> [(String, Input)]
    forall a. a -> [a] -> [a]
    :[(String, Input)]
    rest
        where (String
    pairString,String
    qString')= (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    split (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '&') String
    qString
              (String
    name,String
    val)=(Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    split (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '=') String
    pairString
              rest :: [(String, Input)]
    rest=if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    qString' then [] else String -> [(String, Input)]
    formDecode String
    qString'

    -- | Decodes application\/x-www-form-urlencoded inputs.
    -- TODO: should any of the [] be error conditions?
    formDecodeBS :: L.ByteString -> [(String, Input)]
    formDecodeBS :: ByteString -> [(String, Input)]
    formDecodeBS ByteString
    qString | ByteString -> Bool
    L.null ByteString
    qString = []
    formDecodeBS ByteString
    qString =
        if ByteString -> Bool
    L.null ByteString
    pairString
           then [(String, Input)]
    rest            -- skip in case of consecutive ampersands "...&&..."
           else (String -> String
    SURI.unEscapeQS (ByteString -> String
    L.unpack ByteString
    name), String -> Input
    simpleInput (String -> Input) -> String -> Input
    forall a b. (a -> b) -> a -> b
    $ String -> String
    SURI.unEscapeQS (ByteString -> String
    L.unpack (ByteString -> String) -> ByteString -> String
    forall a b. (a -> b) -> a -> b
    $ Int64 -> ByteString -> ByteString
    L.drop Int64
    1 ByteString
    val)) (String, Input) -> [(String, Input)] -> [(String, Input)]
    forall a. a -> [a] -> [a]
    : [(String, Input)]
    rest
        where (ByteString
    pairString,ByteString
    qString') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
    L.break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '&') ByteString
    qString
              (ByteString
    name,ByteString
    val) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
    L.break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '=') ByteString
    pairString
              rest :: [(String, Input)]
    rest = ByteString -> [(String, Input)]
    formDecodeBS (Int64 -> ByteString -> ByteString
    L.drop Int64
    1 ByteString
    qString')

    -- FIXME: is usend L.unpack really the right thing to do
    decodeBody :: BodyPolicy
               -> Maybe ContentType
               -> L.ByteString
               -> IO ([(String,Input)], Maybe String)
    decodeBody :: BodyPolicy
    -> Maybe ContentType
    -> ByteString
    -> IO ([(String, Input)], Maybe String)
    decodeBody BodyPolicy
    bp Maybe ContentType
    ctype ByteString
    inp
        = case Maybe ContentType
    ctype of
            Just (ContentType String
    "application" String
    "x-www-form-urlencoded" [(String, String)]
    _) ->
                ([(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)], Maybe String)
    decodedUrlEncodedForm
            Just (ContentType String
    "multipart" String
    "form-data" [(String, String)]
    ps) ->
                InputWorker
    -> [(String, String)]
    -> ByteString
    -> IO ([(String, Input)], Maybe String)
    multipartDecode ((BodyPolicy -> Int64 -> Int64 -> Int64 -> InputWorker
    inputWorker BodyPolicy
    bp) (BodyPolicy -> Int64
    maxDisk BodyPolicy
    bp) (BodyPolicy -> Int64
    maxRAM BodyPolicy
    bp) (BodyPolicy -> Int64
    maxHeader BodyPolicy
    bp)) [(String, String)]
    ps ByteString
    inp
            Just ContentType
    ct ->
                ([(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 -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String
    "decodeBody: unsupported content-type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ContentType -> String
    forall a. Show a => a -> String
    show ContentType
    ct) -- unknown content-type, the user will have to
                         -- deal with it by looking at the raw content
            -- No content-type given, assume x-www-form-urlencoded
            Maybe ContentType
    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, Input)], Maybe String)
    decodedUrlEncodedForm
      where
         (ByteString
    upToMaxRAM,ByteString
    overMaxRAM) = Int64 -> ByteString -> (ByteString, ByteString)
    L.splitAt (BodyPolicy -> Int64
    maxRAM BodyPolicy
    bp) ByteString
    inp
         decodedUrlEncodedForm :: ([(String, Input)], Maybe String)
    decodedUrlEncodedForm = (ByteString -> [(String, Input)]
    formDecodeBS ByteString
    upToMaxRAM,
                                  if ByteString -> Bool
    L.null ByteString
    overMaxRAM
                                  then Maybe String
    forall a. Maybe a
    Nothing
                                  else String -> Maybe String
    forall a. a -> Maybe a
    Just (String
    "x-www-form-urlencoded content longer than BodyPolicy.maxRAM=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int64 -> String
    forall a. Show a => a -> String
    show (BodyPolicy -> Int64
    maxRAM BodyPolicy
    bp) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " bytes"))

    -- | Decodes multipart\/form-data input.
    multipartDecode :: InputWorker
                    -> [(String,String)] -- ^ Content-type parameters
                    -> L.ByteString      -- ^ Request body
                    -> IO ([(String,Input)], Maybe String) -- ^ Input variables and values.
    multipartDecode :: InputWorker
    -> [(String, String)]
    -> ByteString
    -> IO ([(String, Input)], Maybe String)
    multipartDecode InputWorker
    worker [(String, String)]
    ps ByteString
    inp =
        case String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    "boundary" [(String, String)]
    ps of
             Just String
    b  -> InputWorker
    -> ByteString -> ByteString -> IO ([(String, Input)], Maybe String)
    multipartBody InputWorker
    worker (String -> ByteString
    L.pack String
    b) ByteString
    inp
             Maybe String
    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 -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String
    "boundary not found in parameters: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [(String, String)] -> String
    forall a. Show a => a -> String
    show [(String, String)]
    ps)

    -- | Get the path components from a String.
    pathEls :: String -> [String]
    pathEls :: String -> [String]
    pathEls = (Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    drop Int
    1) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (ByteString -> String
    U.toString (ByteString -> String)
    -> (String -> ByteString) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ByteString
    P.pack (String -> ByteString)
    -> (String -> String) -> String -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    SURI.unEscape) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> [String]
    forall a. Eq a => a -> [a] -> [[a]]
    splitList Char
    '/'

    -- | Repeadly splits a list by the provided separator and collects the results
    splitList :: Eq a => a -> [a] -> [[a]]
    splitList :: forall a. Eq a => a -> [a] -> [[a]]
    splitList a
    _   [] = []
    splitList a
    sep [a]
    list = [a]
    h[a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    :a -> [a] -> [[a]]
    forall a. Eq a => a -> [a] -> [[a]]
    splitList a
    sep [a]
    t
            where ([a]
    h,[a]
    t)=(a -> Bool) -> [a] -> ([a], [a])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    split (a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    ==a
    sep) [a]
    list

    -- | Repeatedly splits a list and collects the results
    splitListBy :: (a -> Bool) -> [a] -> [[a]]
    splitListBy :: forall a. (a -> Bool) -> [a] -> [[a]]
    splitListBy a -> Bool
    _ [] = []
    splitListBy a -> Bool
    f [a]
    list = [a]
    h[a] -> [[a]] -> [[a]]
    forall a. a -> [a] -> [a]
    :(a -> Bool) -> [a] -> [[a]]
    forall a. (a -> Bool) -> [a] -> [[a]]
    splitListBy a -> Bool
    f [a]
    t
            where ([a]
    h,[a]
    t)=(a -> Bool) -> [a] -> ([a], [a])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    split a -> Bool
    f [a]
    list

    -- | Split is like break, but the matching element is dropped.
    split :: (a -> Bool) -> [a] -> ([a], [a])
    split :: forall a. (a -> Bool) -> [a] -> ([a], [a])
    split a -> Bool
    f [a]
    s = ([a]
    left,[a]
    right)
            where
            ([a]
    left,[a]
    right')=(a -> Bool) -> [a] -> ([a], [a])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break a -> Bool
    f [a]
    s
            right :: [a]
    right = if [a] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [a]
    right' then [] else [a] -> [a]
    forall a. HasCallStack => [a] -> [a]
    tail [a]
    right'