{-# 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))