|
| 1 | +{-# LANGUAGE TypeFamilies #-} |
| 2 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 3 | +{-# LANGUAGE FlexibleInstances #-} |
| 4 | +{-# LANGUAGE ExistentialQuantification #-} |
| 5 | +{-# LANGUAGE FunctionalDependencies #-} |
| 6 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 7 | +{-# LANGUAGE GADTs #-} |
| 8 | +{-# LANGUAGE DataKinds #-} |
| 9 | +{-# LANGUAGE TypeOperators #-} |
| 10 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 11 | +{-# LANGUAGE RankNTypes #-} |
| 12 | +{-# LANGUAGE TypeInType #-} |
| 13 | +{-# LANGUAGE TypeApplications #-} |
| 14 | +{-# LANGUAGE LambdaCase #-} |
| 15 | +{-# LANGUAGE OverloadedStrings #-} |
| 16 | +{-# LANGUAGE DeriveGeneric #-} |
| 17 | +{-# LANGUAGE DefaultSignatures #-} |
| 18 | +{-# LANGUAGE FlexibleContexts #-} |
| 19 | +{-# LANGUAGE UndecidableInstances #-} |
| 20 | +module Solga.Client |
| 21 | + ( Client(..) |
| 22 | + , SomeRequestData(..) |
| 23 | + , choose |
| 24 | + , RawRequest(..) |
| 25 | + , ToSegment(..) |
| 26 | + , WithData(..) |
| 27 | + , GetResponse(..) |
| 28 | + ) where |
| 29 | + |
| 30 | +import Data.Kind |
| 31 | +import Data.Proxy |
| 32 | +import qualified Data.Aeson as Aeson |
| 33 | +import qualified Network.HTTP.Client as Http |
| 34 | +import qualified Network.HTTP.Client.MultipartFormData as Http |
| 35 | +import GHC.Generics |
| 36 | +import qualified Data.ByteString.Char8 as BSC8 |
| 37 | +import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) |
| 38 | +import Data.ByteString (ByteString) |
| 39 | +import qualified Data.ByteString as BS |
| 40 | +import Data.Monoid ((<>)) |
| 41 | +import qualified Data.Text.Encoding as T |
| 42 | +import Data.Text (Text) |
| 43 | +import Network.HTTP.Types (urlEncodeBuilder) |
| 44 | +import qualified Blaze.ByteString.Builder as Blaze |
| 45 | +import qualified Data.ByteString.Lazy as BSL |
| 46 | +import qualified Data.Text as T |
| 47 | + |
| 48 | +import Solga.Core |
| 49 | + |
| 50 | +data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) |
| 51 | + |
| 52 | +class Client r where |
| 53 | + type RequestData r :: * -> * |
| 54 | + type RequestData r = SomeRequestData r |
| 55 | + performRequest :: proxy r -> Http.Request -> Http.Manager -> RequestData r a -> IO a |
| 56 | + default |
| 57 | + performRequest :: forall (proxy :: * -> *) a. |
| 58 | + (RequestData r ~ SomeRequestData r) |
| 59 | + => proxy r -> Http.Request -> Http.Manager -> RequestData r a -> IO a |
| 60 | + performRequest _p req mgr (SomeRequestData p perf) = performRequest p req mgr perf |
| 61 | + |
| 62 | +choose :: forall in_ out a. |
| 63 | + (Client in_, RequestData out ~ SomeRequestData out) |
| 64 | + => (out -> in_) -> RequestData in_ a -> RequestData out a |
| 65 | +choose _f perf = SomeRequestData (Proxy @in_) perf |
| 66 | + |
| 67 | +newtype RawRequest a = RawRequest {unRequestDataRaw :: Http.Request -> Http.Manager -> IO a} |
| 68 | + |
| 69 | +instance Client (Raw a) where |
| 70 | + type RequestData (Raw a) = RawRequest |
| 71 | + performRequest _p mgr req (RawRequest f) = f mgr req |
| 72 | + |
| 73 | +instance Client (RawResponse a) where |
| 74 | + type RequestData (RawResponse a) = RawRequest |
| 75 | + performRequest _p mgr req (RawRequest f) = f mgr req |
| 76 | + |
| 77 | +instance (Client next) => Client (End next) where |
| 78 | + type RequestData (End next) = RequestData next |
| 79 | + performRequest _p mgr req perf = performRequest (Proxy @next) mgr req perf |
| 80 | + |
| 81 | +addSegment :: Http.Request -> Text -> Http.Request |
| 82 | +addSegment req segtxt = req |
| 83 | + { Http.path = if BS.null (Http.path req) || BSC8.last (Http.path req) == '/' |
| 84 | + then Http.path req <> seg |
| 85 | + else Http.path req <> "/" <> seg |
| 86 | + } |
| 87 | + where |
| 88 | + seg = BSL.toStrict (Blaze.toLazyByteString (urlEncodeBuilder False (T.encodeUtf8 segtxt))) |
| 89 | + |
| 90 | +instance (Client next, KnownSymbol seg) => Client (Seg seg next) where |
| 91 | + type RequestData (Seg seg next) = RequestData next |
| 92 | + performRequest _p req mgr perf = |
| 93 | + performRequest (Proxy @next) (addSegment req (T.pack (symbolVal (Proxy @seg)))) mgr perf |
| 94 | + |
| 95 | +instance (Client left, Client right) => Client (left :<|> right) where |
| 96 | + type RequestData (left :<|> right) = RequestData left :+: RequestData right |
| 97 | + performRequest _p mgr req = \case |
| 98 | + L1 perf -> performRequest (Proxy @left) mgr req perf |
| 99 | + R1 perf -> performRequest (Proxy @right) mgr req perf |
| 100 | + |
| 101 | +data WhichSeg (segs :: [Symbol]) where |
| 102 | + ThisSeg :: KnownSymbol seg => WhichSeg (seg ': segs) |
| 103 | + ThatSeg :: WhichSeg segs -> WhichSeg (seg ': segs) |
| 104 | + |
| 105 | +thisSeg :: forall seg segs. KnownSymbol seg => WhichSeg (seg ': segs) -> String |
| 106 | +thisSeg _ = symbolVal (Proxy @seg) |
| 107 | + |
| 108 | +whichSeg :: WhichSeg segs -> String |
| 109 | +whichSeg ts@ThisSeg = thisSeg ts |
| 110 | +whichSeg (ThatSeg ws) = whichSeg ws |
| 111 | + |
| 112 | +instance (Client next) => Client (OneOfSegs segs next) where |
| 113 | + type RequestData (OneOfSegs segs next) = WithData (WhichSeg segs) (RequestData next) |
| 114 | + performRequest _p req mgr (WithData ws perf) = |
| 115 | + performRequest (Proxy @next) (addSegment req (T.pack (whichSeg ws))) mgr perf |
| 116 | + |
| 117 | +class ToSegment a where |
| 118 | + toSegment :: a -> Text |
| 119 | + |
| 120 | +instance ToSegment Text where |
| 121 | + toSegment = id |
| 122 | + |
| 123 | +data WithData a next b = WithData |
| 124 | + { ardData :: a |
| 125 | + , ardNext :: next b |
| 126 | + } |
| 127 | + |
| 128 | +instance (Client next, ToSegment a) => Client (Capture a next) where |
| 129 | + type RequestData (Capture a next) = WithData a (RequestData next) |
| 130 | + performRequest _p req mgr (WithData x perf) = |
| 131 | + performRequest (Proxy @next) (addSegment req (toSegment x)) mgr perf |
| 132 | + |
| 133 | +instance (Client next, KnownSymbol method) => Client (Method method next) where |
| 134 | + type RequestData (Method seg next) = RequestData next |
| 135 | + performRequest _p req mgr perf = performRequest |
| 136 | + (Proxy @next) req{Http.method = BSC8.pack (symbolVal (Proxy @method))} mgr perf |
| 137 | + |
| 138 | +newtype GetResponse resp a b = GetResponse {unGetResponse :: Http.Response resp -> a -> IO b} |
| 139 | + |
| 140 | +instance (Aeson.FromJSON a) => Client (JSON a) where |
| 141 | + -- note that we do not decode eagerly because it's often the case that the body |
| 142 | + -- cannot be decoded since web servers return invalid json on errors |
| 143 | + -- (e.g. "Internal server error" on a 500 rather than a json encoded error) |
| 144 | + type RequestData (JSON a) = GetResponse BSL.ByteString (Either String a) |
| 145 | + performRequest _p req mgr (GetResponse f) = do |
| 146 | + resp <- Http.httpLbs req mgr |
| 147 | + let decode = Aeson.eitherDecode' (Http.responseBody resp) |
| 148 | + f resp decode |
| 149 | + |
| 150 | +instance (Client next) => Client (ExtraHeaders next) where |
| 151 | + type RequestData (ExtraHeaders next) = RequestData next |
| 152 | + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf |
| 153 | + |
| 154 | +instance (Client next) => Client (NoCache next) where |
| 155 | + type RequestData (NoCache next) = RequestData next |
| 156 | + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf |
| 157 | + |
| 158 | +instance (Client next, Aeson.ToJSON a) => Client (ReqBodyJSON a next) where |
| 159 | + type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) |
| 160 | + performRequest _p req mgr (WithData x perf) = performRequest |
| 161 | + (Proxy @next) req{Http.requestBody = Http.RequestBodyLBS (Aeson.encode x)} mgr perf |
| 162 | + |
| 163 | +instance (Client next) => Client (WithIO next) where |
| 164 | + type RequestData (WithIO next) = RequestData next |
| 165 | + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf |
| 166 | + |
| 167 | +instance (Client next) => Client (ReqBodyMultipart fp a next) where |
| 168 | + type |
| 169 | + RequestData (ReqBodyMultipart fp a next) = |
| 170 | + WithData ([Http.Part], Maybe ByteString) (RequestData next) |
| 171 | + performRequest _p req mgr (WithData (parts, mbBoundary) perf) = do |
| 172 | + req' <- case mbBoundary of |
| 173 | + Nothing -> Http.formDataBody parts req |
| 174 | + Just x -> Http.formDataBodyWithBoundary x parts req |
| 175 | + performRequest (Proxy @next) req' mgr perf |
| 176 | + |
0 commit comments