mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
Remove MonadWidget, tighten imports
This commit is contained in:
parent
da0bd01e5e
commit
51e6b971b0
@ -8,7 +8,8 @@ module Main where
|
||||
|
||||
import Data.Bool
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Control.Monad.Fix (MonadFix)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Servant.API
|
||||
@ -25,7 +26,12 @@ main :: IO ()
|
||||
main = mainWidget run
|
||||
|
||||
|
||||
run :: forall t m. MonadWidget t m => m ()
|
||||
run :: forall t m. (SupportsServantReflex t m,
|
||||
DomBuilder t m,
|
||||
DomBuilderSpace m ~ GhcjsDomSpace,
|
||||
MonadFix m,
|
||||
PostBuild t m,
|
||||
MonadHold t m) => m ()
|
||||
run = do
|
||||
|
||||
-- Allow user to choose the url target for the request
|
||||
@ -110,3 +116,6 @@ showRB (XhrResponseBody_Default t) = tShow t
|
||||
showRB (XhrResponseBody_Text t) = tShow t
|
||||
showRB (XhrResponseBody_Blob t) = "<Blob>"
|
||||
showRB (XhrResponseBody_ArrayBuffer t) = tShow t
|
||||
|
||||
note :: e -> Maybe a -> Either e a
|
||||
note e = maybe (Left e) Right
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -13,9 +14,14 @@ module Servant.Common.BaseUrl (
|
||||
-- * functions
|
||||
, baseUrlWidget
|
||||
, showBaseUrl
|
||||
|
||||
-- * constraints
|
||||
, SupportsServantReflex
|
||||
) where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Fix (MonadFix)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -24,6 +30,9 @@ import Reflex
|
||||
import Reflex.Dom
|
||||
import Text.Read
|
||||
|
||||
|
||||
type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))
|
||||
|
||||
-- | URI scheme to use
|
||||
data Scheme =
|
||||
Http -- ^ http://
|
||||
@ -58,7 +67,13 @@ showBaseUrl (BaseFullUrl urlscheme host port path) =
|
||||
(Https, 443) -> ""
|
||||
_ -> ":" <> T.pack (show port)
|
||||
|
||||
baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)
|
||||
baseUrlWidget :: forall t m .(SupportsServantReflex t m,
|
||||
DomBuilderSpace m ~ GhcjsDomSpace,
|
||||
MonadFix m,
|
||||
PostBuild t m,
|
||||
MonadHold t m,
|
||||
DomBuilder t m)
|
||||
=> m (Dynamic t BaseUrl)
|
||||
baseUrlWidget = elClass "div" "base-url" $ do
|
||||
urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def
|
||||
let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
|
||||
|
@ -9,20 +9,19 @@
|
||||
module Servant.Common.Req where
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
import Control.Applicative (liftA2, liftA3)
|
||||
import Control.Applicative (liftA2, liftA3)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Reflex
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Reflex.Dom
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.API.ContentTypes
|
||||
import Web.HttpApiData
|
||||
import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
|
||||
import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
|
||||
import Web.HttpApiData (ToHttpApiData(..))
|
||||
-------------------------------------------------------------------------------
|
||||
import Servant.API.BasicAuth
|
||||
|
||||
@ -90,14 +89,12 @@ displayHttpRequest :: Text -> Text
|
||||
displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
|
||||
|
||||
-- | This function actually performs the request.
|
||||
performRequest :: forall t m.MonadWidget t m
|
||||
performRequest :: forall t m.(SupportsServantReflex t m)
|
||||
=> Text
|
||||
-> Req t
|
||||
-> Dynamic t BaseUrl
|
||||
-> Event t ()
|
||||
-> m (Event t XhrResponse, Event t Text)
|
||||
-- -> ExceptT ServantError IO ( Int, ByteString, MediaType
|
||||
-- , [HTTP.Header], Response ByteString)
|
||||
performRequest reqMeth req reqHost trigger = do
|
||||
|
||||
let t :: Dynamic t [Either Text Text]
|
||||
@ -210,15 +207,18 @@ bytesToPayload :: BL.ByteString -> XhrPayload
|
||||
bytesToPayload = T.pack . BL.unpack
|
||||
#endif
|
||||
|
||||
performRequestNoBody ::
|
||||
forall t m .MonadWidget t m => Text -> Req t -> Dynamic t BaseUrl
|
||||
-> Event t () -> m (Event t (ReqResult NoContent))
|
||||
performRequestNoBody :: forall t m .(SupportsServantReflex t m)
|
||||
=> Text
|
||||
-> Req t
|
||||
-> Dynamic t BaseUrl
|
||||
-> Event t () -> m (Event t (ReqResult NoContent))
|
||||
performRequestNoBody reqMeth req reqHost trigger = do
|
||||
(resp, badReq) <- performRequest reqMeth req reqHost trigger
|
||||
return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
|
||||
|
||||
|
||||
performRequestCT :: (MonadWidget t m, MimeUnrender ct a)
|
||||
performRequestCT :: (SupportsServantReflex t m,
|
||||
MimeUnrender ct a)
|
||||
=> Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
|
||||
-> Event t () -> m (Event t (ReqResult a))
|
||||
performRequestCT ct reqMeth req reqHost trigger = do
|
||||
|
@ -23,22 +23,43 @@ module Servant.Reflex
|
||||
, module Servant.Common.BaseUrl
|
||||
) where
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
import Control.Applicative
|
||||
import Data.Monoid ((<>))
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.CaseInsensitive (mk)
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding
|
||||
import GHC.TypeLits
|
||||
import Servant.API
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.Req
|
||||
import Reflex
|
||||
import Reflex.Dom
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Servant.API ((:<|>)(..),(:>), BasicAuth,
|
||||
BasicAuthData, BuildHeadersTo(..),
|
||||
Capture, contentType, Header,
|
||||
Headers(..), HttpVersion, IsSecure,
|
||||
MimeRender(..), MimeUnrender,
|
||||
NoContent, QueryFlag, QueryParam,
|
||||
QueryParams, Raw, ReflectMethod(..),
|
||||
RemoteHost, ReqBody,
|
||||
ToHttpApiData(..), Vault, Verb)
|
||||
import Servant.Common.BaseUrl (BaseUrl, baseUrlWidget, showBaseUrl,
|
||||
SupportsServantReflex)
|
||||
import Servant.Common.Req (Req, ReqResult(..), QParam(..),
|
||||
QueryPart(..), addHeader, authData,
|
||||
defReq, prependToPathParts,
|
||||
performRequestCT,
|
||||
performRequestNoBody,
|
||||
qParamToQueryPart, reqBody,
|
||||
reqSuccess, reqFailure,
|
||||
reqMethod, respHeaders, response,
|
||||
qParams)
|
||||
import Reflex.Dom (Dynamic, Event, Reflex,
|
||||
XhrRequest(..),
|
||||
XhrResponseHeaders(..),
|
||||
XhrResponse(..), ffor, fmapMaybe,
|
||||
leftmost, performRequestAsync,
|
||||
tagPromptlyDyn )
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
@ -78,13 +99,13 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: MonadWidget t m
|
||||
-- > getBook :: SupportsServantReflex t m
|
||||
-- => Dynamic t BaseUrl
|
||||
-- -> Dynamic t (Maybe Text)
|
||||
-- -> Event t ()
|
||||
-- -> m (Event t (Either XhrError (Text, Book)))
|
||||
-- > getBook = client myApi (constDyn host)
|
||||
instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)
|
||||
instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)
|
||||
=> HasClient t m (Capture capture a :> sublayout) where
|
||||
|
||||
type Client t m (Capture capture a :> sublayout) =
|
||||
@ -101,7 +122,7 @@ instance (MonadWidget t m, ToHttpApiData a, HasClient t m sublayout)
|
||||
-- VERB (Returning content) --
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
-- Note [Non-Empty Content Types]
|
||||
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
|
||||
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
|
||||
) => HasClient t m (Verb method status cts' a) where
|
||||
type Client t m (Verb method status cts' a) =
|
||||
Event t () -> m (Event t (ReqResult a))
|
||||
@ -109,12 +130,12 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- ExceptT ServantError IO a
|
||||
clientWithRoute Proxy _ req baseurl =
|
||||
performRequestCT (Proxy :: Proxy ct) method req' baseurl
|
||||
where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
req' = req { reqMethod = method }
|
||||
|
||||
-- -- VERB (No content) --
|
||||
instance {-# OVERLAPPING #-}
|
||||
(ReflectMethod method, MonadWidget t m) =>
|
||||
(ReflectMethod method, SupportsServantReflex t m) =>
|
||||
HasClient t m (Verb method status cts NoContent) where
|
||||
type Client t m (Verb method status cts NoContent) =
|
||||
Event t () -> m (Event t (ReqResult NoContent))
|
||||
@ -122,7 +143,7 @@ instance {-# OVERLAPPING #-}
|
||||
-- ExceptT ServantError IO NoContent
|
||||
clientWithRoute Proxy _ req baseurl =
|
||||
performRequestNoBody method req baseurl
|
||||
where method = decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
|
||||
toHeaders r =
|
||||
@ -152,7 +173,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- Note [Non-Empty Content Types]
|
||||
( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
|
||||
ReflectMethod method, cts' ~ (ct ': cts),
|
||||
MonadWidget t m
|
||||
SupportsServantReflex t m
|
||||
) => HasClient t m (Verb method status cts' (Headers ls a)) where
|
||||
type Client t m (Verb method status cts' (Headers ls a)) =
|
||||
Event t () -> m (Event t (ReqResult (Headers ls a)))
|
||||
@ -167,7 +188,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- HEADERS Verb (No content) --
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
|
||||
MonadWidget t m
|
||||
SupportsServantReflex t m
|
||||
) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
|
||||
type Client t m (Verb method status cts (Headers ls NoContent))
|
||||
= Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
|
||||
@ -194,7 +215,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToHttpApiData a,
|
||||
HasClient t m sublayout, MonadWidget t m)
|
||||
HasClient t m sublayout, SupportsServantReflex t m)
|
||||
=> HasClient t m (Header sym a :> sublayout) where
|
||||
|
||||
type Client t m (Header sym a :> sublayout) =
|
||||
@ -346,7 +367,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
-- TODO redo
|
||||
instance (MonadWidget t m) => HasClient t m Raw where
|
||||
instance SupportsServantReflex t m => HasClient t m Raw where
|
||||
type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))
|
||||
-> Event t ()
|
||||
-> m (Event t (ReqResult ()))
|
||||
|
Loading…
Reference in New Issue
Block a user