module Network.CGI.Protocol (
CGIRequest(..), Input(..),
CGIResult(..),
Headers, HeaderName(..),
hRunCGI, runCGIEnvFPS,
decodeInput, takeInput,
getCGIVars,
logCGI,
formEncode, urlEncode, formDecode, urlDecode,
maybeRead, replace
) where
import Control.Monad.Trans (MonadIO(..))
import Data.Char (chr, isHexDigit, digitToInt)
import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Network.URI (escapeURIString,isUnescapedInURI)
import System.Environment (getEnvironment)
import System.IO (Handle, hPutStrLn, stderr, hFlush, hSetBinaryMode)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Typeable
import Network.Multipart
data CGIRequest =
CGIRequest {
CGIRequest -> Map String String
cgiVars :: Map String String,
CGIRequest -> [(String, Input)]
cgiInputs :: [(String, Input)],
CGIRequest -> ByteString
cgiRequestBody :: ByteString
}
deriving (Int -> CGIRequest -> ShowS
[CGIRequest] -> ShowS
CGIRequest -> String
(Int -> CGIRequest -> ShowS)
-> (CGIRequest -> String)
-> ([CGIRequest] -> ShowS)
-> Show CGIRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGIRequest] -> ShowS
$cshowList :: [CGIRequest] -> ShowS
show :: CGIRequest -> String
$cshow :: CGIRequest -> String
showsPrec :: Int -> CGIRequest -> ShowS
$cshowsPrec :: Int -> CGIRequest -> ShowS
Show)
data Input = Input {
Input -> ByteString
inputValue :: ByteString,
Input -> Maybe String
inputFilename :: Maybe String,
Input -> ContentType
inputContentType :: ContentType
}
deriving Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Int -> Input -> ShowS
$cshowsPrec :: Int -> Input -> ShowS
Show
data CGIResult = CGIOutput ByteString
| CGINothing
deriving (Int -> CGIResult -> ShowS
[CGIResult] -> ShowS
CGIResult -> String
(Int -> CGIResult -> ShowS)
-> (CGIResult -> String)
-> ([CGIResult] -> ShowS)
-> Show CGIResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CGIResult] -> ShowS
$cshowList :: [CGIResult] -> ShowS
show :: CGIResult -> String
$cshow :: CGIResult -> String
showsPrec :: Int -> CGIResult -> ShowS
$cshowsPrec :: Int -> CGIResult -> ShowS
Show, ReadPrec [CGIResult]
ReadPrec CGIResult
Int -> ReadS CGIResult
ReadS [CGIResult]
(Int -> ReadS CGIResult)
-> ReadS [CGIResult]
-> ReadPrec CGIResult
-> ReadPrec [CGIResult]
-> Read CGIResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [CGIResult]
$creadListPrec :: ReadPrec [CGIResult]
readPrec :: ReadPrec CGIResult
$creadPrec :: ReadPrec CGIResult
readList :: ReadS [CGIResult]
$creadList :: ReadS [CGIResult]
readsPrec :: Int -> ReadS CGIResult
$creadsPrec :: Int -> ReadS CGIResult
Read, CGIResult -> CGIResult -> Bool
(CGIResult -> CGIResult -> Bool)
-> (CGIResult -> CGIResult -> Bool) -> Eq CGIResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CGIResult -> CGIResult -> Bool
$c/= :: CGIResult -> CGIResult -> Bool
== :: CGIResult -> CGIResult -> Bool
$c== :: CGIResult -> CGIResult -> Bool
Eq, Eq CGIResult
Eq CGIResult =>
(CGIResult -> CGIResult -> Ordering)
-> (CGIResult -> CGIResult -> Bool)
-> (CGIResult -> CGIResult -> Bool)
-> (CGIResult -> CGIResult -> Bool)
-> (CGIResult -> CGIResult -> Bool)
-> (CGIResult -> CGIResult -> CGIResult)
-> (CGIResult -> CGIResult -> CGIResult)
-> Ord CGIResult
CGIResult -> CGIResult -> Bool
CGIResult -> CGIResult -> Ordering
CGIResult -> CGIResult -> CGIResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CGIResult -> CGIResult -> CGIResult
$cmin :: CGIResult -> CGIResult -> CGIResult
max :: CGIResult -> CGIResult -> CGIResult
$cmax :: CGIResult -> CGIResult -> CGIResult
>= :: CGIResult -> CGIResult -> Bool
$c>= :: CGIResult -> CGIResult -> Bool
> :: CGIResult -> CGIResult -> Bool
$c> :: CGIResult -> CGIResult -> Bool
<= :: CGIResult -> CGIResult -> Bool
$c<= :: CGIResult -> CGIResult -> Bool
< :: CGIResult -> CGIResult -> Bool
$c< :: CGIResult -> CGIResult -> Bool
compare :: CGIResult -> CGIResult -> Ordering
$ccompare :: CGIResult -> CGIResult -> Ordering
$cp1Ord :: Eq CGIResult
Ord, Typeable)
hRunCGI :: MonadIO m =>
[(String,String)]
-> Handle
-> Handle
-> (CGIRequest -> m (Headers, CGIResult))
-> m ()
hRunCGI :: [(String, String)]
-> Handle
-> Handle
-> (CGIRequest -> m (Headers, CGIResult))
-> m ()
hRunCGI env :: [(String, String)]
env hin :: Handle
hin hout :: Handle
hout f :: CGIRequest -> m (Headers, CGIResult)
f =
do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Bool -> IO ()
hSetBinaryMode Handle
hin Bool
True
ByteString
inp <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
BS.hGetContents Handle
hin
ByteString
outp <- [(String, String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
forall (m :: * -> *).
Monad m =>
[(String, String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS [(String, String)]
env ByteString
inp CGIRequest -> m (Headers, CGIResult)
f
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
hout ByteString
outp
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
hout
runCGIEnvFPS :: Monad m =>
[(String,String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS :: [(String, String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS vars :: [(String, String)]
vars inp :: ByteString
inp f :: CGIRequest -> m (Headers, CGIResult)
f
= do let (inputs :: [(String, Input)]
inputs,body :: ByteString
body) = [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
decodeInput [(String, String)]
vars ByteString
inp
(hs :: Headers
hs,outp :: CGIResult
outp) <- CGIRequest -> m (Headers, CGIResult)
f (CGIRequest -> m (Headers, CGIResult))
-> CGIRequest -> m (Headers, CGIResult)
forall a b. (a -> b) -> a -> b
$ CGIRequest :: Map String String -> [(String, Input)] -> ByteString -> CGIRequest
CGIRequest {
cgiVars :: Map String String
cgiVars = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
vars,
cgiInputs :: [(String, Input)]
cgiInputs = [(String, Input)]
inputs,
cgiRequestBody :: ByteString
cgiRequestBody = ByteString
body
}
ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ case CGIResult
outp of
CGIOutput c :: ByteString
c -> ByteString -> Headers -> ByteString
formatResponse ByteString
c Headers
hs'
where hs' :: Headers
hs' = if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (HeaderName -> Headers -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
ct Headers
hs)
then Headers
hs else Headers
hs Headers -> Headers -> Headers
forall a. [a] -> [a] -> [a]
++ [(HeaderName
ct,String
defaultContentType)]
ct :: HeaderName
ct = String -> HeaderName
HeaderName "Content-type"
CGINothing -> ByteString -> Headers -> ByteString
formatResponse ByteString
BS.empty Headers
hs
formatResponse :: ByteString -> Headers -> ByteString
formatResponse :: ByteString -> Headers -> ByteString
formatResponse c :: ByteString
c hs :: Headers
hs =
[ByteString] -> ByteString
unlinesCrLf ([String -> ByteString
BS.pack (String
nString -> ShowS
forall a. [a] -> [a] -> [a]
++": "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
v) | (HeaderName n :: String
n,v :: String
v) <- Headers
hs]
[ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
BS.empty,ByteString
c])
where unlinesCrLf :: [ByteString] -> ByteString
unlinesCrLf = ByteString -> [ByteString] -> ByteString
BS.intercalate (String -> ByteString
BS.pack "\r\n")
defaultContentType :: String
defaultContentType :: String
defaultContentType = "text/html; charset=ISO-8859-1"
decodeInput :: [(String,String)]
-> ByteString
-> ([(String,Input)],ByteString)
decodeInput :: [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
decodeInput env :: [(String, String)]
env inp :: ByteString
inp =
let (inputs :: [(String, Input)]
inputs, body :: ByteString
body) = [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
bodyInput [(String, String)]
env ByteString
inp in ([(String, String)] -> [(String, Input)]
queryInput [(String, String)]
env [(String, Input)] -> [(String, Input)] -> [(String, Input)]
forall a. [a] -> [a] -> [a]
++ [(String, Input)]
inputs, ByteString
body)
simpleInput :: String -> Input
simpleInput :: String -> Input
simpleInput v :: String
v = Input :: ByteString -> Maybe String -> ContentType -> Input
Input { inputValue :: ByteString
inputValue = String -> ByteString
BS.pack String
v,
inputFilename :: Maybe String
inputFilename = Maybe String
forall a. Maybe a
Nothing,
inputContentType :: ContentType
inputContentType = ContentType
defaultInputType }
defaultInputType :: ContentType
defaultInputType :: ContentType
defaultInputType = String -> String -> [(String, String)] -> ContentType
ContentType "text" "plain" [("charset","windows-1252")]
getCGIVars :: MonadIO m => m [(String,String)]
getCGIVars :: m [(String, String)]
getCGIVars = IO [(String, String)] -> m [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
logCGI :: MonadIO m => String -> m ()
logCGI :: String -> m ()
logCGI s :: String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s)
queryInput :: [(String,String)]
-> [(String,Input)]
queryInput :: [(String, String)] -> [(String, Input)]
queryInput env :: [(String, String)]
env = String -> [(String, Input)]
formInput (String -> [(String, Input)]) -> String -> [(String, Input)]
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookupOrNil "QUERY_STRING" [(String, String)]
env
formInput :: String
-> [(String,Input)]
formInput :: String -> [(String, Input)]
formInput qs :: String
qs = [(String
n, String -> Input
simpleInput String
v) | (n :: String
n,v :: String
v) <- String -> [(String, String)]
formDecode String
qs]
formEncode :: [(String,String)] -> String
formEncode :: [(String, String)] -> String
formEncode xs :: [(String, String)]
xs =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "&" [ShowS
urlEncode String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
urlEncode String
v | (n :: String
n,v :: String
v) <- [(String, String)]
xs]
urlEncode :: String -> String
urlEncode :: ShowS
urlEncode = Char -> Char -> ShowS
forall a. Eq a => a -> a -> [a] -> [a]
replace ' ' '+' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
okChar
where okChar :: Char -> Bool
okChar c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
||
(Char -> Bool
isUnescapedInURI Char
c Bool -> Bool -> Bool
&& Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` "&=+")
formDecode :: String -> [(String,String)]
formDecode :: String -> [(String, String)]
formDecode "" = []
formDecode s :: String
s = (ShowS
urlDecode String
n, ShowS
urlDecode (Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1 String
v)) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: String -> [(String, String)]
formDecode (Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1 String
rs)
where (nv :: String
nv,rs :: String
rs) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='&') String
s
(n :: String
n,v :: String
v) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='=') String
nv
urlDecode :: String -> String
urlDecode :: ShowS
urlDecode = ShowS
unEscapeString ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char -> ShowS
forall a. Eq a => a -> a -> [a] -> [a]
replace '+' ' '
unEscapeString :: String -> String
unEscapeString :: ShowS
unEscapeString [] = ""
unEscapeString ('%':x1 :: Char
x1:x2 :: Char
x2:s :: String
s) | Char -> Bool
isHexDigit Char
x1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
x2 =
Int -> Char
chr (Char -> Int
digitToInt Char
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
x2) Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unEscapeString String
s
unEscapeString (c :: Char
c:s :: String
s) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unEscapeString String
s
bodyInput :: [(String,String)]
-> ByteString
-> ([(String,Input)], ByteString)
bodyInput :: [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
bodyInput env :: [(String, String)]
env inp :: ByteString
inp =
case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "REQUEST_METHOD" [(String, String)]
env of
Just "POST" ->
let ctype :: Maybe ContentType
ctype = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "CONTENT_TYPE" [(String, String)]
env Maybe String -> (String -> Maybe ContentType) -> Maybe ContentType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe ContentType
forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType
in Maybe ContentType -> ByteString -> ([(String, Input)], ByteString)
decodeBody Maybe ContentType
ctype (ByteString -> ([(String, Input)], ByteString))
-> ByteString -> ([(String, Input)], ByteString)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> ByteString -> ByteString
takeInput [(String, String)]
env ByteString
inp
_ -> ([], ByteString
inp)
decodeBody :: Maybe ContentType
-> ByteString
-> ([(String,Input)], ByteString)
decodeBody :: Maybe ContentType -> ByteString -> ([(String, Input)], ByteString)
decodeBody ctype :: Maybe ContentType
ctype inp :: ByteString
inp =
case Maybe ContentType
ctype of
Just (ContentType "application" "x-www-form-urlencoded" _)
-> (String -> [(String, Input)]
formInput (ByteString -> String
BS.unpack ByteString
inp), ByteString
BS.empty)
Just (ContentType "multipart" "form-data" ps :: [(String, String)]
ps)
-> ([(String, String)] -> ByteString -> [(String, Input)]
multipartDecode [(String, String)]
ps ByteString
inp, ByteString
BS.empty)
Just _ -> ([], ByteString
inp)
Nothing -> (String -> [(String, Input)]
formInput (ByteString -> String
BS.unpack ByteString
inp), ByteString
BS.empty)
takeInput :: [(String,String)]
-> ByteString
-> ByteString
takeInput :: [(String, String)] -> ByteString -> ByteString
takeInput env :: [(String, String)]
env req :: ByteString
req =
case Maybe Int64
len of
Just l :: Int64
l -> Int64 -> ByteString -> ByteString
BS.take Int64
l ByteString
req
Nothing -> ByteString
BS.empty
where len :: Maybe Int64
len = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "CONTENT_LENGTH" [(String, String)]
env Maybe String -> (String -> Maybe Int64) -> Maybe Int64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int64
forall a. Read a => String -> Maybe a
maybeRead
multipartDecode :: [(String,String)]
-> ByteString
-> [(String,Input)]
multipartDecode :: [(String, String)] -> ByteString -> [(String, Input)]
multipartDecode ps :: [(String, String)]
ps inp :: ByteString
inp =
case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "boundary" [(String, String)]
ps of
Just b :: String
b -> let MultiPart bs :: [BodyPart]
bs = String -> ByteString -> MultiPart
parseMultipartBody String
b ByteString
inp
in (BodyPart -> (String, Input)) -> [BodyPart] -> [(String, Input)]
forall a b. (a -> b) -> [a] -> [b]
map BodyPart -> (String, Input)
bodyPartToInput [BodyPart]
bs
Nothing -> []
bodyPartToInput :: BodyPart -> (String,Input)
bodyPartToInput :: BodyPart -> (String, Input)
bodyPartToInput (BodyPart hs :: Headers
hs b :: ByteString
b) =
case Headers -> Maybe ContentDisposition
forall (m :: * -> *).
MonadFail m =>
Headers -> m ContentDisposition
getContentDisposition Headers
hs of
Just (ContentDisposition "form-data" ps :: [(String, String)]
ps) ->
(String -> [(String, String)] -> String
lookupOrNil "name" [(String, String)]
ps,
Input :: ByteString -> Maybe String -> ContentType -> Input
Input { inputValue :: ByteString
inputValue = ByteString
b,
inputFilename :: Maybe String
inputFilename = String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "filename" [(String, String)]
ps,
inputContentType :: ContentType
inputContentType = ContentType
ctype })
_ -> ("ERROR",String -> Input
simpleInput "ERROR")
where ctype :: ContentType
ctype = ContentType -> Maybe ContentType -> ContentType
forall a. a -> Maybe a -> a
fromMaybe ContentType
defaultInputType (Headers -> Maybe ContentType
forall (m :: * -> *). MonadFail m => Headers -> m ContentType
getContentType Headers
hs)
replace :: Eq a =>
a
-> a
-> [a]
-> [a]
replace :: a -> a -> [a] -> [a]
replace x :: a
x y :: a
y = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\z :: a
z -> if a
z a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x then a
y else a
z)
maybeRead :: Read a => String -> Maybe a
maybeRead :: String -> Maybe a
maybeRead = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, String)] -> Maybe (a, String)
forall a. [a] -> Maybe a
listToMaybe ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. Read a => ReadS a
reads
lookupOrNil :: String -> [(String,String)] -> String
lookupOrNil :: String -> [(String, String)] -> String
lookupOrNil n :: String
n = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe String -> String)
-> ([(String, String)] -> Maybe String)
-> [(String, String)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n