{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Text.XML.Schema.Org.Xmlsoap.Schemas.Soap.Http
-- Copyright   :  (c) Simon Foster 2004
-- License     :  GPL version 2 (see COPYING)
-- 
-- Maintainer  :  aca01sdf@shef.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (ghc >= 6 only)
--
-- A HTTP transport for SOAP.
--
-- This is a work in progress.
--
-- @This file is part of HAIFA.@
--
-- @HAIFA is free software; you can redistribute it and\/or modify it under the terms of the 
-- GNU General Public License as published by the Free Software Foundation; either version 2 
-- of the License, or (at your option) any later version.@
--
-- @HAIFA is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without 
-- even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.@
--
-- @You should have received a copy of the GNU General Public License along with HAIFA; if not, 
-- write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA@
----------------------------------------------------------------------------
module Text.XML.Schema.Org.Xmlsoap.Schemas.Soap.Http where

import Data.Dynamic
import Data.Generics
import Network.HTTP
import Network.URI
import Text.XML.Schema.Org.Xmlsoap.Schemas.Soap.Envelope
import Text.XML.Schema.Org.Xmlsoap.Schemas.Wsdl.Soap
import Text.XML.Serializer
import Text.XML.HXT.Parser (xmlTreesToString, removeAllWhiteSpace)
import Text.XML.HXT.Aliases (parseXML)
import Maybe

{-
data HTTP = 
    HTTP { target     :: URI 
         , soapAction :: String
         } 
-}

doHTTP :: String -> URI -> String -> IO Response
doHTTP b u a = let h = [ Header HdrHost (authority u)
                       , Header HdrContentLength (show $ length b)
                       , Header HdrContentType "text/xml"
                       , Header (HdrCustom "SOAPAction") (show a)
                       ]
                   r = Request u POST h b 
                       in do x <- simpleHTTP r
                             case x of
                                 Left  e -> fail ("HTTP Error : "++show e)
                                 Right x -> return x

--request_response :: String -> Dynamic -> (a -> XmlTree) -> (XmlTree -> Maybe b) -> a -> IO b
request_response a d ser des env = let b     = xmlTreesToString [ser env]
                                       u     = fromDyn d (error $ "Incorrect address parameter handed to HTTP, expected URI, got " ++ show d)
                                         in do --putStrLn b 
                                               x <- doHTTP b u a                                               
                                               xml <- parseXML $ rspBody x
                                               
                                               -- The filter here is vital to a working implementation.
                                               case xml of
                                                   Nothing -> fail "Non-XML Body returned"
                                                   Just x  -> case (des (head $ removeAllWhiteSpace $ head x)) of
                                                                  Nothing -> 
                                                                      fail "Failed to parse SOAP Envelope or Body"
                                                                  Just x -> 
                                                                      return x

one_way = undefined
solicit_response = undefined                                                                      
                                                                                                                
{-
instance SOAPTransport HTTP where
    rpc (HTTP u a) ser des env = let b = xmlTreesToString [ser env]
                                         in do 
                                               x <- doHTTP b u a
                                               
                                               xml <- parseXML $ rspBody x
                                               
                                               -- The filter here is vital to a working implementation.
                                               case xml of
                                                   Nothing -> fail "Non-XML Body returned"
                                                   Just x  -> case (des (head $ removeAllWhiteSpace $ head x)) of
                                                                  Nothing -> 
                                                                      fail "Failed to parse SOAP Envelope or Body"
                                                                  Just x -> 
                                                                      return x
    document (HTTP u a) ser env = let b = xmlTreesToString [ser env]
                                          in do x <- doHTTP b u a
                                                return ()
-}                                         