module RunHTTP(runHTTP,Options(..),cgiHandler) where
import Network.URI(uriPath,uriQuery)
import CGI(ContentType(..))
import CGI(CGIResult(..),CGIRequest(..),Input(..),
                            Headers,HeaderName(..))
import CGI(runCGIT)
import Network.Shed.Httpd(initServer,Request(..),Response(..))
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)
import qualified Data.Map as M(fromList)
import URLEncoding(decodeQuery)

data Options = Options { Options -> String
documentRoot :: String, Options -> Int
port :: Int } deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show

runHTTP :: Options -> CGIT IO CGIResult -> IO Server
runHTTP (Options String
root Int
port) = Int -> (Request -> IO Response) -> IO Server
initServer Int
port ((Request -> IO Response) -> IO Server)
-> (CGIT IO CGIResult -> Request -> IO Response)
-> CGIT IO CGIResult
-> IO Server
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CGIT IO CGIResult -> Request -> IO Response
forall (f :: * -> *).
Monad f =>
String -> CGIT f CGIResult -> Request -> f Response
cgiHandler String
root

cgiHandler :: String -> CGIT f CGIResult -> Request -> f Response
cgiHandler String
root CGIT f CGIResult
h = ((Headers, CGIResult) -> Response)
-> f (Headers, CGIResult) -> f Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Headers, CGIResult) -> Response
httpResp (f (Headers, CGIResult) -> f Response)
-> (Request -> f (Headers, CGIResult)) -> Request -> f Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGIT f CGIResult -> CGIRequest -> f (Headers, CGIResult)
forall (m :: * -> *) a.
Monad m =>
CGIT m a -> CGIRequest -> m (Headers, a)
runCGIT CGIT f CGIResult
h (CGIRequest -> f (Headers, CGIResult))
-> (Request -> CGIRequest) -> Request -> f (Headers, CGIResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Request -> CGIRequest
cgiReq String
root

httpResp :: (Headers,CGIResult) -> Response
httpResp :: (Headers, CGIResult) -> Response
httpResp (Headers
hdrs,CGIResult
r) = Int -> [(String, String)] -> String -> Response
Response Int
code (((HeaderName, String) -> (String, String))
-> Headers -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (HeaderName, String) -> (String, String)
forall b. (HeaderName, b) -> (String, b)
name Headers
hdrs) (CGIResult -> String
body CGIResult
r)
  where
    code :: Int
code = Int -> (String -> Int) -> Maybe String -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
200 (String -> Int
forall a. Read a => String -> a
read(String -> Int) -> ShowS -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[String] -> String
forall a. [a] -> a
head([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [String]
words) (HeaderName -> Headers -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> HeaderName
HeaderName String
"Status") Headers
hdrs)
    body :: CGIResult -> String
body CGIResult
CGINothing = String
""
    body (CGIOutput ByteString
s) = ByteString -> String
BS.unpack ByteString
s

    name :: (HeaderName, b) -> (String, b)
name (HeaderName String
n,b
v) = (String
n,b
v)

cgiReq :: String -> Request -> CGIRequest
cgiReq :: String -> Request -> CGIRequest
cgiReq String
root (Request String
method URI
uri [(String, String)]
hdrs String
body)
  | String
method String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"POST" = Map String String -> [(String, Input)] -> ByteString -> CGIRequest
CGIRequest Map String String
vars (((String, String) -> (String, Input))
-> [(String, String)] -> [(String, Input)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, Input)
forall a. (a, String) -> (a, Input)
input (String -> [(String, String)]
decodeQuery String
body)) ByteString
BS.empty
  | Bool
otherwise        = Map String String -> [(String, Input)] -> ByteString -> CGIRequest
CGIRequest Map String String
vars (((String, String) -> (String, Input))
-> [(String, String)] -> [(String, Input)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, Input)
forall a. (a, String) -> (a, Input)
input (String -> [(String, String)]
decodeQuery String
qs  )) ByteString
BS.empty -- assumes method=="GET"
  where
    vars :: Map String String
vars = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String
"REQUEST_METHOD",String
method),
                       (String
"REQUEST_URI",URI -> String
forall a. Show a => a -> String
show URI
uri),
                       (String
"SCRIPT_FILENAME",String
rootString -> ShowS
forall a. [a] -> [a] -> [a]
++URI -> String
uriPath URI
uri),
                       (String
"QUERY_STRING",String
qs),
                       (String
"HTTP_ACCEPT_LANGUAGE",String
al)]
    qs :: String
qs = case URI -> String
uriQuery URI
uri of
           Char
'?':Char
'&':String
s -> String
s -- httpd-shed bug workaround
           Char
'?':String
s -> String
s
           String
s -> String
s
    al :: String
al = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
forall a. a -> a
id (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Accept-Language" [(String, String)]
hdrs

    input :: (a, String) -> (a, Input)
input (a
name,String
val) = (a
name,ByteString -> Maybe String -> ContentType -> Input
Input (String -> ByteString
BS.pack String
val) Maybe String
forall a. Maybe a
Nothing ContentType
plaintext)
    plaintext :: ContentType
plaintext = String -> String -> [(String, String)] -> ContentType
ContentType String
"text" String
"plain" []