HAppS-Server-0.9.2: src/HAppS/Server/SimpleHTTP.hs
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
-----------------------------------------------------------------------------
-- |
-- Module : HAppS.Server.SimpleHTTP
-- Copyright : (c) HAppS Inc 2007
-- License : BSD-like
--
-- Maintainer : lemmih@vo.com
-- Stability : provisional
-- Portability : requires mtl
--
-- SimpleHTTP provides a back-end independent API for handling HTTP requests.
--
-- By default, the built-in HTTP server will be used. However, other back-ends
-- like CGI\/FastCGI can used if so desired.
-----------------------------------------------------------------------------
module HAppS.Server.SimpleHTTP
( module HAppS.Server.HTTP.Types
, module HAppS.Server.Cookie
, -- * SimpleHTTP
simpleHTTP -- , simpleHTTP'
, parseConfig
, FromReqURI(..)
, RqData
, FromData(..)
, ToMessage(..)
, ServerPart
, ServerPartT(..)
, Web
, WebT(..)
, Result(..)
, noHandle
, escape
-- * ServerPart primitives.
, webQuery
, webUpdate
, flatten
, localContext
, dir -- :: String -> [ServerPart] -> ServerPart
, method -- :: MatchMethod m => m -> IO Result -> ServerPart
, methodSP
-- , method' -- :: MatchMethod m => m -> IO (Maybe Result) -> ServerPart
, path -- :: FromReqURI a => (a -> [ServerPart]) -> ServerPart
, proxyServe
, rproxyServe
-- , limProxyServe
, uriRest
, anyPath
, anyPath'
, withData -- :: FromData a => (a -> [ServerPart]) -> ServerPart
, withDataFn
-- , modXml
, require -- :: IO (Maybe a) -> (a -> [ServerPart]) -> ServerPart
, multi -- :: [ServerPart] -> ServerPart
, withRequest -- :: (Request -> IO Result) -> ServerPart
, debugFilter
, anyRequest
, applyRequest
, modifyResponse
, setResponseCode
, basicAuth
-- * Creating Results.
, ok -- :: ToMessage a => a -> IO Result
-- , mbOk
, badGateway
, internalServerError
, badRequest
, unauthorized
, forbidden
, notFound
, seeOther
, found
, movedPermanently
, tempRedirect
, addCookie
, addCookies
-- * Parsing input and cookies
, lookInput -- :: String -> Data Input
, lookBS -- :: String -> Data B.ByteString
, look -- :: String -> Data String
, lookCookie -- :: String -> Data Cookie
, lookCookieValue -- :: String -> Data String
, readCookieValue -- :: Read a => String -> Data a
, lookRead -- :: Read a => String -> Data a
, lookPairs
-- * XSLT
, xslt ,doXslt
) where
import HAppS.Server.HTTP.Client
import HAppS.Data.Xml.HaXml
import qualified HAppS.Server.MinHaXML as H
import HAppS.Server.HTTP.Types hiding (Version(..))
import qualified HAppS.Server.HTTP.Types as Types
import HAppS.Server.HTTP.Listen
import HAppS.Server.XSLT
import HAppS.Server.SURI (ToSURI)
import HAppS.Util.Common
import HAppS.Server.Cookie
import HAppS.State (QueryEvent, UpdateEvent, query, update)
import HAppS.Data -- used by default implementation of fromData
import Control.Monad.Reader
import Control.Monad.State
--import Control.Concurrent
import Data.Maybe
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Generics as G
import qualified Data.Map as M
import Text.Html (Html,renderHtml)
import qualified Text.XHtml as XHtml (Html,renderHtml)
import qualified HAppS.Crypto.Base64 as Base64
import Data.Char
import Data.List
import System.IO
import System.Environment
import System.Console.GetOpt
import System.Exit
type Web a = WebT IO a
type ServerPart a = ServerPartT IO a
newtype ServerPartT m a = ServerPartT { unServerPartT :: Request -> WebT m a }
instance (Monad m) => Monad (ServerPartT m) where
f >>= g = ServerPartT $ \rq ->
do a <- unServerPartT f rq
unServerPartT (g a) rq
return x = ServerPartT $ \_ -> return x
newtype WebT m a = WebT { unWebT :: m (Result a) }
data Result a = NoHandle
| Ok (Response -> Response) a
| Escape Response
deriving Show
instance Show (a -> b) where
show _ = "<func>"
instance Monad m => Monad (WebT m) where
f >>= g = WebT $ do r <- unWebT f
case r of
NoHandle -> return NoHandle
Escape resp -> return $ Escape resp
Ok out a -> do r' <- unWebT (g a)
case r' of
NoHandle -> return NoHandle
Escape resp -> return $ Escape resp
Ok out' a' -> return $ Ok (out' . out) a'
return x = WebT $ return (Ok id x)
instance MonadTrans WebT where
lift m = WebT (liftM (Ok id) m)
instance MonadIO m => MonadIO (WebT m) where
liftIO m = WebT (liftM (Ok id) $ liftIO m)
instance MonadReader r m => MonadReader r (WebT m) where
ask = lift ask
local fn m = WebT $ local fn (unWebT m)
instance MonadState st m => MonadState st (WebT m) where
get = lift get
put = lift . put
noHandle :: Monad m => WebT m a
noHandle = WebT $ return NoHandle
escape :: (Monad m, ToMessage resp) => WebT m resp -> WebT m a
escape gen = WebT $ do res <- unWebT gen
case res of
NoHandle -> return NoHandle
Escape resp -> return $ Escape resp
Ok out a -> return $ Escape $ out $ toResponse a
ho :: [OptDescr (Conf -> Conf)]
ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]
parseConfig :: [String] -> Either [String] Conf
parseConfig args
= case getOpt Permute ho args of
(flags,_,[]) -> Right $ foldr ($) nullConf flags
(_,_,errs) -> Left errs
-- | Use the built-in web-server to serve requests according to list of @ServerParts@.
simpleHTTP :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()
simpleHTTP conf hs
= listen conf (simpleHTTP' hs)
-- | Generate a result from a list of @ServerParts@ and a @Request@. This is mainly used
-- by CGI (and fast-cgi) wrappers.
simpleHTTP' :: (ToMessage a, Monad m) => [ServerPartT m a] -> Request -> m Response
simpleHTTP' hs req
= do res <- unWebT (unServerPartT (multi hs) req)
case res of
NoHandle -> return $ result 404 "No suitable handler found"
Escape resp -> return resp
Ok out a -> return $ out $ toResponse a
class FromReqURI a where
fromReqURI :: String -> Maybe a
instance FromReqURI String where fromReqURI = Just
instance FromReqURI Int where fromReqURI = readM
instance FromReqURI Integer where fromReqURI = readM
instance FromReqURI Float where fromReqURI = readM
instance FromReqURI Double where fromReqURI = readM
type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a
class FromData a where
fromData :: RqData a
instance (Eq a,Show a,Xml a,G.Data a) => FromData a where
fromData = do mbA <- lookPairs >>= return . normalize . fromPairs
case mbA of
Just a -> return a
Nothing -> fail "FromData G.Data failure"
-- fromData = lookPairs >>= return . normalize . fromPairs
instance (FromData a, FromData b) => FromData (a,b) where
fromData = liftM2 (,) fromData fromData
instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where
fromData = liftM3 (,,) fromData fromData fromData
instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where
fromData = liftM4 (,,,) fromData fromData fromData fromData
instance FromData a => FromData (Maybe a) where
fromData = fmap Just fromData `mplus` return Nothing
{- |
Minimal definition: 'toMessage'
-}
class ToMessage a where
toContentType :: a -> B.ByteString
toContentType _ = B.pack "text/plain"
toMessage :: a -> L.ByteString
toMessage = error "HAppS.Server.SimpleHTTP.ToMessage.toMessage: Not defined"
toResponse:: a -> Response
toResponse val =
let bs = toMessage val
result = Response 200 M.empty nullRsFlags bs
in setHeaderBS (B.pack "Content-Type") (toContentType val)
result
instance ToMessage [Element] where
toContentType _ = B.pack "application/xml"
toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE
toMessage x = error ("HAppS.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)
instance ToMessage () where
toContentType _ = B.pack "text/plain"
toMessage () = L.empty
instance ToMessage String where
toContentType _ = B.pack "text/plain"
toMessage = L.pack
instance ToMessage Integer where
toMessage = toMessage . show
instance ToMessage a => ToMessage (Maybe a) where
toContentType _ = toContentType (undefined :: a)
toMessage Nothing = toMessage "nothing"
toMessage (Just x) = toMessage x
instance ToMessage Html where
toContentType _ = B.pack "text/html"
toMessage = L.pack . renderHtml
instance ToMessage XHtml.Html where
toContentType _ = B.pack "text/html"
toMessage = L.pack . XHtml.renderHtml
instance ToMessage Response where
toResponse = id
instance (Xml a)=>ToMessage a where
toContentType = toContentType . toXml
toMessage = toMessage . toPublicXml
-- toMessageM = toMessageM . toPublicXml
class MatchMethod m where matchMethod :: m -> Method -> Bool
instance MatchMethod Method where matchMethod method = (== method)
instance MatchMethod [Method] where matchMethod methods = (`elem` methods)
instance MatchMethod (Method -> Bool) where matchMethod f = f
instance MatchMethod () where matchMethod () _ = True
webQuery :: (MonadIO m, QueryEvent ev res) => ev -> WebT m res
webQuery = liftIO . query
webUpdate :: (MonadIO m, UpdateEvent ev res) => ev -> WebT m res
webUpdate = liftIO . update
flatten :: (ToMessage a, Monad m) => ServerPartT m a -> ServerPartT m Response
flatten = liftM toResponse
localContext :: Monad m => (WebT m a -> WebT m' a) -> [ServerPartT m a] -> ServerPartT m' a
localContext fn hs
= ServerPartT $ \rq -> fn (unServerPartT (multi hs) rq)
-- | Pop a path element and run the @[ServerPart]@ if it matches the given string.
dir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a
dir staticPath handle
= ServerPartT $ \rq -> case rqPaths rq of
(path:xs) | path == staticPath ->
unServerPartT (multi handle) rq{rqPaths = xs}
_ -> noHandle
-- | Guard against the method. Note, this function also guards against any
-- remaining path segments. See 'anyRequest'.
methodSP :: (MatchMethod method, Monad m) => method -> ServerPartT m a -> ServerPartT m a
methodSP m handle
= ServerPartT $ \rq -> if matchMethod m (rqMethod rq) && null (rqPaths rq)
then unServerPartT handle rq
else noHandle
-- | Guard against the method. Note, this function also guards against any
-- remaining path segments. See 'anyRequest'.
method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a
method m handle = methodSP m (ServerPartT $ \_ -> handle)
-- | Pop a path element and parse it.
path :: (FromReqURI a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r
path handle
= ServerPartT $ \rq ->
case rqPaths rq of
(path:xs) | Just a <- fromReqURI path
-> unServerPartT (multi $ handle a) rq{rqPaths = xs}
_ -> noHandle
uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a
uriRest handle = withRequest $ \rq ->
unServerPartT (handle (rqURL rq)) rq
anyPath x = path $ (\(_::String) -> x)
anyPath' x = path $ (\(_::String) -> [x])
-- | Retrieve date from the input query or the cookies.
withData :: (FromData a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r
withData = withDataFn fromData
withDataFn :: Monad m => RqData a -> (a -> [ServerPartT m r]) -> ServerPartT m r
withDataFn fn handle
= ServerPartT $ \rq -> case runReaderT fn (rqInputs rq,rqCookies rq) of
Nothing -> noHandle
Just a -> unServerPartT (multi $ handle a) rq
proxyServe :: MonadIO m => [String] -> ServerPartT m Response
proxyServe allowed = withRequest $ \rq ->
if cond rq then proxyServe' rq else noHandle
where
cond rq
| "*" `elem` allowed = True
| domain `elem` allowed = True
| superdomain `elem` wildcards =True
| otherwise = False
where
domain = head (rqPaths rq)
superdomain = tail $ snd $ break (=='.') domain
wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed)
proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=
either (badGateway . toResponse . show) (escape . return)
rproxyServe :: MonadIO m => String -> [(String, String)] -> ServerPartT m Response
rproxyServe defaultHost list = withRequest $ \rq ->
liftIO (getResponse (unrproxify defaultHost list rq)) >>=
either (badGateway . toResponse . show) (escape . return)
{-
modXml:: (Monad m) => (Request -> Element -> m Element) -> [ServerPartT m a] ->
ServerPartT m a
modXml f handle
= Reader $ \rq ->
do res <- runReader (multi handle) rq
case res of
Nothing -> return Nothing
Just res'@(Left _) -> return $ Just res'
Just res'@(Right (s,el)) ->
(\el->return $ Just $ Right (s,el)) =<< f rq el
-}
-- | Run an IO action and, if it returns @Just@, pass it to the second argument.
require :: MonadIO m => IO (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r
require fn = requireM (liftIO fn)
requireM :: Monad m => m (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r
requireM fn handle
= ServerPartT $ \rq -> do mbVal <- lift fn
case mbVal of
Nothing -> noHandle
Just a -> unServerPartT (multi $ handle a) rq
showRequest
= Reader $ \rq -> print (rq::Request)
-- FIXME: What to do with Escapes?
-- | Use @cmd@ to transform XML against @xslPath@.
-- This function only acts if the content-type is @application\/xml@.
xslt :: (MonadIO m, ToMessage r) =>
XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.
-> XSLPath -- ^ Path to xslt stylesheet.
-> [ServerPartT m r] -- ^ Affected @ServerParts@.
-> ServerPartT m Response
xslt cmd xslPath parts =
withRequest $ \rq ->
do res <- unServerPartT (multi parts) rq
if toContentType res == B.pack "application/xml"
then liftM toResponse (doXslt cmd xslPath (toResponse res))
else return (toResponse res)
doXslt cmd xslPath res =
do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res
liftIO $ print res
liftIO $ print "##########"
liftIO $ print new
return $ setHeader "Content-Type" "text/html" $
setHeader "Content-Length" (show $ L.length new) $
res { rsBody = new }
--io :: IO Result -> ServerPart
--io action = ReaderT $ \_ -> Just action
modifyResponse :: Monad m => (Response -> Response) -> WebT m ()
modifyResponse modFn = WebT $ return $ Ok modFn ()
setResponseCode :: Monad m => Int -> WebT m ()
setResponseCode code
= modifyResponse $ \resp -> resp{rsCode = code}
addCookie :: Monad m => Seconds -> Cookie -> WebT m ()
addCookie sec cookie
= modifyResponse $ addHeader "Set-Cookie" (mkCookieHeader sec cookie)
addCookies :: Monad m => [(Seconds, Cookie)] -> WebT m ()
addCookies = mapM_ (uncurry addCookie)
{-
delCookie :: String -> WebT m ()
delCookie name =
-}
resp status val = setResponseCode status >> return val
{-- do bs <- toMessageM val
liftM (setHeaderBS (B.pack "Content-Type") (toContentType val)) $
sresult' status bs
--}
{-
mbOk :: ToMessage b => (a -> b) -> Maybe a -> IO Result -> IO Result
mbOk f val other = maybe other (ok . f) val
-}
-- | Respond with @200 OK@.
ok :: Monad m => a -> WebT m a
ok = resp 200
internalServerError::Monad m => a -> WebT m a
internalServerError = resp 500
badGateway::Monad m=> a-> WebT m a
badGateway = resp 502
-- | Respond with @400 Bad Request@.
badRequest :: Monad m => a -> WebT m a
badRequest = resp 400
-- | Respond with @401 Unauthorized@.
unauthorized :: Monad m => a -> WebT m a
unauthorized val = resp 401 val
-- | Respond with @403 Forbidden@.
forbidden :: Monad m => a -> WebT m a
forbidden val = resp 403 val
-- | Respond with @404 Not Found@.
notFound :: Monad m => a -> WebT m a
notFound val = resp 404 val
-- | Respond with @303 See Other@.
seeOther :: (Monad m, ToSURI uri) => uri -> res -> WebT m res
seeOther uri res = do modifyResponse $ redirect 303 uri
return res
-- | Respond with @302 Found@.
found :: (Monad m, ToSURI uri) => uri -> res -> WebT m res
found uri res = do modifyResponse $ redirect 302 uri
return res
-- | Respond with @301 Moved Permanently@.
movedPermanently :: (Monad m, ToSURI a) => a -> res -> WebT m res
movedPermanently uri res = do modifyResponse $ redirect 301 uri
return res
-- | Respond with @307 Temporary Redirect@.
tempRedirect :: (Monad m, ToSURI a) => a -> res -> WebT m res
tempRedirect val res = do modifyResponse $ redirect 307 val
return res
multi :: Monad m => [ServerPartT m a] -> ServerPartT m a
multi ls = ServerPartT $ \rq -> foldr servPlus noHandle [ unServerPartT l rq | l <- ls ]
where servPlus a b = WebT $
do a' <- unWebT a
case a' of
NoHandle -> unWebT b
_ -> return a'
withRequest :: (Request -> WebT m a) -> ServerPartT m a
withRequest fn = ServerPartT $ fn
debugFilter handle = [
ServerPartT $ \rq -> WebT $ do
resp <- unWebT (unServerPartT (multi handle) rq)
liftIO $ print rq >> print resp
return resp]
anyRequest :: Monad m => WebT m a -> ServerPartT m a
anyRequest x = withRequest $ \_ -> x
applyRequest hs = simpleHTTP' hs >>= return . Left
basicAuth :: (MonadIO m) => String -> M.Map String String -> [ServerPartT m a] -> ServerPartT m a
basicAuth realmName authMap xs = multi $ basicAuthImpl:xs
where
basicAuthImpl = withRequest $ \rq ->
case getHeader "authorization" rq of
Nothing -> err
Just x -> case parseHeader x of
(name, ':':pass) | validLogin name pass -> noHandle
_ -> err
validLogin name pass = M.lookup name authMap == Just pass
parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6
headerName = "WWW-Authenticate"
headerValue = "Basic realm=\"" ++ realmName ++ "\""
err = escape $
do unauthorized "Not authorized"
--------------------------------------------------------------
-- Query/Post data validating
--------------------------------------------------------------
lookInput :: String -> RqData Input
lookInput name
= do inputs <- asks fst
case lookup name inputs of
Nothing -> fail "input not found"
Just i -> return i
lookBS :: String -> RqData L.ByteString
lookBS = fmap inputValue . lookInput
look :: String -> RqData String
look = fmap L.unpack . lookBS
lookCookie :: String -> RqData Cookie
lookCookie name
= do cookies <- asks snd
case lookup (map toLower name) cookies of -- keys are lowercased
Nothing -> fail "cookie not found"
Just c -> return c
lookCookieValue :: String -> RqData String
lookCookieValue = fmap cookieValue . lookCookie
readCookieValue :: Read a => String -> RqData a
readCookieValue name = readM =<< fmap cookieValue (lookCookie name)
lookRead :: Read a => String -> RqData a
lookRead name = readM =<< look name
lookPairs :: RqData [(String,String)]
lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))