0 | module Pact.Client.Core
 1 |
 2 | import Pact.API.Component
 3 | import Pact.API
 4 |
 5 | import Data.Vect
 6 | import Data.Vect.Quantifiers
 7 |
 8 | import Control.Monad.Either
 9 |
10 |
11 | import Network.HTTP
12 | import Utils.String
13 | import public Network.HTTP.URL
14 | import Data.Either
15 | import Pact.API.Verb
16 | import Pact.API.MimeRender
17 |
18 | %hide  Utils.Streaming.infixl.(:>)
19 |
20 | public export
21 | Result : Type -> Type
22 | Result a = EitherT String IO a
23 |
24 | map_error : Functor m => (e -> e') -> EitherT e m a -> EitherT e' m a
25 | map_error f = bimapEitherT f id
26 |
27 |
28 | with_client : {e : _} -> IO (HttpClient e) -> (HttpClient e -> EitherT (HttpError e) IO a) -> EitherT (HttpError e) IO a
29 | with_client client f = MkEitherT $ do
30 |   c <- client
31 |   Right ok <- runEitherT (f c)
32 |   | Left err => close c *> pure (Left err)
33 |   close c
34 |   pure (Right ok)
35 |
36 | export
37 | get : (url : URL) -> Result String
38 | get url = map_error show $ with_client {e=()} new_client_default $ \client => do
39 |   (response, content) <- request client GET url [] ()
40 |   content <- toList_ content
41 |   case utf8_pack content of
42 |     Nothing => pure "Failed to decode content"
43 |     Just content => pure content
44 |
45 | export
46 | getPath : (path: String) -> (accept: Type) -> (t: Type) -> {auto prf: MimeUnrender accept t} -> Result t
47 | getPath p accept resType {prf} = do
48 |   url' <- pure $ "http://localhost:2222" ++ p
49 |   url <- MkEitherT . pure . url_from_string $ url'
50 |   content <- get url
51 |   case mimeUnrender {ctype = accept} {a = resType} content of
52 |     Left err => throwE err
53 |     Right res => pure res
54 |
55 | public export
56 | GetGenerateLinkFunType : Component _ _ _ -> Type -> Type
57 | GetGenerateLinkFunType (StaticPath path) resType = Result resType
58 | GetGenerateLinkFunType (Capture name ty) resType = ty -> Result resType
59 | GetGenerateLinkFunType (ReqBody _) resType = Result resType
60 | GetGenerateLinkFunType (StaticPath path :/ rest) resType = GetGenerateLinkFunType rest resType
61 | GetGenerateLinkFunType (Capture name ty :/ rest) resType = ty -> GetGenerateLinkFunType rest resType
62 | GetGenerateLinkFunType (ReqBody _ :/ rest) resType = GetGenerateLinkFunType rest resType
63 |
64 | public export
65 | GetGenerateLinkByAPI : API -> Type
66 | GetGenerateLinkByAPI (path :> verb) = GetGenerateLinkFunType path (VerbResponse verb)
67 |
68 | generateLink : (comp: Component t ts r) -> {auto allprf : All ToHttpApiData ts} -> (acc: String) -> (accept: Type) -> (resType: Type) -> {auto prf: MimeUnrender accept resType} -> GetGenerateLinkFunType comp resType
69 | generateLink (StaticPath path) acc accept resType = getPath "\{acc}/\{path}" accept resType
70 | generateLink (Capture name ty) {allprf = prf :: restPrf} acc accept resType = (\x: ty => getPath "\{acc}/\{toUrlPiece x}" accept resType)
71 | generateLink (ReqBody _) acc accept resType = getPath acc accept resType
72 | generateLink (StaticPath path :/ rest) {allprf = prf :: restPrf} acc accept resType = generateLink rest  "\{acc}/\{path}" accept resType
73 | generateLink (Capture name ty :/ rest) {allprf = prf :: restPrf} acc accept resType = (\x: ty => generateLink rest "\{acc}/\{toUrlPiece x}" accept resType)
74 | generateLink (ReqBody _ :/ _) acc accept resType = assert_total $ idris_crash "ReqBody is not supported"
75 |
76 | public export
77 | generateLinkByAPI : (api: API) -> {allprf : All ToHttpApiData api.types} -> {verbPrf: MimeUnrender (VerbAccept api.verb) (VerbResponse api.verb)} -> GetGenerateLinkByAPI api
78 | generateLinkByAPI (path :> verb) = generateLink path "" (VerbAccept verb) (VerbResponse verb)
79 |
80 |