bundles/org.simantics.scl.rest/scl/HTTP/Client.scl

   1 import "Vector"
   2 import "File"
   3 import "HTTP/Form"
   4 import "HTTP/MultiPart"
   5 import "HTTP/MediaType"
   6 import "Future"
   7
   8 type ResponseHandler = Response -> <Proc> ()
   9 type FailureHandler = Throwable -> <Proc> ()
  10
  11 NO_RESPONSE_HANDLER = (\response -> ()) :: ResponseHandler
  12 NO_FAILURE_HANDLER = (\failure -> ()) :: FailureHandler
  13
  14 importJava "javax.ws.rs.client.Invocation" where
  15     data Invocation
  16
  17     @JavaName invoke
  18     syncInvoke :: Invocation -> <Proc, Exception> Response
  19
  20 importJava "javax.ws.rs.core.Response" where
  21     data Response
  22     @JavaName getStatus
  23     statusCodeOf :: Response -> <Proc> Integer
  24     @Private
  25     @JavaName readEntity
  26     readEntity_ :: Response -> Class a -> <Proc, Exception> a
  27
  28 readEntity :: VecComp a => Response -> <Proc, Exception> a
  29 readEntity response = readEntity_ response classObject
  30
  31 importJava "javax.ws.rs.client.Invocation$Builder" where
  32     data Builder
  33
  34     header :: Builder -> String -> String -> <Proc> Builder
  35     @private
  36     @JavaName accept
  37     acceptMediaType_ :: Builder -> Vector MediaType -> <Proc> Builder
  38     @private
  39     @JavaName acceptEncoding
  40     acceptEncoding_ :: Builder -> Vector String -> <Proc> Builder
  41     @private
  42     @JavaName acceptLanguage
  43     acceptLanguage_ :: Builder -> Vector String -> <Proc> Builder
  44     cookie :: Builder -> String -> String -> <Proc> Builder
  45     build :: Builder -> String -> <Proc> Invocation
  46     buildGet :: Builder -> <Proc> Invocation
  47     buildPost :: Builder -> Entity -> <Proc> Invocation
  48     buildDelete :: Builder -> <Proc> Invocation
  49     buildPut :: Builder -> Entity -> <Proc> Invocation
  50
  51 acceptMediaType :: Builder -> [MediaType] -> <Proc> Builder
  52 acceptMediaType builder mediaTypes =
  53     acceptMediaType_ builder $ vector mediaTypes
  54
  55 acceptEncoding :: Builder -> [String] -> <Proc> Builder
  56 acceptEncoding builder encodings =
  57     acceptEncoding_ builder $ vector encodings
  58
  59 acceptLanguage :: Builder -> [String] -> <Proc> Builder
  60 acceptLanguage builder languages =
  61     acceptEncoding_ builder $ vector languages
  62
  63 importJava "javax.ws.rs.client.WebTarget" where
  64     data WebTarget
  65
  66     path :: WebTarget -> String -> <Proc> WebTarget
  67     request :: WebTarget -> <Proc> Builder
  68
  69 importJava "javax.ws.rs.client.ClientBuilder" where
  70     data ClientBuilder
  71
  72     @JavaName newBuilder
  73     clientBuilder :: <Proc> ClientBuilder
  74
  75 importJava "org.simantics.scl.rest.HttpClientUtils" where
  76     buildClient :: ClientBuilder -> Client
  77     statusMessageOf :: Response -> <Proc> String
  78     asyncInvoke :: Invocation -> ResponseHandler -> FailureHandler -> <Proc> Future Response
  79
  80 importJava "javax.ws.rs.client.Entity" where
  81     data Entity
  82
  83     @JavaName form
  84     formEntity :: Form -> <Proc> Entity
  85     entity :: a -> MediaType -> <Proc> Entity
  86
  87 importJava "javax.ws.rs.client.Client" where
  88     data Client
  89
  90     target :: Client -> String -> <Proc> WebTarget
  91     close :: Client -> <Proc> ()
  92
  93 /*
  94 Example usage:
  95
  96 getExample :: String -> <Proc, Exception> String
  97 getExample uri = do
  98     httpClient = buildClient clientBuilder
  99     webTarget = target httpClient uri
 100     builder = request webTarget
 101     acceptMediaType builder [WILDCARD_TYPE]
 102     invocation = buildGet builder
 103     response = syncInvoke invocation
 104     print $ statusCodeOf response
 105     print $ statusMessageOf response
 106     res = readEntity response
 107     close httpClient
 108     res
 109
 110 postMultiPartExample :: String -> [File] -> <Proc, Exception> String
 111 postMultiPartExample uri files = do
 112     httpClient = buildClient clientBuilder
 113     webTarget = target httpClient uri
 114     builder = request webTarget
 115     acceptMediaType builder [WILDCARD_TYPE]
 116     mp = formDataMultiPart
 117     addBodyPart mp $ formDataBodyPart "Name" "Test" $ withCharset TEXT_PLAIN_TYPE "utf-8"
 118     iterI (\i f ->
 119       addBodyPart mp $ fileDataBodyPart ("file" + show i) f APPLICATION_OCTET_STREAM_TYPE
 120     ) files
 121     invocation = buildPost builder $ entity mp MULTIPART_FORM_DATA_TYPE
 122     response = syncInvoke invocation
 123     print $ statusCodeOf response
 124     print $ statusMessageOf response
 125     res = readEntity response
 126     close httpClient
 127     res
 128
 129 postFileExample :: String -> File -> <Proc, Exception> String
 130 postFileExample uri f = do
 131     httpClient = buildClient clientBuilder
 132     webTarget = target httpClient uri
 133     builder = request webTarget
 134     acceptMediaType builder [WILDCARD_TYPE]
 135     mp = formDataMultiPart
 136     invocation = buildPost builder $ entity f APPLICATION_OCTET_STREAM_TYPE
 137     response = syncInvoke invocation
 138     print $ statusCodeOf response
 139     print $ statusMessageOf response
 140     res = readEntity response
 141     close httpClient
 142     res
 143
 144 postFileAsyncExample :: String -> File -> <Proc, Exception> ()
 145 postFileAsyncExample uri f = do
 146     httpClient = buildClient clientBuilder
 147     webTarget = target httpClient uri
 148     builder = request webTarget
 149     acceptMediaType builder [WILDCARD_TYPE]
 150     mp = formDataMultiPart
 151     invocation = buildPost builder $ entity f APPLICATION_OCTET_STREAM_TYPE
 152     f = asyncInvoke invocation
 153       (\response -> do
 154         print $ statusCodeOf response
 155         print $ statusMessageOf response
 156         catch (do
 157           content = ((readEntity response) :: String)
 158           print $ length content
 159         ) (\(t :: Throwable) -> print $ show t)
 160         close httpClient
 161         ()
 162       )
 163       (\throwable -> do
 164         print $ show throwable
 165         close httpClient
 166         ()
 167       )
 168     print $ isFutureDone f
 169 */