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

{- |
   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.LibCurlInput
    ( getLibCurlContents
    , a_use_curl
    , withCurl
    , curlOptions
    )
where

import           Control.Arrow                            -- arrow classes
import           Control.Arrow.ArrowList
import           Control.Arrow.ArrowTree
import           Control.Arrow.ArrowIO

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 qualified Text.XML.HXT.IO.GetHTTPLibCurl as LibCURL

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
import           Text.XML.HXT.Arrow.XmlOptions                  ( a_proxy
                                                                , a_redirect
                                                                )

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

getLibCurlContents      :: IOSArrow XmlTree XmlTree
getLibCurlContents :: IOSArrow XmlTree XmlTree
getLibCurlContents
    = [Char]
-> ([([Char], [Char])], (Bool, ([Char], Bool)))
-> IOSArrow XmlTree XmlTree
forall {a}.
Enum a =>
[Char]
-> ([([Char], [Char])], (a, ([Char], Bool)))
-> IOSArrow XmlTree XmlTree
getC
      ([Char]
 -> ([([Char], [Char])], (Bool, ([Char], Bool)))
 -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     XmlTree
     ([Char], ([([Char], [Char])], (Bool, ([Char], Bool))))
-> IOSArrow XmlTree XmlTree
forall c1 c2 b d.
(c1 -> c2 -> IOSLA (XIOState ()) b d)
-> IOSLA (XIOState ()) b (c1, c2) -> IOSLA (XIOState ()) b d
forall (a :: * -> * -> *) c1 c2 b d.
ArrowList a =>
(c1 -> c2 -> a b d) -> a b (c1, c2) -> a b d
$<<
      ( [Char] -> IOSLA (XIOState ()) XmlTree [Char]
forall (a :: * -> * -> *). ArrowXml a => [Char] -> a XmlTree [Char]
getAttrValue [Char]
transferURI
        IOSLA (XIOState ()) XmlTree [Char]
-> IOSLA
     (XIOState ()) XmlTree ([([Char], [Char])], (Bool, ([Char], Bool)))
-> IOSLA
     (XIOState ())
     XmlTree
     ([Char], ([([Char], [Char])], (Bool, ([Char], Bool))))
forall b c c'.
IOSLA (XIOState ()) b c
-> IOSLA (XIOState ()) b c' -> IOSLA (XIOState ()) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
        Selector XIOSysState ([([Char], [Char])], (Bool, ([Char], Bool)))
-> IOSLA
     (XIOState ()) XmlTree ([([Char], [Char])], (Bool, ([Char], Bool)))
forall c s b. Selector XIOSysState c -> IOStateArrow s b c
getSysVar (Selector XIOSysState [([Char], [Char])]
theInputOptions Selector XIOSysState [([Char], [Char])]
-> Selector XIOSysState (Bool, ([Char], Bool))
-> Selector
     XIOSysState ([([Char], [Char])], (Bool, ([Char], Bool)))
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState Bool
theRedirect     Selector XIOSysState Bool
-> Selector XIOSysState ([Char], Bool)
-> Selector XIOSysState (Bool, ([Char], Bool))
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState [Char]
theProxy        Selector XIOSysState [Char]
-> Selector XIOSysState Bool -> Selector XIOSysState ([Char], Bool)
forall s a b. Selector s a -> Selector s b -> Selector s (a, b)
.&&&.
                   Selector XIOSysState Bool
theStrictInput
                  )
      )
      where
      getC :: [Char]
-> ([([Char], [Char])], (a, ([Char], Bool)))
-> IOSArrow XmlTree XmlTree
getC [Char]
uri ([([Char], [Char])]
options, (a
redirect, ([Char]
proxy, Bool
strictInput)))
          = IOSLA (XIOState ()) XmlTree (IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree
forall b c.
IOSLA (XIOState ()) b (IOSLA (XIOState ()) b c)
-> IOSLA (XIOState ()) b c
forall (a :: * -> * -> *) b c. ArrowList a => a b (a b c) -> a b c
applyA ( ( Int -> [Char] -> IOSArrow XmlTree XmlTree
forall s b. Int -> [Char] -> IOStateArrow s b b
traceMsg Int
2 ( [Char]
"get HTTP via libcurl, uri=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
uri [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" options=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
forall a. Show a => a -> [Char]
show [([Char], [Char])]
options' )
                       IOSArrow XmlTree XmlTree
-> IOSLA
     (XIOState ())
     XmlTree
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
-> IOSLA
     (XIOState ())
     XmlTree
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], 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
     ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
-> IOSLA
     (XIOState ())
     XmlTree
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
forall c b. IO c -> IOSLA (XIOState ()) b c
forall (a :: * -> * -> *) c b. ArrowIO a => IO c -> a b c
arrIO0 ( Bool
-> [([Char], [Char])]
-> [Char]
-> IO
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
LibCURL.getCont
                                    Bool
strictInput
                                    [([Char], [Char])]
options'
                                    [Char]
uri
                              )
                     )
                     IOSLA
  (XIOState ())
  XmlTree
  (Either
     ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
-> IOSLA
     (XIOState ())
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], 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
>>>
                     ( (([([Char], [Char])], [Char]) -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     ([([Char], [Char])], [Char])
     (IOSArrow XmlTree XmlTree)
forall b c. (b -> c) -> IOSLA (XIOState ()) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (([([Char], [Char])] -> [Char] -> IOSArrow XmlTree XmlTree)
-> ([([Char], [Char])], [Char]) -> IOSArrow XmlTree XmlTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [([Char], [Char])] -> [Char] -> IOSArrow XmlTree XmlTree
forall s.
[([Char], [Char])] -> [Char] -> IOStateArrow s XmlTree XmlTree
addInputError)
                       IOSLA
  (XIOState ())
  ([([Char], [Char])], [Char])
  (IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     ([([Char], [Char])], ByteString)
     (IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     (Either
        ([([Char], [Char])], [Char]) ([([Char], [Char])], ByteString))
     (IOSArrow XmlTree XmlTree)
forall b d c.
IOSLA (XIOState ()) b d
-> IOSLA (XIOState ()) c d -> IOSLA (XIOState ()) (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
|||
                       (([([Char], [Char])], ByteString) -> IOSArrow XmlTree XmlTree)
-> IOSLA
     (XIOState ())
     ([([Char], [Char])], ByteString)
     (IOSArrow XmlTree XmlTree)
forall b c. (b -> c) -> IOSLA (XIOState ()) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ([([Char], [Char])], ByteString) -> IOSArrow XmlTree XmlTree
addContent
                     )
                   )
            where
            options' :: [([Char], [Char])]
options' = ([Char]
a_proxy, [Char]
proxy)
                       ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: ([Char]
a_redirect, Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> (a -> Int) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> [Char]) -> a -> [Char]
forall a b. (a -> b) -> a -> b
$ a
redirect)
                       ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: [([Char], [Char])]
options

addContent        :: (Attributes, B.ByteString) -> IOSArrow XmlTree XmlTree
addContent :: ([([Char], [Char])], ByteString) -> IOSArrow XmlTree XmlTree
addContent ([([Char], [Char])]
al, ByteString
bc)
    = IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (t :: * -> *) b.
Tree t =>
IOSLA (XIOState ()) (t b) (t b) -> IOSLA (XIOState ()) (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b) -> a (t b) (t b)
replaceChildren (ByteString -> IOSArrow XmlTree XmlTree
forall n. ByteString -> IOSLA (XIOState ()) n 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 b. [IOSLA (XIOState ()) b b] -> IOSLA (XIOState ()) b b
forall (a :: * -> * -> *) b. ArrowList a => [a b b] -> a b b
seqA ((([Char], [Char]) -> IOSArrow XmlTree XmlTree)
-> [([Char], [Char])] -> [IOSArrow XmlTree XmlTree]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> IOSArrow XmlTree XmlTree)
-> ([Char], [Char]) -> IOSArrow XmlTree XmlTree
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
[Char] -> [Char] -> a XmlTree XmlTree
addAttr) [([Char], [Char])]
al)           -- add the meta info (HTTP headers, ...)

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

a_use_curl              :: String
a_use_curl :: [Char]
a_use_curl              = [Char]
"use-curl"

withCurl               :: Attributes -> SysConfig
withCurl :: [([Char], [Char])] -> SysConfig
withCurl [([Char], [Char])]
curlOpts      = 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
getLibCurlContents
                         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
>>>
                         [([Char], [Char])] -> SysConfig
withInputOptions [([Char], [Char])]
curlOpts

curlOptions            :: [OptDescr SysConfig]
curlOptions :: [OptDescr SysConfig]
curlOptions            = [ [Char]
-> [[Char]] -> ArgDescr SysConfig -> [Char] -> OptDescr SysConfig
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
"" [[Char]
a_use_curl]  (SysConfig -> ArgDescr SysConfig
forall a. a -> ArgDescr a
NoArg ([([Char], [Char])] -> SysConfig
withCurl []))  [Char]
"enable HTTP input with libcurl" ]

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