import Data List import Network HTTP import Network URI data Object Ob

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
import Data.List
import Network.HTTP
import Network.URI
data Object = ObjectiById String
| ObjectByAbout String
type Credentials = Maybe (String, String)
username, password :: Credentials -> String
username Nothing = error "no username in empty credentials"
username (Just (u, _)) = u
password Nothing = error "no username in empty credentials"
password (Just (_, p)) = p
data FluidDB = FluidDB {
host :: String,
credentials :: Credentials
}
data TagValue = TagValue {
name :: String,
value :: Maybe String
}
type Tag = String
abs_tag_path :: Tag -> Tag
abs_tag_path "/about" = "/fluiddb/about"
abs_tag_path t =
if head t == '/'
then if "/tags/" `isPrefixOf` t
then drop 5 t
else t
else "/xa4a/" ++ t
full_tag_path :: Tag -> Tag
full_tag_path s =
if "/tags/" `isPrefixOf` s
then s
else "/tags/" ++ (abs_tag_path s)
callGET :: String -> String -> String -> IO (ResponseCode, String)
callGET path body hash = do
resp <- simpleHTTP req
case resp of
Right resp ->
return (rspCode resp, (try_unpack (rspHeaders resp) (rspBody resp)))
Left _ -> error "Something fucked up"
where
try_unpack headers body =
case lookupHeader HdrContentType headers of
Nothing -> body
Just s ->
if "application/json" `isPrefixOf` s then load_json body
else body
load_json = id
parseU u = case parseURI u of
Nothing -> error "parsing uri failed"
Just s -> s
req = Request { rqURI = parseU ("http://sandbox.fluidinfo.com" ++ path)
, rqMethod = GET
, rqBody = body
, rqHeaders =
[ Header HdrContentType "application/json"
, Header HdrAccept "application/json"
]
}
--getTagValue :: FluidDB -> Object -> Tag -> IO String
--getTagValue (ObjectById o_id) tag =
-- let full_path = "/objects/" ++ o_id ++ (abs_tag_path tag)