Commits

Alex Suraci  committed c457e20

initial record
Ignore-this: b5d8066cee164bf4dafec2b4d7fa8d8f

  • Participants

Comments (0)

Files changed (2)

+{-# LANGUAGE FlexibleInstances, QuasiQuotes #-}
+
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Valuable
+
+import Network.HTTP
+import Network.Stream
+import Network.URI
+
+load :: VM ()
+load = do
+    eval [$e|HTTP = Object clone|]
+    eval [$e|HTTP Response = Object clone|]
+
+    [$p|HTTP get: (url: String)|] =: do
+        url <- getString [$e|url|]
+        liftIO (simpleHTTP (getRequest url))
+            >>= httpResult
+
+    [$p|HTTP get: (url: String) with: (params: List)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        params <- getList [$e|params|] >>= mapM (\e -> do
+            k <- dispatch (single "from" e) >>= findString
+            v <- dispatch (single "to" e) >>= findString
+            return (fromString k, fromString v))
+
+        liftIO (simpleHTTP (req GET (url { uriQuery = '?' : urlEncodeVars params }) ""))
+            >>= httpResult
+
+    [$p|HTTP put: (url: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        liftIO (simpleHTTP (mkRequest PUT url :: Request String))
+            >>= httpResult
+
+    [$p|HTTP put: (url: String) body: (body: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        body <- getString [$e|body|]
+        liftIO (simpleHTTP (req PUT url body)) >>= httpResult
+
+    [$p|HTTP post: (url: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        liftIO (simpleHTTP (mkRequest POST url :: Request String))
+            >>= httpResult
+
+    [$p|HTTP post: (url: String) body: (body: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        body <- getString [$e|body|]
+        liftIO (simpleHTTP (req POST url body)) >>= httpResult
+
+    [$p|HTTP delete: (url: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        liftIO (simpleHTTP (req DELETE url ""))
+            >>= httpResult
+
+    [$p|HTTP delete: (url: String) body: (body: String)|] =: do
+        url <- getString [$e|url|] >>= toURI
+        body <- getString [$e|body|]
+        liftIO (simpleHTTP (req DELETE url body))
+            >>= httpResult
+  where
+    toURI s =
+        case parseURI s of
+            Nothing -> raise ["invalid-url"] [string s]
+            Just u -> return u
+
+    req meth url body =
+        Request
+            { rqURI = url
+            , rqBody = body
+            , rqHeaders =
+                [ Header HdrContentLength (show (length body))
+                , Header HdrUserAgent defaultUserAgent
+                ]
+            , rqMethod = meth
+            }
+
+    httpResult :: Result (Response String) -> VM Value
+    httpResult r =
+        case r of
+            Left ErrorReset -> raise' "connection-reset"
+            Left ErrorClosed -> raise' "connection-closed"
+            Left (ErrorParse s) -> raise ["http-parse-error"] [string s]
+            Left (ErrorMisc s) -> raise ["http-misc-error"] [string s]
+            Right r -> toValue r
+
+
+instance Valuable (Response String) where
+    toValue r@(Response { rspCode = (c1, c2, c3) }) = do
+        ([$p|r|] =::) =<< eval [$e|HTTP Response clone|]
+
+        ([$p|r code|] =::) =<<
+            list (map (Integer . fromIntegral) [c1, c2, c3])
+
+        [$p|r reason|] =:: string (rspReason r)
+
+        headers <- (list =<<) $ forM (rspHeaders r) $ \(Header n v) ->
+            dispatch (keyword ["->"] [string (show n), string v])
+
+        [$p|r headers|] =:: headers
+
+        [$p|r body|] =:: string (rspBody r)
+        here "r"
+
+    fromValue _ = raise' "no-from-response"
+name: "http"
+description: "interface for Network.HTTP"
+version: 0 . 1
+author: "Alex Suraci"