├── .gitignore
├── CHANGELOG.md
├── Makefile
├── README.md
├── example
    ├── ClientSample.idr
    └── example.ipkg
├── http.ipkg
└── src
    ├── HttpClient.idr
    ├── HttpClient
        ├── Base.idr
        ├── Foreign.idr
        ├── ForeignTypes.idr
        ├── Headers.idr
        ├── Json.idr
        ├── Methods.idr
        └── Requests.idr
    ├── Makefile
    ├── http.c
    ├── http.h
    ├── memstream.c
    └── memstream.h


/.gitignore:
--------------------------------------------------------------------------------
1 | *.ibc
2 | *~
3 | *.o
4 | *.out
5 | httpclient_doc/
6 | example/clientsample
7 | 


--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
 1 | <a name=""></a>
 2 | #  (2016-03-08)
 3 | 
 4 | 
 5 | * Add debug flag cd1a0d4
 6 | * Add new modules to package config 3f5136b
 7 | * Initial version 198f0b0
 8 | * Refactor into a better layer system 6350cd3
 9 | * Update README 1d0c6e7
10 | 
11 | 
12 | 
13 | <a name=""></a>
14 | #  (2016-03-07)
15 | 
16 | 
17 | * Initial version 198f0b0
18 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
 1 | build:
 2 | 	idris --build http.ipkg --warnpartial
 3 | 
 4 | install:
 5 | 	idris --install http.ipkg --warnpartial
 6 | 
 7 | doc:
 8 | 	idris --mkdoc http.ipkg
 9 | 
10 | test:
11 | 	idris --testpkg http.ipkg
12 | 
13 | clean:
14 | 	idris --clean http.ipkg
15 | 	rm -rf httpclient_doc
16 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | 
 2 | ## idris http client
 3 | 
 4 | This is a very limited httpclient implementation based on libcurl for idris.
 5 | It is still littered with debug output and currently just supports a minimal subset
 6 | of HTTP features. It is probably not threadsafe, is leaking memory, the API is far from stable and not documented etc.
 7 | 
 8 | ### Example
 9 | 
