module HJScript.Ajax
(
ReqParam,ReqParams, IsReqParams(..),noParams,
asyncGetReq, asyncPostReq,
(=:), (<&>), addGetParams,
openAsync,openAsyncPost,sendNull,sendPost,
setCallBack, succCallBack,isReady, isReadySucc,
crtXMLHttpRequest, setPostReqHeader,
module HJScript.Objects.XMLHttpRequest
) where
import HJScript.Lang
import HJScript.Objects.XMLHttpRequest
import HJScript.Objects.ActiveXObject
import HJScript.DOM
import Data.List (intersperse)
import Control.Monad.Trans
data HttpMethod
= Get
| Post
deriving Show
asyncGetReq :: (IsReqParams ps, IsExp e String) =>
e ->
ps ->
(JObject XMLHttpRequest -> HJScript ()) ->
HJScript ()
asyncGetReq url params callb = do
req <- crtXMLReq
req # openAsyncGet url'
req # setCallBack callb'
req # sendNull
where
url' = url `addGetParams` params
callb' req = doIf (isReadySucc req) (callb req) noElse
asyncPostReq :: (IsReqParams ps, IsExp e String) =>
e ->
ps ->
(JObject XMLHttpRequest -> HJScript ()) ->
HJScript ()
asyncPostReq url params callb = do
req <- crtXMLReq
req # openAsync Post url
req # setCallBack callb'
req # setPostReqHeader
req # sendPost (toReqParams params)
where
callb' req = doIf (isReadySucc req) (callb req) noElse
type ReqParam = (JString, JString)
type ReqParams = [ReqParam]
noParams :: ReqParams
noParams = []
class IsReqParams a where
toReqParams :: a -> [ReqParam]
instance (IsExp e1 String, IsExp e2 String) => IsReqParams (e1,e2) where
toReqParams (e1,e2) = [(toExp e1, toExp e2)]
instance IsReqParams ReqParams where
toReqParams = id
(=:) :: IsReqParams (a, b) => a -> b -> ReqParams
e1 =: e2 = toReqParams (e1,e2)
(<&>) :: (IsReqParams p1 , IsReqParams p2) => p1 -> p2 -> ReqParams
p1 <&> p2 = (toReqParams p1) ++ (toReqParams p2)
instance IsExp ReqParam String where
toExp (p,v) = p .+. string "=" .+. v
instance IsExp [ReqParam] String where
toExp pvs = foldr (.+.) (string "") pvs'
where
pvs' = intersperse (string "&") (map toExp pvs)
addGetParams :: (IsExp e String , IsReqParams ps) => e -> ps -> JString
addGetParams url params
| null params' = toExp url
| otherwise = toExp url .+. string "?" .+. toExp params'
where
params' = toReqParams params
openAsync :: (IsExp e String) =>
HttpMethod -> e -> JObject XMLHttpRequest -> HJScript ()
openAsync meth url = openReq (toExp $ show meth) (toExp url) true
openAsyncGet :: (IsExp e String) =>
e -> JObject XMLHttpRequest -> HJScript ()
openAsyncGet = openAsync Get
openAsyncPost :: (IsExp e String) =>
e -> JObject XMLHttpRequest -> HJScript ()
openAsyncPost = openAsync Post
sendNull :: JObject XMLHttpRequest -> HJScript ()
sendNull = sendReq jnull
sendPost pst = sendReq $ toExp pst
setCallBack fun req = do
callback <- procedure $ \() -> fun req
req # onReadyStateChange .=. callback
where
callback = procedure $ \() -> fun req
succCallBack :: JObject XMLHttpRequest -> JBool
succCallBack req = req # statusReq .==. int 200
isReady :: JObject XMLHttpRequest -> JBool
isReady req = req # readyState .==. int 4
isReadySucc req = isReady req .&&. succCallBack req
crtXMLHttpRequest :: HJScript (Exp XMLHttpRequest)
crtXMLHttpRequest = new XMLHttpRequest ()
crtXMLReq :: HJScript (Exp XMLHttpRequest)
crtXMLReq = do
req <- var
doIf hasXMLHttpReq
(new XMLHttpRequest () >>= \xmlHttp -> (req .=. xmlHttp)) $
doElse $
doIf hasActiveX
(new ActiveXObject msXMLHttp >>= \actX -> (req .=. (castObject actX))) $
doElse $ window # alert (string "JavaScript operation not supported")
return (val req)
setPostReqHeader req = req # setRequestHeader contt appl
where
contt = string "Content-Type"
appl = string "application/x-www-form-urlencoded"
hasXMLHttpReq, hasActiveX :: JBool
hasXMLHttpReq = window `hasFeature` XMLHttpRequest
hasActiveX = window `hasFeature` ActiveXObject