-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.Arrow.LibCurlInput
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   libcurl input
-}

-- ------------------------------------------------------------

module Text.XML.HXT.Arrow.LibHTTPInput
    ( getHTTPNativeContents
    , withHTTP
    , httpOptions
    )
where

import           Control.Arrow
import           Control.Arrow.ArrowIO
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree

import qualified Data.ByteString.Lazy                 as B
-- import qualified Data.ByteString.Lazy.Char8     as C

import           System.Console.GetOpt

import           Text.XML.HXT.Arrow.DocumentInput     (addInputError)
import           Text.XML.HXT.IO.GetHTTPNative        (getCont)

import           Text.XML.HXT.DOM.Interface

import           Text.XML.HXT.Arrow.XmlArrow
import           Text.XML.HXT.Arrow.XmlState
import           Text.XML.HXT.Arrow.XmlState.TypeDefs

-- ----------------------------------------------------------

getHTTPNativeContents      :: IOSArrow XmlTree XmlTree
getHTTPNativeContents :: IOSArrow XmlTree XmlTree
getHTTPNativeContents
    = String
-> (Attributes, (String, (Bool, Bool))) -> IOSArrow XmlTree XmlTree
getC
      (String
 -> (Attributes, (String, (Bool, Bool)))
 -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     XmlTree
     (String, (Attributes, (String, (Bool, Bool))))
-> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<<
      ( String -> IOSLA (XIOState ()) XmlTree String
forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
transferURI
        IOSLA (XIOState ()) XmlTree String
-> IOSLA (XIOState ()) XmlTree (Attributes, (String, (Bool, Bool)))
-> IOSLA
     (XIOState ())
     XmlTree
     (String, (Attributes, (String, (Bool, Bool))))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
        Selector XIOSysState (Attributes, (String, (Bool, Bool)))
-> IOSLA (XIOState ()) XmlTree (Attributes, (String, (Bool, Bool)))
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar (Selector XIOSysState Attributes
theInputOptions Selector XIOSysState Attributes
-> Selector XIOSysState (String, (Bool, Bool))
-> Selector XIOSysState (Attributes, (String, (Bool, Bool)))
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState String
theProxy        Selector XIOSysState String
-> Selector XIOSysState (Bool, Bool)
-> Selector XIOSysState (String, (Bool, Bool))
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState Bool
theStrictInput  Selector XIOSysState Bool
-> Selector XIOSysState Bool -> Selector XIOSysState (Bool, Bool)
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState Bool
theRedirect
                  )
      )
      where
      getC :: String
-> (Attributes, (String, (Bool, Bool))) -> IOSArrow XmlTree XmlTree
getC String
uri (Attributes
options, (String
proxy, (Bool
strictInput, Bool
redirect)))
          = IOSLA (XIOState ()) XmlTree (IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => a b (a b c) -> a b c
applyA ( ( Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 ( String
"get HTTP via native HTTP interface, uri=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
uri String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" options=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Attributes -> String
forall a. Show a => a -> String
show Attributes
options )
                       IOSArrow XmlTree XmlTree
-> IOSLA
     (XIOState ())
     XmlTree
     (Either (Attributes, String) (Attributes, ByteString))
-> IOSLA
     (XIOState ())
     XmlTree
     (Either (Attributes, String) (Attributes, ByteString))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                       IO (Either (Attributes, String) (Attributes, ByteString))
-> IOSLA
     (XIOState ())
     XmlTree
     (Either (Attributes, String) (Attributes, ByteString))
forall (a :: * -> * -> *) c b. ArrowIO a => IO c -> a b c
arrIO0 (Bool
-> String
-> String
-> Bool
-> Attributes
-> IO (Either (Attributes, String) (Attributes, ByteString))
getCont Bool
strictInput String
proxy String
uri Bool
redirect Attributes
options)
                     )
                     IOSLA
  (XIOState ())
  XmlTree
  (Either (Attributes, String) (Attributes, ByteString))
-> IOSLA
     (XIOState ())
     (Either (Attributes, String) (Attributes, ByteString))
     (IOSArrow XmlTree XmlTree)
-> IOSLA (XIOState ()) XmlTree (IOSArrow XmlTree XmlTree)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                     ( ((Attributes, String) -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ()) (Attributes, String) (IOSArrow XmlTree XmlTree)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Attributes -> String -> IOSArrow XmlTree XmlTree)
-> (Attributes, String) -> IOSArrow XmlTree XmlTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Attributes -> String -> IOSArrow XmlTree XmlTree
forall s. Attributes -> String -> IOStateArrow s XmlTree XmlTree
addInputError)
                       IOSLA (XIOState ()) (Attributes, String) (IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ()) (Attributes, ByteString) (IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     (Either (Attributes, String) (Attributes, ByteString))
     (IOSArrow XmlTree XmlTree)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
|||
                       ((Attributes, ByteString) -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ()) (Attributes, ByteString) (IOSArrow XmlTree XmlTree)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Attributes, ByteString) -> IOSArrow XmlTree XmlTree
addContent
                     )
                   )

addContent        :: (Attributes, B.ByteString) -> IOSArrow XmlTree XmlTree
addContent :: (Attributes, ByteString) -> IOSArrow XmlTree XmlTree
addContent (Attributes
al, ByteString
bc)
    = IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren (ByteString -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) n.
ArrowXml a =>
ByteString -> a n XmlTree
blb ByteString
bc)                  -- add the contents
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      [IOSArrow XmlTree XmlTree] -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => [a b b] -> a b b
seqA (((String, String) -> IOSArrow XmlTree XmlTree)
-> Attributes -> [IOSArrow XmlTree XmlTree]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> IOSArrow XmlTree XmlTree)
-> (String, String) -> IOSArrow XmlTree XmlTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
String -> String -> a XmlTree XmlTree
addAttr) Attributes
al)           -- add the meta info (HTTP headers, ...)

-- ------------------------------------------------------------

a_use_http              :: String
a_use_http :: String
a_use_http              = String
"use-http"

withHTTP               :: Attributes -> SysConfig
withHTTP :: Attributes -> SysConfig
withHTTP Attributes
httpOpts      = Selector XIOSysState (IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> SysConfig
forall s a. Selector s a -> a -> s -> s
setS Selector XIOSysState (IOSArrow XmlTree XmlTree)
theHttpHandler IOSArrow XmlTree XmlTree
getHTTPNativeContents
                         SysConfig -> SysConfig -> SysConfig
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
                         Attributes -> SysConfig
withInputOptions Attributes
httpOpts

httpOptions            :: [OptDescr SysConfig]
httpOptions :: [OptDescr SysConfig]
httpOptions            = [ String
-> [String] -> ArgDescr SysConfig -> String -> OptDescr SysConfig
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
"" [String
a_use_http]  (SysConfig -> ArgDescr SysConfig
forall a. a -> ArgDescr a
NoArg (Attributes -> SysConfig
withHTTP []))  String
"enable HTTP input with native Haskell HTTP package" ]

-- ------------------------------------------------------------