{-# LANGUAGE OverloadedStrings, CPP #-}
module Yesod.Core.Internal.Request
    ( parseWaiRequest
    , RequestBodyContents
    , FileInfo
    , fileName
    , fileContentType
    , fileMove
    , mkFileInfoLBS
    , mkFileInfoFile
    , mkFileInfoSource
    , FileUpload (..)
    , tooLargeResponse
    , tokenKey
    , langKey
    , textQueryString
    -- The below are exported for testing.
    , randomString
    ) where

import Data.String (IsString)
import Control.Arrow (second)
import qualified Network.Wai.Parse as NWP
import qualified Network.Wai as W
import Web.Cookie (parseCookiesText)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as LS8
import Data.Text (Text, pack)
import Network.HTTP.Types (queryToQueryText, Status (Status))
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.ByteString.Lazy as L
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Conduit
import Data.Word (Word8, Word64)
import Control.Exception (throwIO)
import Control.Monad ((<=<), liftM)
import Yesod.Core.Types
import qualified Data.Map as Map
import Data.IORef
import qualified Data.Vector.Storable as V
import Data.ByteString.Internal (ByteString (PS))
import qualified Data.Word8 as Word8

-- | Impose a limit on the size of the request body.
limitRequestBody :: Word64 -> W.Request -> IO W.Request
limitRequestBody :: Word64 -> Request -> IO Request
limitRequestBody Word64
maxLen Request
req = do
    IORef Word64
ref <- forall a. a -> IO (IORef a)
newIORef Word64
maxLen
    forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
        { requestBody :: IO ByteString
W.requestBody = do
            ByteString
bs <- Request -> IO ByteString
W.requestBody Request
req
            Word64
remaining <- forall a. IORef a -> IO a
readIORef IORef Word64
ref
            let len :: Word64
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S8.length ByteString
bs
                remaining' :: Word64
remaining' = Word64
remaining forall a. Num a => a -> a -> a
- Word64
len
            if Word64
remaining forall a. Ord a => a -> a -> Bool
< Word64
len
                then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Response -> HandlerContents
HCWai forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Response
tooLargeResponse Word64
maxLen Word64
len
                else do
                    forall a. IORef a -> a -> IO ()
writeIORef IORef Word64
ref Word64
remaining'
                    forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
        }

tooLargeResponse :: Word64 -> Word64 -> W.Response
tooLargeResponse :: Word64 -> Word64 -> Response
tooLargeResponse Word64
maxLen Word64
bodyLen = Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS
    (Int -> ByteString -> Status
Status Int
413 ByteString
"Too Large")
    [(HeaderName
"Content-Type", ByteString
"text/plain")]
    ([ByteString] -> ByteString
L.concat 
        [ ByteString
"Request body too large to be processed. The maximum size is "
        , ([Char] -> ByteString
LS8.pack (forall a. Show a => a -> [Char]
show Word64
maxLen))
        , ByteString
" bytes; your request body was "
        , ([Char] -> ByteString
LS8.pack (forall a. Show a => a -> [Char]
show Word64
bodyLen))
        , ByteString
" bytes. If you're the developer of this site, you can configure the maximum length with the `maximumContentLength` or `maximumContentLengthIO` function on the Yesod typeclass."
        ])

parseWaiRequest :: W.Request
                -> SessionMap
                -> Bool
                -> Maybe Word64 -- ^ max body size
                -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
parseWaiRequest :: Request
-> SessionMap
-> Bool
-> Maybe Word64
-> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
parseWaiRequest Request
env SessionMap
session Bool
useToken Maybe Word64
mmaxBodySize =
    -- In most cases, we won't need to generate any random values. Therefore,
    -- we split our results: if we need a random generator, return a Right
    -- value, otherwise return a Left and avoid the relatively costly generator
    -- acquisition.
    case Either (Maybe Text) (IO Int -> IO (Maybe Text))
etoken of
        Left Maybe Text
token -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO YesodRequest
mkRequest Maybe Text
token
        Right IO Int -> IO (Maybe Text)
mkToken -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO YesodRequest
mkRequest forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO Int -> IO (Maybe Text)
mkToken
  where
    mkRequest :: Maybe Text -> IO YesodRequest
mkRequest Maybe Text
token' = do
        Request
envLimited <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. Monad m => a -> m a
return Word64 -> Request -> IO Request
limitRequestBody Maybe Word64
mmaxBodySize Request
env
        forall (m :: * -> *) a. Monad m => a -> m a
return YesodRequest
            { reqGetParams :: [(Text, Text)]
reqGetParams  = [(Text, Text)]
gets
            , reqCookies :: [(Text, Text)]
reqCookies    = [(Text, Text)]
cookies
            , reqWaiRequest :: Request
reqWaiRequest = Request
envLimited
            , reqLangs :: [Text]
reqLangs      = [Text]
langs''
            , reqToken :: Maybe Text
reqToken      = Maybe Text
token'
            , reqSession :: SessionMap
reqSession    = if Bool
useToken
                                then forall k a. Ord k => k -> Map k a -> Map k a
Map.delete forall a. IsString a => a
tokenKey SessionMap
session
                                else SessionMap
session
            , reqAccept :: [ByteString]
reqAccept     = Request -> [ByteString]
httpAccept Request
env
            }
    gets :: [(Text, Text)]
gets = Request -> [(Text, Text)]
textQueryString Request
env
    reqCookie :: Maybe ByteString
reqCookie = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Cookie" forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
W.requestHeaders Request
env
    cookies :: [(Text, Text)]
cookies = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [(Text, Text)]
parseCookiesText Maybe ByteString
reqCookie
    acceptLang :: Maybe ByteString
acceptLang = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept-Language" forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
W.requestHeaders Request
env
    langs :: [Text]
langs = forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
S8.unpack) forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [ByteString]
NWP.parseHttpAccept Maybe ByteString
acceptLang

    lookupText :: k -> Map k ByteString -> Maybe Text
