module General.Web(
responseOK, responseNotFound,
responseFlatten, responseEvaluate, responseRewrite,
URL, filePathToURL, combineURL, escapeURL, (++%), unescapeURL,
escapeHTML, (++&), htmlTag,
Args, cgiArgs, cgiResponse, parseHttpQueryArgs
) where
#ifndef MIN_VERSION_wai
#define MIN_VERSION_wai(a,b,c) 1
#endif
import General.System
import General.Base
import System.FilePath
import Network.Wai
#if MIN_VERSION_wai(3, 0, 0)
import Data.IORef
#endif
#if MIN_VERSION_wai(2, 0, 0)
import Network.Wai.Internal
#endif
import Network.HTTP.Types
import Data.CaseInsensitive(original)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Blaze.ByteString.Builder(toLazyByteString)
import Data.Conduit.List(consume)
import Data.Conduit(($$),Flush(Chunk))
#if !MIN_VERSION_wai(2, 0, 0)
import Control.Monad.Trans.Resource (runResourceT)
#endif
type Args = [(String, String)]
responseOK = responseLBS status200
responseNotFound x = responseLBS status404 [] $ fromString $ "File not found: " ++ x
responseFlatten :: Response -> IO (Status, ResponseHeaders, LBString)
responseFlatten r = do
#if MIN_VERSION_wai(3, 0, 0)
let (s,hs,withBody) = responseToStream r
ref <- newIORef mempty
let addChunk builder = modifyIORef ref (<> builder)
withBody $ \body -> body addChunk (return ())
builder <- readIORef ref
let res = toLazyByteString builder
return (s,hs,res)
#elif MIN_VERSION_wai(2, 0, 0)
let (s,hs,withSrc) = responseToSource r
chunks <- withSrc $ \src -> src $$ consume
let res = toLazyByteString $ mconcat [x | Chunk x <- chunks]
return (s,hs,res)
#else
let (s,hs,rest) = responseSource r
chunks <- runResourceT $ rest $$ consume
let res = toLazyByteString $ mconcat [x | Chunk x <- chunks]
return (s,hs,res)
#endif
responseEvaluate :: Response -> IO ()
responseEvaluate (ResponseBuilder _ _ x) = LBS.length (toLazyByteString x) `seq` return ()
responseEvaluate _ = return ()
responseRewrite :: (LBString -> LBString) -> Response -> IO Response
responseRewrite f r = do
(a,b,c) <- responseFlatten r
return $ responseLBS a b $ f c
escapeHTML :: String -> String
escapeHTML = concatMap f
where
f '<' = "<"
f '>' = ">"
f '&' = "&"
f '\"' = """
f x = [x]
(++&) :: String -> String -> String
a ++& b = a ++ escapeHTML b
htmlTag :: String -> String -> String
htmlTag x y = "<" ++ x ++ ">" ++ y ++ "</" ++ x ++ ">"
filePathToURL :: FilePath -> URL
filePathToURL xs = "file://" ++ ['/' | not $ "/" `isPrefixOf` ys] ++ ys
where ys = map (\x -> if isPathSeparator x then '/' else x) xs
combineURL :: String -> String -> String
combineURL a b
| any (`isPrefixOf` b) ["http:","https:","file:"] = b
| otherwise = a ++ b
unescapeURL :: String -> String
unescapeURL ('+':xs) = ' ' : unescapeURL xs
unescapeURL ('%':a:b:xs) | [(v,"")] <- readHex [a,b] = chr v : unescapeURL xs
unescapeURL (x:xs) = x : unescapeURL xs
unescapeURL [] = []
escapeURL :: String -> String
escapeURL = concatMap f
where
f x | isAlphaNum x || x `elem` "-" = [x]
| x == ' ' = "+"
| otherwise = '%' : ['0' | length s == 1] ++ s
where s = showHex (ord x) ""
(++%) :: String -> String -> String
a ++% b = a ++ escapeURL b
cgiVariable :: IO (Maybe String)
cgiVariable = do
str <- getEnvVar "QUERY_STRING"
if isJust str
then return str
else fmap (fmap $ const "") $ getEnvVar "REQUEST_URI"
cgiArgs :: IO (Maybe Args)
cgiArgs = do
x <- cgiVariable
return $ case x of
Nothing -> Nothing
Just y -> Just $ parseHttpQueryArgs $ ['=' | '=' `notElem` y] ++ y
cgiResponse :: Response -> IO ()
cgiResponse r = do
(status,headers,body) <- responseFlatten r
LBS.putStr $ LBS.unlines $
[LBS.fromChunks [original a, fromString ": ", b] | (a,b) <- headers] ++
[fromString "",body]
parseHttpQueryArgs :: String -> Args
parseHttpQueryArgs xs = mapMaybe (f . splitPair "=") $ splitList "&" xs
where f Nothing = Nothing
f (Just (a,b)) = Just (unescapeURL a, unescapeURL b)
splitList :: Eq a => [a] -> [a] -> [[a]]
splitList find str = if isJust q then a : splitList find b else [str]
where
q = splitPair find str
Just (a, b) = q
splitPair :: Eq a => [a] -> [a] -> Maybe ([a], [a])
splitPair find str = f str
where
f [] = Nothing
f x | isPrefixOf find x = Just ([], drop (length find) x)
| otherwise = if isJust q then Just (head x:a, b) else Nothing
where
q = f (tail x)
Just (a, b) = q