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
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
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
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]
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
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
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
Ord, Typeable)
hRunCGI :: MonadIO m =>
[(String,String)]
-> Handle
-> Handle
-> (CGIRequest -> m (Headers, CGIResult))
-> m ()
hRunCGI :: forall (m :: * -> *).
MonadIO m =>
[(String, String)]
-> Handle
-> Handle
-> (CGIRequest -> m (Headers, CGIResult))
-> m ()
hRunCGI [(String, String)]
env Handle
hin Handle
hout CGIRequest -> m (Headers, CGIResult)
f =
do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Bool -> IO ()
hSetBinaryMode Handle
hin Bool
True
ByteString
inp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
BS.hGetContents Handle
hin
ByteString
outp <- forall (m :: * -> *).
Monad m =>
[(String, String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS [(String, String)]
env ByteString
inp CGIRequest -> m (Headers, CGIResult)
f
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPut Handle
hout ByteString
outp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 :: forall (m :: * -> *).
Monad m =>
[(String, String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS [(String, String)]
vars ByteString
inp CGIRequest -> m (Headers, CGIResult)
f
= do let ([(String, Input)]
inputs,ByteString
body) = [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
decodeInput [(String, String)]
vars ByteString
inp
(Headers
hs,CGIResult
outp) <- CGIRequest -> m (Headers, CGIResult)
f forall a b. (a -> b) -> a -> b
$ CGIRequest {
cgiVars :: Map String String
cgiVars = 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
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case CGIResult
outp of
CGIOutput ByteString
c -> ByteString -> Headers -> ByteString
formatResponse ByteString
c Headers
hs'
where hs' :: Headers
hs' = if forall a. Maybe a -> Bool
isJust (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
ct Headers
hs)
then Headers
hs else Headers
hs forall a. [a] -> [a] -> [a]
++ [(HeaderName
ct,String
defaultContentType)]
ct :: HeaderName
ct = String -> HeaderName
HeaderName String
"Content-type"
CGIResult
CGINothing -> ByteString -> Headers -> ByteString
formatResponse ByteString
BS.empty Headers
hs
formatResponse :: ByteString -> Headers -> ByteString
formatResponse :: ByteString -> Headers -> ByteString
formatResponse ByteString
c Headers
hs =
[ByteString] -> ByteString
unlinesCrLf ([String -> ByteString
BS.pack (String
nforall a. [a] -> [a] -> [a]
++String
": "forall a. [a] -> [a] -> [a]
++String
v) | (HeaderName String
n,String
v) <- Headers
hs]
forall a. [a] -> [a] -> [a]
++ [ByteString
BS.empty,ByteString
c])
where unlinesCrLf :: [ByteString] -> ByteString
unlinesCrLf = ByteString -> [ByteString] -> ByteString
BS.intercalate (String -> ByteString
BS.pack String
"\r\n")
defaultContentType :: String
defaultContentType :: String
defaultContentType = String
"text/html; charset=ISO-8859-1"
decodeInput :: [(String,String)]
-> ByteString
-> ([(String,Input)],ByteString)
decodeInput :: [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
decodeInput [(String, String)]
env ByteString
inp =
let ([(String, Input)]
inputs, ByteString
body) = [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
bodyInput [(String, String)]
env ByteString
inp in ([(String, String)] -> [(String, Input)]
queryInput [(String, String)]
env forall a. [a] -> [a] -> [a]
++ [(String, Input)]
inputs, ByteString
body)
simpleInput :: String -> Input
simpleInput :: String -> Input
simpleInput String
v = Input { inputValue :: ByteString
inputValue = String -> ByteString
BS.pack String
v,
inputFilename :: Maybe String
inputFilename = forall a. Maybe a
Nothing,
inputContentType :: ContentType
inputContentType = ContentType
defaultInputType }
defaultInputType :: ContentType
defaultInputType :: ContentType
defaultInputType = String -> String -> [(String, String)] -> ContentType
ContentType String
"text" String
"plain" [(String
"charset",String
"windows-1252")]
getCGIVars :: MonadIO m => m [(String,String)]
getCGIVars :: forall (m :: * -> *). MonadIO m => m [(String, String)]
getCGIVars = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
logCGI :: MonadIO m => String -> m ()
logCGI :: forall (m :: * -> *). MonadIO m => String -> m ()
logCGI String
s = 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 [(String, String)]
env = String -> [(String, Input)]
formInput forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> String
lookupOrNil String
"QUERY_STRING" [(String, String)]
env
formInput :: String
-> [(String,Input)]
formInput :: String -> [(String, Input)]
formInput String
qs = [(String
n, String -> Input
simpleInput String
v) | (String
n,String
v) <- String -> [(String, String)]
formDecode String
qs]
formEncode :: [(String,String)] -> String
formEncode :: [(String, String)] -> String
formEncode [(String, String)]
xs =
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" [ShowS
urlEncode String
n forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ ShowS
urlEncode String
v | (String
n,String
v) <- [(String, String)]
xs]
urlEncode :: String -> String
urlEncode :: ShowS
urlEncode = forall a. Eq a => a -> a -> [a] -> [a]
replace Char
' ' Char
'+' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
okChar
where okChar :: Char -> Bool
okChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
||
(Char -> Bool
isUnescapedInURI Char
c Bool -> Bool -> Bool
&& Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"&=+")
formDecode :: String -> [(String,String)]
formDecode :: String -> [(String, String)]
formDecode String
"" = []
formDecode String
s = (ShowS
urlDecode String
n, ShowS
urlDecode (forall a. Int -> [a] -> [a]
drop Int
1 String
v)) forall a. a -> [a] -> [a]
: String -> [(String, String)]
formDecode (forall a. Int -> [a] -> [a]
drop Int
1 String
rs)
where (String
nv,String
rs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
'&') String
s
(String
n,String
v) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
'=') String
nv
urlDecode :: String -> String
urlDecode :: ShowS
urlDecode = ShowS
unEscapeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> a -> [a] -> [a]
replace Char
'+' Char
' '
unEscapeString :: String -> String
unEscapeString :: ShowS
unEscapeString [] = String
""
unEscapeString (Char
'%':Char
x1:Char
x2:String
s) | Char -> Bool
isHexDigit Char
x1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
x2 =
Int -> Char
chr (Char -> Int
digitToInt Char
x1 forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
x2) forall a. a -> [a] -> [a]
: ShowS
unEscapeString String
s
unEscapeString (Char
c:String
s) = Char
c forall a. a -> [a] -> [a]
: ShowS
unEscapeString String
s
bodyInput :: [(String,String)]
-> ByteString
-> ([(String,Input)], ByteString)
bodyInput :: [(String, String)] -> ByteString -> ([(String, Input)], ByteString)
bodyInput [(String, String)]
env ByteString
inp =
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"REQUEST_METHOD" [(String, String)]
env of
Just String
"POST" ->
let ctype :: Maybe ContentType
ctype = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CONTENT_TYPE" [(String, String)]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => String -> m ContentType
parseContentType
in Maybe ContentType -> ByteString -> ([(String, Input)], ByteString)
decodeBody Maybe ContentType
ctype forall a b. (a -> b) -> a -> b
$ [(String, String)] -> ByteString -> ByteString
takeInput [(String, String)]
env ByteString
inp
Maybe String
_ -> ([], ByteString
inp)
decodeBody :: Maybe ContentType
-> ByteString
-> ([(String,Input)], ByteString)
decodeBody :: Maybe ContentType -> ByteString -> ([(String, Input)], ByteString)
decodeBody Maybe ContentType
ctype ByteString
inp =
case Maybe ContentType
ctype of
Just (ContentType String
"application" String
"x-www-form-urlencoded" [(String, String)]
_)
-> (String -> [(String, Input)]
formInput (ByteString -> String
BS.unpack ByteString
inp), ByteString
BS.empty)
Just (ContentType String
"multipart" String
"form-data" [(String, String)]
ps)
-> ([(String, String)] -> ByteString -> [(String, Input)]
multipartDecode [(String, String)]
ps ByteString
inp, ByteString
BS.empty)
Just ContentType
_ -> ([], ByteString
inp)
Maybe ContentType
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 [(String, String)]
env ByteString
req =
case Maybe Int64
len of
Just Int64
l -> Int64 -> ByteString -> ByteString
BS.take Int64
l ByteString
req
Maybe Int64
Nothing -> ByteString
BS.empty
where len :: Maybe Int64
len = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"CONTENT_LENGTH" [(String, String)]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => String -> Maybe a
maybeRead
multipartDecode :: [(String,String)]
-> ByteString
-> [(String,Input)]
multipartDecode :: [(String, String)] -> ByteString -> [(String, Input)]
multipartDecode [(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 -> let MultiPart [BodyPart]
bs = String -> ByteString -> MultiPart
parseMultipartBody String
b ByteString
inp
in forall a b. (a -> b) -> [a] -> [b]
map BodyPart -> (String, Input)
bodyPartToInput [BodyPart]
bs
Maybe String
Nothing -> []
bodyPartToInput :: BodyPart -> (String,Input)
bodyPartToInput :: BodyPart -> (String, Input)
bodyPartToInput (BodyPart Headers
hs ByteString
b) =
case forall (m :: * -> *).
MonadFail m =>
Headers -> m ContentDisposition
getContentDisposition Headers
hs of
Just (ContentDisposition String
"form-data" [(String, String)]
ps) ->
(String -> [(String, String)] -> String
lookupOrNil String
"name" [(String, String)]
ps,
Input { inputValue :: ByteString
inputValue = ByteString
b,
inputFilename :: Maybe String
inputFilename = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"filename" [(String, String)]
ps,
inputContentType :: ContentType
inputContentType = ContentType
ctype })
Maybe ContentDisposition
_ -> (String
"ERROR",String -> Input
simpleInput String
"ERROR")
where ctype :: ContentType
ctype = forall a. a -> Maybe a -> a
fromMaybe ContentType
defaultInputType (forall (m :: * -> *). MonadFail m => Headers -> m ContentType
getContentType Headers
hs)
replace :: Eq a =>
a
-> a
-> [a]
-> [a]
replace :: forall a. Eq a => a -> a -> [a] -> [a]
replace a
x a
y = forall a b. (a -> b) -> [a] -> [b]
map (\a
z -> if a
z forall a. Eq a => a -> a -> Bool
== a
x then a
y else a
z)
maybeRead :: Read a => String -> Maybe a
maybeRead :: forall a. Read a => String -> Maybe a
maybeRead = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => ReadS a
reads
lookupOrNil :: String -> [(String,String)] -> String
lookupOrNil :: String -> [(String, String)] -> String
lookupOrNil String
n = forall a. a -> Maybe a -> a
fromMaybe String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
n