{-# 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 Bool
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) []
       forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)
    where
      ctype :: Maybe ContentType
      ctype :: Maybe ContentType
ctype = forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
P.unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do let ctype :: Maybe ContentType
ctype = forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
P.unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"content-type" Request
req
       Maybe [(String, Input)]
mbi <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
       case Maybe [(String, Input)]
mbi of
         (Just [(String, Input)]
bi) ->
             do forall a. MVar a -> a -> IO ()
putMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) [(String, Input)]
bi
                forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)]
bi, forall a. Maybe a
Nothing)
         Maybe [(String, Input)]
Nothing ->
             do Maybe RqBody
rqbody <- forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
req
                case Maybe RqBody
rqbody of
                  Maybe RqBody
Nothing          -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"bodyInput: Request body was already consumed.")
                  (Just (Body ByteString
bs)) ->
                      do r :: ([(String, Input)], Maybe String)
r@([(String, Input)]
inputs, Maybe String
_err) <- BodyPolicy
-> Maybe ContentType
-> ByteString
-> IO ([(String, Input)], Maybe String)
decodeBody BodyPolicy
bodyPolicy Maybe ContentType
ctype ByteString
bs
                         forall a. MVar a -> a -> IO ()
putMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) [(String, Input)]
inputs
                         forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)], Maybe String)
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 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 forall a b. (a -> b) -> a -> b
$ String -> String
SURI.unEscapeQS String
val)forall a. a -> [a] -> [a]
:[(String, Input)]
rest
    where (String
pairString,String
qString')= forall a. (a -> Bool) -> [a] -> ([a], [a])
split (forall a. Eq a => a -> a -> Bool
==Char
'&') String
qString
          (String
name,String
val)=forall a. (a -> Bool) -> [a] -> ([a], [a])
split (forall a. Eq a => a -> a -> Bool
==Char
'=') String
pairString
          rest :: [(String, Input)]
rest=if 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 forall a b. (a -> b) -> a -> b
$ String -> String
SURI.unEscapeQS (ByteString -> String
L.unpack forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
L.drop Int64
1 ByteString
val)) forall a. a -> [a] -> [a]
: [(String, Input)]
rest
    where (ByteString
pairString,ByteString
qString') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (forall a. Eq a => a -> a -> Bool
== Char
'&') ByteString
qString
          (ByteString
name,ByteString
val) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (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)]
_) ->
            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 ->
            forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"decodeBody: unsupported content-type: " forall a. [a] -> [a] -> [a]
++ 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 -> 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 forall a. Maybe a
Nothing
                              else forall a. a -> Maybe a
Just (String
"x-www-form-urlencoded content longer than BodyPolicy.maxRAM=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (BodyPolicy -> Int64
maxRAM BodyPolicy
bp) 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 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"boundary not found in parameters: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(String, String)]
ps)

-- | Get the path components from a String.
pathEls :: String -> [String]
pathEls :: String -> [String]
pathEls = (forall a. Int -> [a] -> [a]
drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
U.toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
P.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
SURI.unEscape) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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]
hforall a. a -> [a] -> [a]
:forall a. Eq a => a -> [a] -> [[a]]
splitList a
sep [a]
t
        where ([a]
h,[a]
t)=forall a. (a -> Bool) -> [a] -> ([a], [a])
split (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]
hforall a. a -> [a] -> [a]
:forall a. (a -> Bool) -> [a] -> [[a]]
splitListBy a -> Bool
f [a]
t
        where ([a]
h,[a]
t)=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')=forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
f [a]
s
        right :: [a]
right = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right' then [] else forall a. [a] -> [a]
tail [a]
right'