{-# 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 :: (Int64 -> Int64 -> Int64 -> InputWorker)
-> Int64 -> Int64 -> Int64 -> BodyPolicy
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 :: 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
_ <- IO Bool -> m Bool
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) []
       ([(String, Input)], Maybe String)
-> m ([(String, Input)], Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe String
forall a. Maybe a
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 (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
       Maybe [(String, Input)]
mbi <- MVar [(String, Input)] -> IO (Maybe [(String, Input)])
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 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 (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)]
bi, Maybe String
forall a. Maybe a
Nothing)
         Maybe [(String, Input)]
Nothing ->
             do Maybe RqBody
rqbody <- Request -> IO (Maybe RqBody)
forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
req
                case Maybe RqBody
rqbody of
                  Maybe RqBody
Nothing          -> ([(String, Input)], Maybe String)
-> IO ([(String, Input)], Maybe String)
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 :: ([(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
                         MVar [(String, Input)] -> [(String, Input)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) [(String, Input)]
inputs
                         ([(String, Input)], Maybe String)
-> IO ([(String, Input)], Maybe String)
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 String -> 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 (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 (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 (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 (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 (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 :: 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 :: (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 :: (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
right' then [] else [a] -> [a]
forall a. [a] -> [a]
tail [a]
right'