lookupText k
k = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k

    -- The language preferences are prioritized as follows:
    langs' :: [Text]
langs' = forall a. [Maybe a] -> [a]
catMaybes [ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup forall a. IsString a => a
langKey [(Text, Text)]
gets -- Query _LANG
                       , forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup forall a. IsString a => a
langKey [(Text, Text)]
cookies     -- Cookie _LANG
                       , forall {k}. Ord k => k -> Map k ByteString -> Maybe Text
lookupText forall a. IsString a => a
langKey SessionMap
session -- Session _LANG
                       ] forall a. [a] -> [a] -> [a]
++ [Text]
langs                    -- Accept-Language(s)

    -- Github issue #195. We want to add an extra two-letter version of any
    -- language in the list.
    langs'' :: [Text]
langs'' = ([Text] -> [Text], Set Text) -> [Text] -> [Text]
addTwoLetters (forall a. a -> a
id, forall a. Set a
Set.empty) [Text]
langs'

    -- If sessions are disabled tokens should not be used (any
    -- tokenKey present in the session is ignored). If sessions
    -- are enabled and a session has no tokenKey a new one is
    -- generated.
    etoken :: Either (Maybe Text) (IO Int -> IO (Maybe Text))
etoken
        | Bool
useToken =
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup forall a. IsString a => a
tokenKey SessionMap
session of
                -- Already have a token, use it.
                Just ByteString
bs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
bs
                -- Don't have a token, get a random generator and make a new one.
                Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => Int -> m Int -> m Text
randomString Int
40
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a. Maybe a
Nothing

textQueryString :: W.Request -> [(Text, Text)]
textQueryString :: Request -> [(Text, Text)]
textQueryString = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query -> [(Text, Maybe Text)]
queryToQueryText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
W.queryString

-- | Get the list of accepted content types from the WAI Request\'s Accept
-- header.
--
-- Since 1.2.0
httpAccept :: W.Request -> [ContentType]
httpAccept :: Request -> [ByteString]
httpAccept = ByteString -> [ByteString]
NWP.parseHttpAccept
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
S8.empty
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept"
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ResponseHeaders
W.requestHeaders

addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
addTwoLetters :: ([Text] -> [Text], Set Text) -> [Text] -> [Text]
addTwoLetters ([Text] -> [Text]
toAdd, Set Text
exist) [] =
    forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
exist) forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
toAdd []
addTwoLetters ([Text] -> [Text]
toAdd, Set Text
exist) (Text
l:[Text]
ls) =
    Text
