{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# options_ghc -Wno-unused-imports #-}
module Web.Scotty.Util
    ( lazyTextToStrictByteString
    , strictByteStringToLazyText
    , decodeUtf8Lenient
    , mkResponse
    , replace
    , add
    , addIfNotPresent
    , socketDescription
    , readRequestBody
    ) where

import Network.Socket (SockAddr(..), Socket, getSocketName, socketPort)
import Network.Wai

import Control.Exception
import Control.Monad (when)
import qualified Data.ByteString as B
import qualified Data.Text as TP (Text, pack)
import qualified Data.Text.Lazy as TL
import           Data.Text.Encoding as ES
import qualified Data.Text.Encoding.Error as ES

import Web.Scotty.Internal.Types

lazyTextToStrictByteString :: TL.Text -> B.ByteString
lazyTextToStrictByteString :: Text -> ByteString
lazyTextToStrictByteString = Text -> ByteString
ES.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict

strictByteStringToLazyText :: B.ByteString -> TL.Text
strictByteStringToLazyText :: ByteString -> Text
strictByteStringToLazyText = Text -> Text
TL.fromStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
ES.decodeUtf8With OnDecodeError
ES.lenientDecode

#if !MIN_VERSION_text(2,0,0)
decodeUtf8Lenient :: B.ByteString -> TP.Text
decodeUtf8Lenient = ES.decodeUtf8With ES.lenientDecode
#endif

-- Note: we currently don't support responseRaw, which may be useful
-- for websockets. However, we always read the request body, which
-- is incompatible with responseRaw responses.
mkResponse :: ScottyResponse -> Response
mkResponse :: ScottyResponse -> Response
mkResponse ScottyResponse
sr = case ScottyResponse -> Content
srContent ScottyResponse
sr of
                    ContentBuilder  Builder
b   -> Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
s ResponseHeaders
h Builder
b
                    ContentFile     FilePath
f   -> Status -> ResponseHeaders -> FilePath -> Maybe FilePart -> Response
responseFile Status
s ResponseHeaders
h FilePath
f Maybe FilePart
forall a. Maybe a
Nothing
                    ContentStream   StreamingBody
str -> Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
h StreamingBody
str
                    ContentResponse Response
res -> Response
res
    where s :: Status
s = ScottyResponse -> Status
srStatus ScottyResponse
sr
          h :: ResponseHeaders
h = ScottyResponse -> ResponseHeaders
srHeaders ScottyResponse
sr

-- Note: we assume headers are not sensitive to order here (RFC 2616 specifies they are not)
replace :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
replace :: forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
replace a
k b
v = a -> b -> [(a, b)] -> [(a, b)]
forall a b. a -> b -> [(a, b)] -> [(a, b)]
add a
k b
v ([(a, b)] -> [(a, b)])
-> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
k) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)

add :: a -> b -> [(a,b)] -> [(a,b)]
add :: forall a b. a -> b -> [(a, b)] -> [(a, b)]
add a
k b
v [(a, b)]
m = (a
k,b
v)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
m

addIfNotPresent :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
addIfNotPresent :: forall a b. Eq a => a -> b -> [(a, b)] -> [(a, b)]
addIfNotPresent a
k b
v = [(a, b)] -> [(a, b)]
go
    where go :: [(a, b)] -> [(a, b)]
go []         = [(a
k,b
v)]
          go l :: [(a, b)]
l@((a
x,b
y):[(a, b)]
r)
            | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
k    = [(a, b)]
l
            | Bool
otherwise = (a
x,b
y) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)] -> [(a, b)]
go [(a, b)]
r

-- Assemble a description from the Socket's PortID.
socketDescription :: Socket -> IO String
socketDescription :: Socket -> IO FilePath
socketDescription Socket
sock = do
  SockAddr
sockName <- Socket -> IO SockAddr
getSocketName Socket
sock
  case SockAddr
sockName of
    SockAddrUnix FilePath
u -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"unix socket " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
u
    SockAddr
_              -> (PortNumber -> FilePath) -> IO PortNumber -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\PortNumber
port -> FilePath
"port " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PortNumber -> FilePath
forall a. Show a => a -> FilePath
show PortNumber
port) (IO PortNumber -> IO FilePath) -> IO PortNumber -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Socket -> IO PortNumber
socketPort Socket
sock

-- | return request body or throw a 'ScottyException' if request body too big
readRequestBody :: IO B.ByteString -- ^ body chunk reader
                -> ([B.ByteString] -> IO [B.ByteString])
                -> Maybe Kilobytes -- ^ max body size
                -> IO [B.ByteString]
readRequestBody :: IO ByteString
-> ([ByteString] -> IO [ByteString])
-> Maybe Kilobytes
-> IO [ByteString]
readRequestBody IO ByteString
rbody [ByteString] -> IO [ByteString]
prefix Maybe Kilobytes
maxSize = do
  ByteString
b <- IO ByteString
rbody
  if ByteString -> Bool
B.null ByteString
b then
       [ByteString] -> IO [ByteString]
prefix []
    else
      do
        Maybe Kilobytes -> IO ()
checkBodyLength Maybe Kilobytes
maxSize
        IO ByteString
-> ([ByteString] -> IO [ByteString])
-> Maybe Kilobytes
-> IO [ByteString]
readRequestBody IO ByteString
rbody ([ByteString] -> IO [ByteString]
prefix ([ByteString] -> IO [ByteString])
-> ([ByteString] -> [ByteString])
-> [ByteString]
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)) Maybe Kilobytes
maxSize
    where checkBodyLength :: Maybe Kilobytes ->  IO ()
          checkBodyLength :: Maybe Kilobytes -> IO ()
checkBodyLength = \case
            Just Kilobytes
maxSize' -> do
              [ByteString]
bodySoFar <- [ByteString] -> IO [ByteString]
prefix []
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString]
bodySoFar [ByteString] -> Kilobytes -> Bool
`isBigger` Kilobytes
maxSize') IO ()
forall {b}. IO b
readUntilEmpty
            Maybe Kilobytes
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          isBigger :: [ByteString] -> Kilobytes -> Bool
isBigger [ByteString]
bodySoFar Kilobytes
maxSize' = (ByteString -> Kilobytes
B.length (ByteString -> Kilobytes)
-> ([ByteString] -> ByteString) -> [ByteString] -> Kilobytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> Kilobytes) -> [ByteString] -> Kilobytes
forall a b. (a -> b) -> a -> b
$ [ByteString]
bodySoFar) Kilobytes -> Kilobytes -> Bool
forall a. Ord a => a -> a -> Bool
> Kilobytes
maxSize' Kilobytes -> Kilobytes -> Kilobytes
forall a. Num a => a -> a -> a
* Kilobytes
1024 -- XXX this looks both inefficient and wrong
          readUntilEmpty :: IO b
readUntilEmpty = do
            ByteString
b <- IO ByteString
rbody
            if ByteString -> Bool
B.null ByteString
b
              then ScottyException -> IO b
forall e a. Exception e => e -> IO a
throwIO ScottyException
RequestTooLarge
              else IO b
readUntilEmpty