10 | Below are some examples of the usage for some request kinds:
11 | 
12 | ```idris
13 | module Main
14 | 
15 | import HttpClient
16 | 
17 | Show Reply where
18 |   show (MkReply statusCode header body) = concat $ intersperse "\n"
19 |                                           ["\nstatusCode: " ,
20 |                                             show statusCode ,
21 |                                           "header:" ,
22 |                                             show header,
23 |                                           "body:",
24 |                                             body]
25 | 
26 | example: String -> IO (Response Reply) -> IO ()
27 | example intro resp= do
28 |   putStrLn intro
29 |   putStrLn $ show !resp
30 |   putStrLn "\n\n\n"
31 | 
32 | main: IO ()
33 | main = do
34 |     example "GET request" $ httpClient
35 |                           $ get
36 |                           $ url "http://httpbin.org/get"
37 | 
38 |     example "POST request" $ httpClient
39 |                            $ post "language=idris&http=libcurl" .
40 |                              withHeader (Link, "up") .
41 |                              withHeader (Accept, "*/*")
42 |                            $ url "http://httpbin.org/post"
43 | 
44 |     example "DELETE request" $ httpClient $ delete "" .
45 |                               withHeaders [
46 |                                 (User_Agent, "idris-httpclient"),
47 |                                 (X_ "Some-Header", "my-data")
48 |                                 ]
49 |                             $ url "http://httpbin.org/delete"
50 | 
51 |     example "Follow request" $ httpClient $ get
52 |                              $ follow
53 |                              $ url "http://httpbin.org/redirect/1"
54 | ```
55 | 
56 | Compile this with
57 | ```bash
58 | idris -p httpclient Main.idr -o main
59 | ```
60 | 
61 | 
62 | ### Installation
63 | 
64 | Installation is only tested on Mac OS X. You will need libcurl (and idris 0.10.2):
65 | 
66 | ```bash
67 | brew install curl
68 | ```
69 | 
70 | You will also need the lightyear parser library available from
71 | [LightYear](https://github.com/ziman/lightyear). Follow the build instructions to put it into your Idris distribution.
72 | 
73 | The Makefile in `/src` assumes a standard location. If that is not ok, adopt to your needs.
74 | If you have the prerequisites, just do:
75 | 
76 | ```bash
77 | make install
78 | ```
79 | 
80 | You will see a warning about a missing main file - that is ok, as long everything typechecks.
81 | 
82 | ### Issues
83 | 
84 | This is pretty much a learning project for me. If you find this project useful, and would like to have features, I am happy to learn in areas which help you. If you have suggestions to make the code better - please let me know.
85 | 
86 | 
87 | ### memstream
88 | 
89 | Memstream implementation taken from http://piumarta.com/software/memstream/
90 | 


--------------------------------------------------------------------------------
/example/ClientSample.idr:
--------------------------------------------------------------------------------
 1 | module Main
 2 | 
 3 | import HttpClient
 4 | import HttpClient.Json
 5 | 
 6 | Show Reply where
 7 |   show (MkReply statusCode header body) = concat $ Prelude.List.intersperse "\n"
 8 |                                           ["\nstatusCode: " ,
 9 |                                             show statusCode ,
10 |                                           "header:" ,
11 |                                             show header,
12 |                                           "body:",
13 |                                             body]
14 | 
15 | example: String -> IO (Response Reply) -> IO ()
16 | example intro resp= do
17 |   putStrLn intro
18 |   putStrLn $ show !resp
19 |   putStrLn "\n\n\n"
20 | 
21 | main: IO ()
22 | main = do
23 |     example "GET request" $ httpClient
24 |                           $ get
25 |                           $ url "http://httpbin.org/get"
26 | 
27 |     example "POST request" $ httpClient
28 |                            $ post "language=idris&http=libcurl" .
29 |                              withHeader (Link, "up") .
30 |                              withHeader (Accept, "*/*")
31 |                            $ url "http://httpbin.org/post"
32 | 
33 |     example "POST json"   $ httpClient
34 |                           $ post (JsonObject ( (insert "foo" (JsonString "bar")) . (insert "bar" (JsonString "foo" ))) empty) .
35 |                              withHeader (Content_Type, "application/json")
36 |                           $ url "http://httpbin.org/post"
37 | 
38 |     example "PUT request" $ httpClient
39 |                           $ put "language=idris&http=libcurl" .
40 |                             withHeader (Link, "up") .
41 |                             withHeader (Accept, "*/*")
42 |                           $ url "http://httpbin.org/put"
43 | 
44 |     example "DELETE request" $ httpClient $ delete "" .
45 |                               withHeaders [
46 |                                 (User_Agent, "idris-httpclient"),
47 |                                 (X_ "Some-Header", "my-data")
48 |                                 ]
49 |                             $ url "http://httpbin.org/delete"
50 | 
51 |     example "Follow request" $ httpClient $ get
52 |                              $ follow
53 |                              $ url "http://httpbin.org/redirect/1"
54 | 


--------------------------------------------------------------------------------
/example/example.ipkg:
--------------------------------------------------------------------------------
 1 | package clientsample
 2 | 
 3 | pkgs = httpclient
 4 | 
 5 | modules = ClientSample
 6 | 
 7 | main = ClientSample
 8 | 
 9 | executable = clientsample
10 | 


--------------------------------------------------------------------------------
/http.ipkg:
--------------------------------------------------------------------------------
 1 | package httpclient
 2 | 
 3 | sourcedir = src
 4 | 
 5 | modules = HttpClient,
 6 |           HttpClient.Base,
 7 |           HttpClient.Methods,
 8 |           HttpClient.Requests,
 9 |           HttpClient.Headers,
10 |           HttpClient.Foreign,
11 |           HttpClient.ForeignTypes,
12 |           HttpClient.Json
13 | 
14 | opts = "-p effects -p lightyear -p contrib"
15 | 
16 | makefile = Makefile
17 | 
18 | objs = http.o, http.h, memstream.o, memstream.h
19 | libs = curl
20 | 


--------------------------------------------------------------------------------
/src/HttpClient.idr:
--------------------------------------------------------------------------------
 1 | ||| HttpClient provides a module to issue Http requests
 2 | module HttpClient
 3 | 
 4 | import HttpClient.Base
 5 | import HttpClient.ForeignTypes
 6 | import public HttpClient.Methods
 7 | import public HttpClient.Requests
 8 | import public HttpClient.Headers
 9 | 
10 | import public Data.SortedMap
11 | 
12 | %access export
13 | %default total
14 | 
15 | 
16 | ||| make a client request
17 | ||| @ request the request record
18 | httpClient: (request: Request) -> IO (Response Reply)
19 | httpClient (MkRequest method url headers options) = do
20 |     -- initialize the curl system
21 |     Right ptr  <- http_init |
22 |       Left error => pure (Left (MkError "error initialising curl"))
23 |     -- set the request url
24 |     Right _    <- http_setopt_url url ptr |
25 |       Left error => pure (Left (MkError "error setting url option"))
26 |     -- append all extra headers
27 |     for headers (\h => http_header_append h ptr)
28 |     -- and other options (e.g. follow) which are treated differently by curl
29 |     for options (\o => http_setopt_option o ptr)
30 |     -- set the request method and if required the body
31 |     Right _    <- http_setopt_method method ptr |
32 |       Left error => pure (Left (MkError "error setting request method"))
33 |     -- perform the request
34 |     Right reply <- http_perform_high ptr |
35 |       Left error => pure (Left (MkError "error performing final request"))
36 |     pure $ Right $ reply
37 | 


--------------------------------------------------------------------------------
/src/HttpClient/Base.idr:
--------------------------------------------------------------------------------
 1 | module HttpClient.Base
 2 | 
 3 | import HttpClient.Requests
 4 | import HttpClient.Methods
 5 | import HttpClient.Headers
 6 | import HttpClient.Foreign
 7 | import Data.Fin
 8 | 
 9 | %access export
10 | %default total
11 | 
12 | ||| initialzie the curl subsystem
13 | http_init: IO (Response CURLPTR)
14 | http_init = do_http_init >>= responsePtr
15 | 
16 | ||| set the url for the request
17 | ||| @ url the url
18 | ||| @ curlHandle the curlHandle
19 | http_setopt_url: (url: String) -> (curlHandle: CURLPTR) -> IO (Response Ok)
20 | http_setopt_url url (MkHttp ptr) =
21 |   responseTy <$> (do_http_setopt_url url ptr)
22 | 
23 | ||| set the request method
24 | ||| @ method the request method
25 | ||| @ curlHandle the curlHandle
26 | http_setopt_method: (method: Method) -> (curlHandle: CURLPTR) -> IO (Response Ok)
27 | http_setopt_method (GET) (MkHttp ptr)  = do_http_setopt_method 0 ptr
28 | http_setopt_method (POST d) (MkHttp ptr)  =
29 |   do
30 |     r1 <- do_http_setopt_method 1 ptr
31 |     r2 <- do_http_setopt_postfields (bodyToString d) ptr
32 |     pure $  r2
33 | http_setopt_method (PUT d) (MkHttp ptr) =
34 |   do
35 |     do_http_setopt_method 2 ptr
36 |     r <- do_http_setopt_postfields (bodyToString d) ptr
37 |     pure $ r
38 | http_setopt_method (DELETE d) (MkHttp ptr) = do_http_setopt_method 3 ptr
39 | 
40 | http_header_append: (header: Header) -> (curlHandle: CURLPTR) -> IO (CURLPTR)
41 | http_header_append header (MkHttp ptr) =
42 |   MkHttp <$> (do_http_header_append (showHeader header) ptr)
43 | 
44 | http_setopt_option: Option -> (curlHandle: CURLPTR) -> IO (Response Ok)
45 | http_setopt_option FOLLOW (MkHttp ptr) = do_http_setopt_follow ptr
46 | 
47 | 
48 | ||| higher level perform of the request, which
49 | ||| transforms the request into a reply
50 | ||| @ curlHandle the curlHandle
51 | http_perform_high: (curlHandle: CURLPTR) -> IO (Response Reply)
52 | http_perform_high curlPtr = do
53 |     responsePtr <- do_http_perform curlPtr
54 |     if !(nullPtr $ getResponsePtr responsePtr)
55 |       then pure $ Left $ MkError ("Error in curl subsystem")
56 |       else
57 |         do
58 |         body <- response_body responsePtr
59 |         header <- parseHeaders <$> response_header responsePtr
60 |         statusCode <- response_code responsePtr
61 |         do_http_cleanup curlPtr
62 |         pure $ Right $ MkReply statusCode header body
63 | 


--------------------------------------------------------------------------------
/src/HttpClient/Foreign.idr:
--------------------------------------------------------------------------------
 1 | module HttpClient.Foreign
 2 | 
 3 | import HttpClient.Requests
 4 | import public HttpClient.ForeignTypes
 5 | 
 6 | %include C "http.h"
 7 | %include C "curl/curl.h"
 8 | %link C "http.o"
 9 | %link C "memstream.o"
10 | %lib C "curl"
11 | 
12 | %access export
13 | %default total
14 | 
15 | ||| extract the primitive Ptr from a RESPONSEPTR
16 | getResponsePtr: RESPONSEPTR -> Ptr
17 | getResponsePtr (MkResponse ptr) = ptr
18 | 
19 | ||| map a C interface response to a Response
20 | responseTy: Int -> Response Ok
21 | responseTy resp =
22 |   if (resp == 0)
23 |     then Right MkOk
24 |     else Left (MkNotOk resp)
25 | 
26 | responsePtr: Ptr -> IO (Response CURLPTR)
27 | responsePtr ptr = if !(Strings.nullPtr ptr)
28 |                   then pure $ Left (MkError "ptr is null")
29 |                   else pure $(Right $ MkHttp ptr)
30 | 
31 | -- PROJECTIONS
32 | 
33 | ||| projection for the C Response struct
34 | response_body: RESPONSEPTR -> IO String
35 | response_body (MkResponse ptr) =
36 |   foreign FFI_C "response_body" (Ptr -> IO String) ptr
37 | 
38 | ||| projection for the C Response struct
39 | response_header: RESPONSEPTR -> IO String
40 | response_header (MkResponse ptr) =
41 |   foreign FFI_C "response_header" (Ptr -> IO String) ptr
42 | 
43 | ||| projection for the C Response struct
44 | response_code: RESPONSEPTR -> IO Int
45 | response_code (MkResponse ptr) =
46 |   foreign FFI_C "response_code" (Ptr -> IO Int) ptr
47 | 
48 | -- PRIMITIVE IO OPERATIONS
49 | 
50 | -- Setter
51 | 
52 | ||| set the method for the request
53 | do_http_setopt_method: Int -> Ptr -> IO (Response Ok)
54 | do_http_setopt_method m ptr =
55 |   responseTy <$> foreign FFI_C "http_easy_setopt_method" (Ptr -> Int -> IO Int) ptr m
56 | 
57 | ||| set POST data
58 | do_http_setopt_postfields: String -> Ptr -> IO (Response Ok)
59 | do_http_setopt_postfields d ptr =
60 |   responseTy <$> foreign FFI_C "http_easy_setopt_postfields" (Ptr -> String -> IO Int) ptr d
61 | 
62 | ||| set the url for the request
63 | ||| * url the url
64 | do_http_setopt_url: (url: String) -> Ptr -> IO Int
65 | do_http_setopt_url url ptr =
66 |   foreign FFI_C "http_easy_setopt_url" (Ptr -> String -> IO Int) ptr url
67 | 
68 | do_http_header_append: (header: String) -> Ptr -> IO Ptr
69 | do_http_header_append header ptr =
70 |   foreign FFI_C "http_header_append" (Ptr -> String -> IO Ptr) ptr header
71 | 
72 | do_http_setopt_follow: Ptr -> IO (Response Ok)
73 | do_http_setopt_follow ptr =
74 |   responseTy <$> foreign FFI_C "http_easy_setopt_follow" (Ptr -> IO Int) ptr
75 | 
76 | -- Lifecycle
77 | 
78 | ||| initialze the curl subsystem
79 | do_http_init: IO (Ptr)
80 | do_http_init =
81 |   foreign FFI_C "http_easy_init" (IO Ptr)
82 | 
83 | ||| low level perform of the request
84 | do_http_perform: CURLPTR -> IO (RESPONSEPTR)
85 | do_http_perform (MkHttp ptr) =
86 |   MkResponse <$> foreign FFI_C "http_easy_perform" (Ptr -> IO Ptr) ptr
87 | 
88 | ||| cleanup the curl subsystem
89 | do_http_cleanup: CURLPTR -> IO ()
90 | do_http_cleanup (MkHttp ptr) =
91 |   foreign FFI_C "http_easy_cleanup" (Ptr -> IO ()) ptr
92 | 


--------------------------------------------------------------------------------
/src/HttpClient/ForeignTypes.idr:
--------------------------------------------------------------------------------
 1 | module HttpClient.ForeignTypes
 2 | 
 3 | %access export
 4 | %default total
 5 | 
 6 | -- Data Types
 7 | 
 8 | ||| A handle for curl
 9 | public export
10 | data CURLPTR =
11 |   ||| constructor
12 |   MkHttp Ptr
13 | 
14 | ||| A handle for the curl response struct
15 | public export
16 | data RESPONSEPTR =
17 |   ||| constructor
18 |   MkResponse Ptr
19 | 


--------------------------------------------------------------------------------
/src/HttpClient/Headers.idr:
--------------------------------------------------------------------------------
  1 | module HttpClient.Headers
  2 | 
  3 | %default total
  4 | %access export
  5 | 
  6 | public export
  7 | Header: Type
  8 | Header = (String, String)
  9 | 
 10 | %name Header header
 11 | 
 12 | public export
 13 | Headers: Type
 14 | Headers = List Header
 15 | 
 16 | %name Headers headers
 17 | 
 18 | private
 19 | parseHeader: String -> Header
 20 | parseHeader h = let keyValue = break (\c => c == ':') h
 21 |                     key = trim $ fst keyValue
 22 |                     valueColon = snd keyValue
 23 |                     value = trim $ substr 1 (length valueColon) valueColon
 24 |                 in (key, value)
 25 | 
 26 | ||| parse a string of response headers into a Headers
 27 | parseHeaders: String -> Headers
 28 | parseHeaders h = parseHeader <$> lines h
 29 | 
 30 | ||| Taken from https://en.wikipedia.org/wiki/List_of_HTTP_header_fields
 31 | public export
 32 | data HeaderFields =
 33 |   Accept |
 34 |   Accept_CharSet |
 35 |   Accept_Encoding |
 36 |   Accept_Language |
 37 |   Accept_Datetime |
 38 |   Authorization |
 39 |   Cache_Control |
 40 |   Connection |
 41 |   Cookie |
 42 |   Content_Length |
 43 |   Content_MD5 |
 44 |   Content_Type |
 45 |   Date |
 46 |   Expect |
 47 |   Forwarded |
 48 |   From |
 49 |   If_Match |
 50 |   If_Modified_Since |
 51 |   If_None_Match |
 52 |   If_Range |
 53 |   Link |
 54 |   Max_Forwards |
 55 |   Origin |
 56 |   Pragma |
 57 |   Proxy_Authorization |
 58 |   Range |
 59 |   Referer |
 60 |   User_Agent |
 61 |   Upgrade |
 62 |   Via |
 63 |   Warning |
 64 |   ||| An arbitrary HTTP header in the form of
 65 |   ||| "X-Foo"
 66 |   X_ String
 67 | 
 68 | %name HeaderFields hf, hf1, hf2
 69 | 
 70 | Show HeaderFields where
 71 |   show Accept = "Accept"
 72 |   show Accept_CharSet = "Accept-CharSet"
 73 |   show Accept_Encoding = "Accept-Encoding"
 74 |   show Accept_Language = "Accept-Language"
 75 |   show Accept_Datetime = "Accept-Datetime"
 76 |   show Authorization = "Authorization"
 77 |   show Cache_Control = "Cache-Control"
 78 |   show Connection = "Connection"
 79 |   show Cookie = "Cookie"
 80 |   show Content_Length = "Content-Length"
 81 |   show Content_MD5 = "Content-MD5"
 82 |   show Content_Type = "Content-Type"
 83 |   show Date = "Date"
 84 |   show Expect = "Expect"
 85 |   show Forwarded = "Forwarded"
 86 |   show From = "From"
 87 |   show If_Match = "If-Match"
 88 |   show If_Modified_Since = "If-Modified-Since"
 89 |   show If_None_Match = "If-None-Match"
 90 |   show If_Range = "If-Range"
 91 |   show Link = "Link"
 92 |   show Max_Forwards = "Max-Forwards"
 93 |   show Origin = "Origin"
 94 |   show Pragma = "Pragma"
 95 |   show Proxy_Authorization = "Proxy-Authorization"
 96 |   show Range = "Range"
 97 |   show Referer = "Referer"
 98 |   show User_Agent = "User-Agent"
 99 |   show Upgrade = "Upgrade"
100 |   show Via = "Via"
101 |   show Warning = "Warning"
102 |   show (X_ x) = "X-" ++ x
103 | 
104 | implicit headerFieldsToString: HeaderFields -> String
105 | headerFieldsToString hf = show hf
106 | 
107 | showHeader: Header -> String
108 | showHeader header = (fst header) ++ ": " ++ (snd header)
109 | 


--------------------------------------------------------------------------------
/src/HttpClient/Json.idr:
--------------------------------------------------------------------------------
  1 | module HttpClient.Json
  2 | 
  3 | -- This file is copied from the example directory of lightyear
  4 | 
  5 | import public Lightyear
  6 | import public Lightyear.Char
  7 | import public Lightyear.Strings
  8 | 
  9 | import public Data.SortedMap
 10 | 
 11 | %access public export
 12 | 
 13 | data JsonValue = JsonString String
 14 |                | JsonNumber Double
 15 |                | JsonBool Bool
 16 |                | JsonNull
 17 |                | JsonArray (List JsonValue)
 18 |                | JsonObject (SortedMap String JsonValue)
 19 | 
 20 | Show JsonValue where
 21 |   show (JsonString s)   = show s
 22 |   show (JsonNumber x)   = show x
 23 |   show (JsonBool True ) = "true"
 24 |   show (JsonBool False) = "false"
 25 |   show  JsonNull        = "null"
 26 |   show (JsonArray  xs)  = show xs
 27 |   show (JsonObject xs)  =
 28 |       "{" ++ intercalate ", " (map fmtItem $ SortedMap.toList xs) ++ "}"
 29 |     where
 30 |       intercalate : String -> List String -> String
 31 |       intercalate sep [] = ""
 32 |       intercalate sep [x] = x
 33 |       intercalate sep (x :: xs) = x ++ sep ++ intercalate sep xs
 34 | 
 35 |       fmtItem (k, v) = show k ++ ": " ++ show v
 36 | 
 37 | hex : Parser Int
 38 | hex = do
 39 |   c <- map (ord . toUpper) $ satisfy isHexDigit
 40 |   pure $ if c >= ord '0' && c <= ord '9' then c - ord '0'
 41 |                                          else 10 + c - ord 'A'
 42 | 
 43 | hexQuad : Parser Int
 44 | hexQuad = do
 45 |   a <- hex
 46 |   b <- hex
 47 |   c <- hex
 48 |   d <- hex
 49 |   pure $ a * 4096 + b * 256 + c * 16 + d
 50 | 
 51 | specialChar : Parser Char
 52 | specialChar = do
 53 |   c <- anyChar
 54 |   case c of
 55 |     '"'  => pure '"'
 56 |     '\\' => pure '\\'
 57 |     '/'  => pure '/'
 58 |     'b'  => pure '\b'
 59 |     'f'  => pure '\f'
 60 |     'n'  => pure '\n'
 61 |     'r'  => pure '\r'
 62 |     't'  => pure '\t'
 63 |     'u'  => map chr hexQuad
 64 |     _    => fail "expected special char"
 65 | 
 66 | jsonString' : Parser (List Char)
 67 | jsonString' = (char '"' *!> pure Prelude.List.Nil) <|> do
 68 |   c <- satisfy (/= '"')
 69 |   if (c == '\\') then map (::) specialChar <*> jsonString'
 70 |                  else map (c ::) jsonString'
 71 | 
 72 | jsonString : Parser String
 73 | jsonString = char '"' *> map pack jsonString' <?> "JSON string"
 74 | 
 75 | -- inspired by Haskell's Data.Scientific module
 76 | record Scientific where
 77 |   constructor MkScientific
 78 |   coefficient : Integer
 79 |   exponent : Integer
 80 | 
 81 | scientificToDouble : Scientific -> Double
 82 | scientificToDouble (MkScientific c e) = fromInteger c * exp
 83 |   where exp = if e < 0 then 1 / pow 10 (fromIntegerNat (- e))
 84 |                        else pow 10 (fromIntegerNat e)
 85 | 
 86 | parseScientific : Parser Scientific
 87 | parseScientific = do sign <- maybe 1 (const (-1)) `map` opt (char '-')
 88 |                      digits <- some digit
 89 |                      hasComma <- isJust `map` opt (char '.')
 90 |                      decimals <- if hasComma then some digit else pure Prelude.List.Nil
 91 |                      hasExponent <- isJust `map` opt (char 'e')
 92 |                      exponent <- if hasExponent then integer else pure 0
 93 |                      pure $ MkScientific (sign * fromDigits (digits ++ decimals))
 94 |                                          (exponent - cast (length decimals))
 95 |   where fromDigits : List (Fin 10) -> Integer
 96 |         fromDigits = foldl (\a, b => 10 * a + cast b) 0
 97 | 
 98 | jsonNumber : Parser Double
 99 | jsonNumber = map scientificToDouble parseScientific
100 | 
101 | jsonBool : Parser Bool
102 | jsonBool  =  (char 't' >! string "rue"  *> return True)
103 |          <|> (char 'f' >! string "alse" *> return False) <?> "JSON Bool"
104 | 
105 | jsonNull : Parser ()
106 | jsonNull = (char 'n' >! string "ull" >! return ()) <?> "JSON Null"
107 | 
108 | mutual
109 |   jsonArray : Parser (List JsonValue)
110 |   jsonArray = char '[' *!> (jsonValue `sepBy` (char ',')) <* char ']'
111 | 
112 |   keyValuePair : Parser (String, JsonValue)
113 |   keyValuePair = do
114 |     key <- spaces *> jsonString <* spaces
115 |     char ':'
116 |     value <- jsonValue
117 |     pure (key, value)
118 | 
119 |   jsonObject : Parser (SortedMap String JsonValue)
120 |   jsonObject = map fromList (char '{' >! (keyValuePair `sepBy` char ',') <* char '}')
121 | 
122 |   jsonValue' : Parser JsonValue
123 |   jsonValue' =  (map JsonString jsonString)
124 |             <|> (map JsonNumber jsonNumber)
125 |             <|> (map JsonBool   jsonBool)
126 |             <|> (pure JsonNull <* jsonNull)
127 |             <|>| map JsonArray  jsonArray
128 |             <|>| map JsonObject jsonObject
129 | 
130 |   jsonValue : Parser JsonValue
131 |   jsonValue = spaces *> jsonValue' <* spaces
132 | 
133 | jsonToplevelValue : Parser JsonValue
134 | jsonToplevelValue = (map JsonArray jsonArray) <|> (map JsonObject jsonObject)
135 | 


--------------------------------------------------------------------------------
/src/HttpClient/Methods.idr:
--------------------------------------------------------------------------------
 1 | module HttpClient.Methods
 2 | 
 3 | import Data.Fin
 4 | import HttpClient.Json
 5 | 
 6 | %access export
 7 | %default partial
 8 | 
 9 | total
10 | Body: Type
11 | Body = String
12 | 
13 | total
14 | bodyToString: Body -> String
15 | bodyToString b = b
16 | 
17 | ||| Interface to transform arbitrary types
18 | ||| into a Body of a request
19 | public export
20 | interface Writeable a where
21 |   writeBody: a -> Body
22 | 
23 | public export
24 | Writeable String where
25 |   writeBody = id
26 | 
27 | public export
28 | Writeable JsonValue where
29 |   writeBody jsValue = show jsValue
30 | 
31 | ||| the Http Method
32 | public export
33 | data Method: Type where
34 |   ||| GET request without a body
35 |   GET: Method
36 |   ||| POST request with a body
37 |   POST: Body -> Method
38 |   ||| PUT request with a body
39 |   PUT: Body -> Method
40 |   ||| DELETE rquest with a body
41 |   DELETE: Body -> Method
42 | 
43 | %name Method method
44 | 


--------------------------------------------------------------------------------
/src/HttpClient/Requests.idr:
--------------------------------------------------------------------------------
  1 | module HttpClient.Requests
  2 | 
  3 | import HttpClient.Methods
  4 | import HttpClient.Headers
  5 | 
  6 | %access export
  7 | %default total
  8 | 
  9 | public export
 10 | data Option =
 11 |   FOLLOW
 12 | 
 13 | %name Option option
 14 | 
 15 | public export
 16 | record Request where
 17 |   constructor MkRequest
 18 |   method: Method
 19 |   url: String
 20 |   headers: Headers
 21 |   options: List Option
 22 | 
 23 | %name Request request
 24 | 
 25 | public export
 26 | record Reply where
 27 |   constructor MkReply
 28 |   statusCode: Int
 29 |   header: Headers
 30 |   body: String
 31 | 
 32 | %name Reply reply
 33 | 
 34 | ||| Type to signify that responses we get from the API are ok,
 35 | ||| e.g. they represent CURLE_OK values
 36 | public export
 37 | data Ok =
 38 |   MkOk
 39 | 
 40 | ||| Error type
 41 | public export
 42 | data NotOk =
 43 |   MkNotOk Int |
 44 |   MkError String
 45 | 
 46 | ||| Shortcut for Either NotOk x
 47 | public export
 48 | Response: (x: Type) -> Type
 49 | Response x = Either NotOk x
 50 | 
 51 | -- Request Builder
 52 | 
 53 | ||| constructs a standard request towards an URL
 54 | ||| and GET method
 55 | url: (url: String) -> Request
 56 | url url = MkRequest GET url [] []
 57 | 
 58 | ||| adds a header to the request
 59 | withHeader: Header -> Request -> Request
 60 | withHeader header request = record { headers = header :: (headers request)} request
 61 | 
 62 | ||| adds headers to the request
 63 | withHeaders: Headers -> Request -> Request
 64 | withHeaders hs request = record { headers = hs ++ (headers request)} request
 65 | 
 66 | private
 67 | withMethod: Method -> Request -> Request
 68 | withMethod method request = record { method = method } request
 69 | 
 70 | private
 71 | withOption: Option -> Request -> Request
 72 | withOption option request = record { options = option :: (options request)} request
 73 | 
 74 | ||| sets the GET request method
 75 | get: Request -> Request
 76 | get request = withMethod (GET) request
 77 | 
 78 | ||| sets the POST request method together with the appropriate body
 79 | ||| by default this is interpreted as urlenconded form data.
 80 | post: Writeable a => a -> Request -> Request
 81 | post body request = withMethod (POST $ writeBody body) request
 82 | 
 83 | put: Writeable a => a -> Request -> Request
 84 | put body request= withMethod (PUT $ writeBody body) request
 85 | 
 86 | delete: Writeable a => a  -> Request -> Request
 87 | delete body = withMethod (DELETE $ writeBody body)
 88 | 
 89 | ||| option to follow redirects
 90 | follow: Request -> Request
 91 | follow = withOption FOLLOW
 92 | 
 93 | -- Instances
 94 | 
 95 | Show Ok where
 96 |   show s = "OK"
 97 | 
 98 | Show NotOk where
 99 |   show (MkError s) = s
100 |   show (MkNotOk resp) = concat ["Not Ok ", show resp]
101 | 


--------------------------------------------------------------------------------
/src/Makefile:
--------------------------------------------------------------------------------
 1 | # the compiler: gcc for C program
 2 | CC = gcc
 3 | 
 4 | # debug flags
 5 | #DEBUG = -D_HTTPCLIENT_DEBUG=1
 6 | 
 7 | # compiler flags:
 8 | CFLAGS  = -Wall -I/usr/local/opt/curl/include $(DEBUG)
 9 | 
10 | # linker flags:
11 | LDFLAGS = -L/usr/local/opt/curl/lib
12 | 
13 | # define any libraries to link:
14 | LIBS = -lcurl
15 | 
16 | SRCS = http.c memstream.c
17 | 
18 | all: $(SRCS)
19 | 	$(CC) $(CFLAGS) -c $(SRCS) $(LFLAGS)
20 | 
21 | clean:
22 | 	$(RM) *.o *~  a.out
23 | 


--------------------------------------------------------------------------------
/src/http.c:
--------------------------------------------------------------------------------
  1 | #include <stdio.h>
  2 | #include <stdlib.h>
  3 | #include <string.h>
  4 | #include <curl/curl.h>
  5 | #include "memstream.h"
  6 | 
  7 | 
  8 | struct Response {
  9 |   long response_code;
 10 |   char *header;
 11 |   char *body;
 12 |   size_t body_size;
 13 |   size_t header_size;
 14 | };
 15 | 
 16 | static struct Response response;
 17 | static struct curl_slist *headerList=NULL;
 18 | 
 19 | long response_code(struct Response *r) {
 20 |   return ((struct Response *) r)->response_code;
 21 | }
 22 | 
 23 | char *response_body(struct Response *r) {
 24 |   return ((struct Response *) r)->body;
 25 | }
 26 | 
 27 | char *response_header(struct Response *r) {
 28 |   #ifdef _HTTPCLIENT_DEBUG
 29 |   fprintf(stderr, "header in response_header: %s\n", ((struct Response *)r)->header);
 30 |   #endif
 31 |   return ((struct Response *) r)->header;
 32 | }
 33 | 
 34 | size_t response_body_size(struct Response *r) {
 35 |   return ((struct Response *) r)->body_size;
 36 | }
 37 | 
 38 | size_t response_header_size(struct Response *r) {
 39 |   return ((struct Response *) r)->header_size;
 40 | }
 41 | 
 42 | void *http_header_append(void *curl, char *header ) {
 43 |   #ifdef _HTTPCLIENT_DEBUG
 44 |   fprintf(stderr, "adding header: %s\n", header);
 45 |   #endif
 46 |   headerList = curl_slist_append(headerList,  header );
 47 |   return (void *) curl;
 48 | }
 49 | 
 50 | void* http_easy_init(void) {
 51 |   CURL *curl = curl_easy_init();
 52 |   return (void *) curl;
 53 | }
 54 | 
 55 | void http_easy_cleanup(void *curl) {
 56 |   if (headerList != NULL) {
 57 |     curl_slist_free_all(headerList);
 58 |     headerList = NULL;
 59 |   }
 60 |   return curl_easy_cleanup((CURL *) curl);
 61 | }
 62 | 
 63 | int http_easy_setopt_url(void *curl, char *url) {
 64 |   return (int) curl_easy_setopt((CURL *) curl, CURLOPT_URL, url);
 65 | }
 66 | 
 67 | int http_easy_setopt_follow(void *curl) {
 68 |   return (int) curl_easy_setopt((CURL *) curl, CURLOPT_FOLLOWLOCATION, 1L);
 69 | }
 70 | 
 71 | int http_easy_setopt_method(void *curl, int method) {
 72 |   CURL *c = (CURL *) curl;
 73 |   switch (method) {
 74 |     case 1: // POST ;
 75 |       #ifdef _HTTPCLIENT_DEBUG
 76 |       fprintf(stderr, "setup post request");
 77 |       #endif
 78 |       return curl_easy_setopt(curl, CURLOPT_POST, 1L);
 79 |       break;
 80 |     case 2: // PUT ;
 81 |       #ifdef _HTTPCLIENT_DEBUG
 82 |       fprintf(stderr, "setup put request");
 83 |       #endif
 84 |       return curl_easy_setopt(curl, CURLOPT_CUSTOMREQUEST, "PUT");
 85 |       break;
 86 |     case 3: // DELETE ;
 87 |       #ifdef _HTTPCLIENT_DEBUG
 88 |       fprintf(stderr, "setup delete request");
 89 |       #endif
 90 |       return curl_easy_setopt(curl, CURLOPT_CUSTOMREQUEST, "DELETE");
 91 |       break;
 92 |     default: //GET ;
 93 |       #ifdef _HTTPCLIENT_DEBUG
 94 |       fprintf(stderr, "setup get request");
 95 |       #endif
 96 |       return curl_easy_setopt(c, CURLOPT_HTTPGET,  1L);
 97 |       break;
 98 |   }
 99 | }
100 | 
101 | int http_easy_setopt_postfields(void *curl, char* data) {
102 |   CURL *c = (CURL *) curl;
103 |   return curl_easy_setopt(c, CURLOPT_POSTFIELDS, data);
104 | }
105 | 
106 | void *http_easy_perform(void *curl) {
107 |   CURL *curlHandle = (CURL *) curl;
108 |   long response_code;
109 |   CURLcode res;
110 |   char *bodyBuffer;
111 |   char *headerBuffer;
112 |   size_t bodySize;
113 |   size_t headerSize;
114 |   FILE *bodyFile;
115 |   FILE *headerFile;
116 | 
117 |   bodyFile = open_memstream (&bodyBuffer, &bodySize);
118 |   headerFile = open_memstream (&headerBuffer, &headerSize);
119 | 
120 |   curl_easy_setopt(curlHandle, CURLOPT_WRITEDATA, (void *)bodyFile);
121 |   curl_easy_setopt(curlHandle, CURLOPT_HEADERDATA, (void *)headerFile);
122 | 
123 |   if (headerList != NULL) {
124 |     curl_easy_setopt(curlHandle, CURLOPT_HTTPHEADER, headerList);
125 |   }
126 | 
127 |   res = curl_easy_perform(curlHandle);
128 |   fclose(bodyFile);
129 |   fclose(headerFile);
130 | 
131 |   if (res != CURLE_OK) {
132 |     fprintf(stderr, "curl_easy_perform() failed: %s\n--- %s, line %d\n",
133 |       curl_easy_strerror(res),
134 |       __FILE__,
135 |       __LINE__);
136 |     return NULL;
137 |   }
138 |   else {
139 |     res = curl_easy_getinfo((CURL *) curl, CURLINFO_RESPONSE_CODE, &response_code);
140 |     response.response_code = response_code;
141 |     response.header_size = headerSize;
142 |     response.header = headerBuffer;
143 |     response.body_size = bodySize;
144 |     response.body = bodyBuffer;
145 |     #ifdef _HTTPCLIENT_DEBUG
146 |     fprintf(stderr, "header in http_easy_perform: %s\n", headerBuffer);
147 |     fprintf(stderr, "body in http_easy_perform: %s\n", bodyBuffer);
148 |     #endif
149 | 
150 |     return &response;
151 |   }
152 | }
153 | 


--------------------------------------------------------------------------------
/src/http.h:
--------------------------------------------------------------------------------
 1 | #ifndef __HTTP_H
 2 | #define __HTTP_H
 3 | 
 4 | //
 5 | // CURL_EXTERN CURL *curl_easy_init(void);
 6 | // CURL_EXTERN CURLcode curl_easy_setopt(CURL *curl, CURLoption option, ...);
 7 | // CURL_EXTERN CURLcode curl_easy_perform(CURL *curl);
 8 | // CURL_EXTERN void curl_easy_cleanup(CURL *curl);
 9 | 
10 | long response_code(void *r);
11 | 
12 | char *response_body(void *r);
13 | char *response_header(void *r);
14 | 
15 | size_t response_body_size(void *r);
16 | size_t response_header_size(void *r);
17 | 
18 | 
19 | int http_easy_setopt_url(void *curl, char *url);
20 | int http_easy_setopt_method(void *curl, int method);
21 | int http_easy_setopt_postfields(void *curl, char* data);
22 | int http_easy_setopt_follow(void *curl);
23 | 
24 | void *http_header_append(void *curl, char *header );
25 | 
26 | void *http_easy_init(void);
27 | void *http_easy_perform(void *curl);
28 | void http_easy_cleanup(void *curl);
29 | 
30 | 
31 | #endif
32 | 


--------------------------------------------------------------------------------
/src/memstream.c:
--------------------------------------------------------------------------------
  1 | /* Compile this file and link the object with your program.  On a recent
  2 |  * GNU/Linux machine the object file will be empty.  On anything derived from
  3 |  * 4.4BSD (Darwin, the Three BSDs, etc.) it will contain an implementation of
  4 |  * open_memstream() as described in the POSIX and Linux manual pages.  On
  5 |  * anything else it will probably cause a compilation error.
  6 |  *
  7 |  * ----------------------------------------------------------------------------
  8 |  *
  9 |  * OPEN_MEMSTREAM(3)      BSD and Linux Library Functions     OPEN_MEMSTREAM(3)
 10 |  *
 11 |  * SYNOPSIS
 12 |  *     #include "memstream.h"
 13 |  *
 14 |  *     FILE *open_memstream(char **bufp, size_t *sizep);
 15 |  *
 16 |  * DESCRIPTION
 17 |  *     The open_memstream()  function opens a  stream for writing to  a buffer.
 18 |  *     The   buffer  is   dynamically  allocated   (as  with   malloc(3)),  and
 19 |  *     automatically grows  as required.  After closing the  stream, the caller
 20 |  *     should free(3) this buffer.
 21 |  *
 22 |  *     When  the  stream is  closed  (fclose(3))  or  flushed (fflush(3)),  the
 23 |  *     locations  pointed  to  by  bufp  and  sizep  are  updated  to  contain,
 24 |  *     respectively,  a pointer  to  the buffer  and  the current  size of  the
 25 |  *     buffer.  These values  remain valid only as long  as the caller performs
 26 |  *     no further output  on the stream.  If further  output is performed, then
 27 |  *     the  stream  must  again  be  flushed  before  trying  to  access  these
 28 |  *     variables.
 29 |  *
 30 |  *     A null byte  is maintained at the  end of the buffer.  This  byte is not
 31 |  *     included in the size value stored at sizep.
 32 |  *
 33 |  *     The stream's  file position can  be changed with fseek(3)  or fseeko(3).
 34 |  *     Moving the file position past the  end of the data already written fills
 35 |  *     the intervening space with zeros.
 36 |  *
 37 |  * RETURN VALUE
 38 |  *     Upon  successful  completion open_memstream()  returns  a FILE  pointer.
 39 |  *     Otherwise, NULL is returned and errno is set to indicate the error.
 40 |  *
 41 |  * CONFORMING TO
 42 |  *     POSIX.1-2008
 43 |  *
 44 |  * ----------------------------------------------------------------------------
 45 |  */
 46 | 
 47 | #include "memstream.h"
 48 | 
 49 | #if _POSIX_C_SOURCE < 200809L
 50 | 
 51 | #include <stddef.h>
 52 | #include <stdlib.h>
 53 | #include <string.h>
 54 | #include <errno.h>
 55 | #include <assert.h>
 56 | 
 57 | #define min(X, Y) (((X) < (Y)) ? (X) : (Y))
 58 | 
 59 | struct memstream
 60 | {
 61 |     int      position;
 62 |     int      size;
 63 |     int      capacity;
 64 |     char    *contents;
 65 |     char   **ptr;
 66 |     size_t  *sizeloc;
 67 | };
 68 | 
 69 | #if MEMSTREAM_DEBUG
 70 |   static void memstream_print(struct memstream *ms)
 71 |   {
 72 |       printf("memstream %p {", ms);
 73 |       printf(" %i", ms->position);
 74 |       printf(" %i", ms->size);
 75 |       printf(" %i", ms->capacity);
 76 |       printf(" %p", ms->contents);
 77 |       printf(" }\n");
 78 |   }
 79 | # define memstream_info(ARGS) printf ARGS
 80 | #else
 81 | # define memstream_print(ms)
 82 | # define memstream_info(ARGS)
 83 | #endif
 84 | 
 85 | #define memstream_check(MS) if (!(MS)->contents) { errno= ENOMEM;  return -1; }
 86 | 
 87 | static int memstream_grow(struct memstream *ms, int minsize)
 88 | {
 89 |     int newcap= ms->capacity * 2;					memstream_check(ms);
 90 |     while (newcap <= minsize) newcap *= 2;				memstream_info(("grow %p to %i\n", ms, newcap));
 91 |     ms->contents= realloc(ms->contents, newcap);
 92 |     if (!ms->contents) return -1;	/* errno == ENOMEM */
 93 |     memset(ms->contents + ms->capacity, 0, newcap - ms->capacity);
 94 |     ms->capacity= newcap;
 95 |     *ms->ptr= ms->contents;		/* size has not changed */
 96 |     return 0;
 97 | }
 98 | 
 99 | static int memstream_read(void *cookie, char *buf, int count)
100 | {
101 |     struct memstream *ms= (struct memstream *)cookie;			memstream_check(ms);
102 |     int n= min(ms->size - ms->position, count);				memstream_info(("memstream_read %p %i\n", ms, count));
103 |     if (n < 1) return 0;
104 |     memcpy(buf, ms->contents, n);
105 |     ms->position += n;							memstream_print(ms);
106 |     return n;
107 | }
108 | 
109 | static int memstream_write(void *cookie, const char *buf, int count)
110 | {
111 |     struct memstream *ms= (struct memstream *)cookie;			memstream_check(ms);
112 |     if (ms->capacity <= ms->position + count)
113 | 	if (memstream_grow(ms, ms->position + count) < 0)		/* errno == ENOMEM */
114 | 	    return -1;
115 |     memcpy(ms->contents + ms->position, buf, count);			memstream_info(("memstream_write %p %i\n", ms, count));
116 |     ms->position += count;
117 |     if (ms->size < ms->position) *ms->sizeloc= ms->size= ms->position;	memstream_print(ms);
118 | 									assert(ms->size < ms->capacity);
119 | 									assert(ms->contents[ms->size] == 0);
120 |     return count;
121 | }
122 | 
123 | static fpos_t memstream_seek(void *cookie, fpos_t offset, int whence)
124 | {
125 |     struct memstream *ms= (struct memstream *)cookie;
126 |     fpos_t pos= 0;							memstream_check(ms);
127 | 									memstream_info(("memstream_seek %p %i %i\n", ms, (int)offset, whence));
128 |     switch (whence) {
129 | 	case SEEK_SET:	pos= offset;			break;
130 | 	case SEEK_CUR:	pos= ms->position + offset;	break;
131 | 	case SEEK_END:	pos= ms->size + offset;		break;
132 | 	default:	errno= EINVAL;			return -1;
133 |     }
134 |     if (pos >= ms->capacity) memstream_grow(ms, pos);
135 |     ms->position= pos;
136 |     if (ms->size < ms->position) *ms->sizeloc= ms->size= ms->position;	memstream_print(ms);  memstream_info(("=> %i\n", (int)pos));
137 | 									assert(ms->size < ms->capacity && ms->contents[ms->size] == 0);
138 |     return pos;
139 | }
140 | 
141 | static int memstream_close(void *cookie)
142 | {
143 |     struct memstream *ms= (struct memstream *)cookie;			if (!ms->contents) { free(ms);  errno= ENOMEM;  return -1; }
144 |     ms->size= min(ms->size, ms->position);
145 |     *ms->ptr= ms->contents;
146 |     *ms->sizeloc= ms->size;						assert(ms->size < ms->capacity);
147 |     ms->contents[ms->size]= 0;
148 |     free(ms);
149 |     return 0;
150 | }
151 | 
152 | FILE *open_memstream(char **ptr, size_t *sizeloc)
153 | {
154 |     if (ptr && sizeloc) {
155 | 	struct memstream *ms= calloc(1, sizeof(struct memstream));
156 | 	FILE *fp= 0;							if (!ms) return 0;	/* errno == ENOMEM */
157 | 	ms->position= ms->size= 0;
158 | 	ms->capacity= 4096;
159 | 	ms->contents= calloc(ms->capacity, 1);				if (!ms->contents) { free(ms);  return 0; } /* errno == ENOMEM */
160 | 	ms->ptr= ptr;
161 | 	ms->sizeloc= sizeloc;
162 | 	memstream_print(ms);
163 | 	fp= funopen(ms, memstream_read, memstream_write, memstream_seek, memstream_close);
164 | 	if (!fp) {
165 | 	    free(ms->contents);
166 | 	    free(ms);
167 | 	    return 0;	/* errno set by funopen */
168 | 	}
169 | 	*ptr= ms->contents;
170 | 	*sizeloc= ms->size;
171 | 	return fp;
172 |     }
173 |     errno= EINVAL;
174 |     return 0;
175 | }
176 | 
177 | #endif /* _POSIX_C_SOURCE < 200809L */
178 | 


--------------------------------------------------------------------------------
/src/memstream.h:
--------------------------------------------------------------------------------
 1 | #if defined(__linux__)
 2 | # include <features.h>
 3 | #endif
 4 | 
 5 | #include <stdio.h>
 6 | 
 7 | #if _POSIX_C_SOURCE < 200809L
 8 | 
 9 | FILE *open_memstream(char **ptr, size_t *sizeloc);
10 | 
11 | #endif /* _POSIX_C_SOURCE < 200809L */
12 | 


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