l forall a. a -> [a] -> [a]
: ([Text] -> [Text], Set Text) -> [Text] -> [Text]
addTwoLetters ([Text] -> [Text]
toAdd', Set Text
exist') [Text]
ls
  where
    ([Text] -> [Text]
toAdd', Set Text
exist')
        | Text -> Int
T.length Text
l forall a. Ord a => a -> a -> Bool
> Int
2 = ([Text] -> [Text]
toAdd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.take Int
2 Text
lforall a. a -> [a] -> [a]
:), Set Text
exist)
        | Bool
otherwise = ([Text] -> [Text]
toAdd, forall a. Ord a => a -> Set a -> Set a
Set.insert Text
l Set Text
exist)

-- | Generate a random String of alphanumerical characters
-- (a-z, A-Z, and 0-9) of the given length using the given
-- random number generator.
randomString :: Monad m => Int -> m Int -> m Text
randomString :: forall (m :: * -> *). Monad m => Int -> m Int -> m Text
randomString Int
len m Int
gen =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> ByteString
fromByteVector) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, Storable a) =>
Int -> m a -> m (Vector a)
V.replicateM Int
len m Word8
asciiChar
  where
    asciiChar :: m Word8
asciiChar =
      let loop :: m Word8
loop = do
            Int
x <- m Int
gen
            let y :: Word8
y = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
x forall a. Integral a => a -> a -> a
`mod` Int
64
            case () of
              ()
                | Word8
y forall a. Ord a => a -> a -> Bool
< Word8
26 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8
y forall a. Num a => a -> a -> a
+ Word8
Word8._A
                | Word8
y forall a. Ord a => a -> a -> Bool
< Word8
52 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8
y forall a. Num a => a -> a -> a
+ Word8
Word8._a forall a. Num a => a -> a -> a
- Word8
26
                | Word8
y forall a. Ord a => a -> a -> Bool
< Word8
62 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8
y forall a. Num a => a -> a -> a
+ Word8
Word8._0 forall a. Num a => a -> a -> a
- Word8
52
                | Bool
otherwise -> m Word8
loop
       in m Word8
loop

fromByteVector :: V.Vector Word8 -> ByteString
fromByteVector :: Vector Word8 -> ByteString
fromByteVector Vector Word8
v =
    ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fptr Int
offset Int
idx
  where
    (ForeignPtr Word8
fptr, Int
offset, Int
idx) = forall a. Vector a -> (ForeignPtr a, Int, Int)
V.unsafeToForeignPtr Vector Word8
v
{-# INLINE fromByteVector #-}

mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
mkFileInfoLBS :: Text -> Text -> ByteString -> FileInfo
mkFileInfoLBS Text
name Text
ct ByteString
lbs =
    Text
-> Text
-> ConduitT () ByteString (ResourceT IO) ()
-> ([Char] -> IO ())
-> FileInfo
FileInfo Text
name Text
ct (forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
lbs) ([Char] -> ByteString -> IO ()
`L.writeFile` ByteString
lbs)

mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
mkFileInfoFile :: Text -> Text -> [Char] -> FileInfo
mkFileInfoFile Text
name Text
ct [Char]
fp = Text
-> Text
-> ConduitT () ByteString (ResourceT IO) ()
-> ([Char] -> IO ())
-> FileInfo
FileInfo Text
name Text
ct (forall (m :: * -> *) i.
MonadResource m =>
[Char] -> ConduitT i ByteString m ()
sourceFile [Char]
fp) (\[Char]
dst -> forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
[Char] -> ConduitT i ByteString m ()
sourceFile [Char]
fp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadResource m =>
[Char] -> ConduitT ByteString o m ()
sinkFile [Char]
dst)

mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource :: Text
-> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource Text
name Text
ct ConduitT () ByteString (ResourceT IO) ()
src = Text
-> Text
-> ConduitT () ByteString (ResourceT IO) ()
-> ([Char] -> IO ())
-> FileInfo
FileInfo Text
name Text
ct ConduitT () ByteString (ResourceT IO) ()
src (\[Char]
dst -> forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString (ResourceT IO) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadResource m =>
[Char] -> ConduitT ByteString o m ()
sinkFile [Char]
dst)

tokenKey :: IsString a => a
tokenKey :: forall a. IsString a => a
tokenKey = a
"_TOKEN"

langKey :: IsString a => a
langKey :: forall a. IsString a => a
langKey = a
"_LANG"