32aceb6 · servant-reflex

git.iko.soy/servant-reflex

WIP converting to new-reflex-dom

Build broken at this point. BaseUrl is done, but Req not finished yet.

commit32aceb664f2f04af499d74490cc6358506e7d9d6 authorDoug Beardsley <mightybyte@gmail.com> dateMon 4 Jul 2016, 20:00 (10 years ago) parentf0ffaae

3 files changed+69−67

compare with master

unifiedsplit

servant-reflex.cabal+1−1 src/Servant/Common/BaseUrl.hs+13−14 src/Servant/Common/Req.hs+55−52

servant-reflex.cabal+1−1

@@ -25,7 +25,7 @@ library

2525 bytestring >= 0.10 && < 0.11,

2626 case-insensitive >= 1.2.0.4 && < 1.3,

2727 containers >= 0.5.6 && < 0.6,

28− data-default >= 0.5 && < 0.6,

28+ data-default >= 0.5 && < 0.7,

2929 exceptions >= 0.8 && < 0.9,

3030 ghcjs-dom >= 0.2 && < 0.3,

3131 http-api-data >= 0.2 && < 0.3,

src/Servant/Common/BaseUrl.hs+13−14

@@ -1,5 +1,8 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE OverloadedStrings #-}

36{-# LANGUAGE ViewPatterns #-}

47{-# LANGUAGE RankNTypes #-}

58{-# LANGUAGE ScopedTypeVariables #-}

@@ -12,15 +15,12 @@ module Servant.Common.BaseUrl (

1215 , showBaseUrl

1316) where

1417

15−import Control.Monad.Catch (Exception, MonadThrow, throwM)

16−import Data.List

1718import Data.Monoid

18−import Data.Typeable

19+import Data.Text (Text)

20+import qualified Data.Text as T

1921import GHC.Generics

20−import Network.URI hiding (path)

2122import Reflex

2223import Reflex.Dom

23−import Safe

2424import Text.Read

2525

2626-- | URI scheme to use

@@ -31,8 +31,8 @@ data Scheme =

3131

3232-- | Simple data type to represent the target of HTTP requests

3333-- for servant's automatically-generated clients.

34−data BaseUrl = BaseFullUrl Scheme String Int String

35− | BasePath String

34+data BaseUrl = BaseFullUrl Scheme Text Int Text

35+ | BasePath Text

3636 deriving (Ord, Read, Show, Generic)

3737

3838

@@ -40,23 +40,22 @@ instance Eq BaseUrl where

4040 BasePath s == BasePath s' = s == s'

4141 BaseFullUrl a b c path == BaseFullUrl a' b' c' path'

4242 = a == a' && b == b' && c == c' && s path == s path'

43− where s ('/':x) = x

44− s x = x

43+ where s x = if T.isPrefixOf "/" x then T.tail x else x

4544 _ == _ = False

4645

47−showBaseUrl :: BaseUrl -> String

46+showBaseUrl :: BaseUrl -> Text

4847showBaseUrl (BasePath s) = s

4948showBaseUrl (BaseFullUrl urlscheme host port path) =

50− schemeString ++ "//" ++ host ++ (portString </> path)

49+ schemeString <> "//" <> host <> (portString </> path)

5150 where

52− a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b

51+ a </> b = if "/" `T.isPrefixOf` b || T.null b then a <> b else a <> "/" <> b

5352 schemeString = case urlscheme of

5453 Http -> "http:"

5554 Https -> "https:"

5655 portString = case (urlscheme, port) of

5756 (Http, 80) -> ""

5857 (Https, 443) -> ""

59− _ -> ":" ++ show port

58+ _ -> ":" <> T.pack (show port)

6059

6160baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)

6261baseUrlWidget = elClass "div" "base-url" $ do

@@ -78,7 +77,7 @@ baseUrlWidget = elClass "div" "base-url" $ do

7877 srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}

7978 text ":"

8079 prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}

81− port :: Dynamic t Int <- holdDyn 80 (fmapMaybe readMaybe $ updated (value prt))

80+ port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))

8281 path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }

8382 BaseFullUrl `mapDyn` value schm `myApDyn` value srv `myApDyn` port `myApDyn` value path

8483

src/Servant/Common/Req.hs+55−52

@@ -1,5 +1,7 @@

11{-# LANGUAGE DeriveDataTypeable #-}

22{-# LANGUAGE CPP #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GADTs #-}

35{-# LANGUAGE OverloadedStrings #-}

46{-# LANGUAGE LambdaCase #-}

57{-# LANGUAGE ScopedTypeVariables #-}

@@ -7,12 +9,13 @@

79module Servant.Common.Req where

810

911import Control.Applicative (liftA2, liftA3)

10−import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)

1112import qualified Data.ByteString.Lazy.Char8 as BL

1213import Data.Maybe

14+import Data.Monoid

1315import qualified Data.Text.Encoding as TE

1416-- import qualified Data.Foldable as F

15−import qualified Data.List as L

17+import Data.Text (Text)

18+import qualified Data.Text as T

1619import Data.Proxy

1720import qualified Data.Map as Map

1821-- import Data.Monoid

@@ -41,14 +44,14 @@ import qualified Data.ByteString.Char8 as BS

4144import Web.HttpApiData

4245

4346data ReqResult a = ResponseSuccess a XhrResponse

44− | ResponseFailure String XhrResponse

45− | RequestFailure String

47+ | ResponseFailure Text XhrResponse

48+ | RequestFailure Text

4649

4750reqSuccess :: ReqResult a -> Maybe a

4851reqSuccess (ResponseSuccess x _) = Just x

4952reqSuccess _ = Nothing

5053

51−reqFailure :: ReqResult a -> Maybe String

54+reqFailure :: ReqResult a -> Maybe Text

5255reqFailure (ResponseFailure s _) = Just s

5356reqFailure (RequestFailure s) = Just s

5457reqFailure _ = Nothing

@@ -58,92 +61,92 @@ response (ResponseSuccess _ x) = Just x

5861response (ResponseFailure _ x) = Just x

5962response _ = Nothing

6063

61−data QueryPart t = QueryPartParam (Behavior t (Either String String))

62− | QueryPartParams (Behavior t [String])

64+data QueryPart t = QueryPartParam (Behavior t (Either Text Text))

65+ | QueryPartParams (Behavior t [Text])

6366 | QueryPartFlag (Behavior t Bool)

6467

6568data Req t = Req

66− { reqMethod :: String

67− , reqPathParts :: [Behavior t (Either String String)]

68− , qParams :: [(String, QueryPart t)]

69− , reqBody :: Maybe (Behavior t (Either String (BL.ByteString, String)))

69+ { reqMethod :: Text

70+ , reqPathParts :: [Behavior t (Either Text Text)]

71+ , qParams :: [(Text, QueryPart t)]

72+ , reqBody :: Maybe (Behavior t (Either Text (BL.ByteString, Text)))

7073 -- , reqAccept :: [MediaType] -- TODO ?

71− , headers :: [(String, Behavior t String)]

74+ , headers :: [(Text, Behavior t Text)]

7275 , authData :: Maybe (Behavior t (Maybe BasicAuthData))

7376 }

7477

7578defReq :: Reflex t => Req t

7679defReq = Req "GET" [] [] Nothing [] Nothing

7780

78−prependToPathParts :: Reflex t => Behavior t (Either String String) -> Req t -> Req t

81+prependToPathParts :: Reflex t => Behavior t (Either Text Text) -> Req t -> Req t

7982prependToPathParts p req =

8083 req { reqPathParts = p : reqPathParts req }

8184

82−addHeader :: (ToHttpApiData a, Reflex t) => String -> Behavior t (Either String a) -> Req t -> Req t

85+addHeader :: (ToHttpApiData a, Reflex t) => Text -> Behavior t (Either Text a) -> Req t -> Req t

8386addHeader name val req = req { headers = headers req

84− ++ [(name, fmap (unpack . toHeader) val)]

85−-- ++ [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]

87+ <> [(name, fmap (toHeader) val)]

88+-- <> [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]

8689 }

8790

8891-- * performing requests

8992

90−displayHttpRequest :: String -> String

91−displayHttpRequest httpmethod = "HTTP " ++ httpmethod ++ " request"

93+displayHttpRequest :: Text -> Text

94+displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

9295

9396-- | This function actually performs the request.

9497performRequest :: forall t m.MonadWidget t m

95− => String

98+ => Text

9699 -> Req t

97100 -> Dynamic t BaseUrl

98101 -> Event t ()

99− -> m (Event t XhrResponse, Event t String)

102+ -> m (Event t XhrResponse, Event t Text)

100103 -- -> ExceptT ServantError IO ( Int, ByteString, MediaType

101104 -- , [HTTP.Header], Response ByteString)

102105performRequest reqMethod req reqHost trigger = do

103106

104107 -- Ridiculous functor-juggling! How to clean this up?

105− let t :: Behavior t [Either String String]

106− t = sequence $ L.reverse $ reqPathParts req

108+ let t :: Behavior t [Either Text Text]

109+ t = sequence $ reverse $ reqPathParts req

107110

108− baseUrl :: Behavior t (Either String String)

111+ baseUrl :: Behavior t (Either Text Text)

109112 baseUrl = Right . showBaseUrl <$> current reqHost

110113

111− urlParts :: Behavior t (Either String [String])

114+ urlParts :: Behavior t (Either Text [Text])

112115 urlParts = fmap sequence t

113116

114− urlPath :: Behavior t (Either String String)

115− urlPath = (fmap.fmap) (L.intercalate "/") urlParts

117+ urlPath :: Behavior t (Either Text Text)

118+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts

116119

117− queryPartString :: (String, QueryPart t) -> Behavior t (Maybe (Either String String))

120+ queryPartString :: (Text, QueryPart t) -> Behavior t (Maybe (Either Text Text))

118121 queryPartString (pName, qp) = case qp of

119122 QueryPartParam p -> ffor p $ \case

120123 Left e -> Just (Left e)

121− Right a -> Just (Right $ pName ++ "=" ++ a)

124+ Right a -> Just (Right $ pName <> "=" <> a)

122125 QueryPartParams ps -> ffor ps $ \pStrings ->

123126 if null pStrings

124127 then Nothing

125− else Just $ Right (L.intercalate "&" (fmap (\p -> pName ++ '=' : p) pStrings))

128+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))

126129 QueryPartFlag fl -> ffor fl $ \case

127130 True -> Just $ Right pName

128131 False -> Nothing

129132

130133

131− queryPartStrings :: [Behavior t (Maybe (Either String String))]

134+ queryPartStrings :: [Behavior t (Maybe (Either Text Text))]

132135 queryPartStrings = map queryPartString (qParams req)

133− queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Behavior t (Either String [String])

134− queryString :: Behavior t (Either String String) =

135− ffor queryPartStrings' $ \qs -> fmap (L.intercalate "&") qs

136−-- ffor queryPartStrings' $ \qs -> fmap (L.intercalate "&") (sequence qs)

137− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if null q then p else p ++ '?' : q) baseUrl urlPath queryString

136+ queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Behavior t (Either Text [Text])

137+ queryString :: Behavior t (Either Text Text) =

138+ ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

139+-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)

140+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if null q then p else p <> "?" <> q) baseUrl urlPath queryString

138141 where

139− (</>) :: String -> String -> String

140− x </> y | ("/" `L.isSuffixOf` x) || ("/" `L.isPrefixOf` y) = x ++ y

141− | otherwise = x ++ '/':y

142+ (</>) :: Text -> Text -> Text

143+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

144+ | otherwise = x <> "/" <> y

142145

143− xhrHeaders :: Behavior t [(String, String)]

146+ xhrHeaders :: Behavior t [(Text, Text)]

144147 xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal

145148

146− mkConfigBody :: [(String,String)] -> (Either String (BL.ByteString, String)) -> Either String XhrRequestConfig

149+ mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig x)

147150 mkConfigBody hs rb = case rb of

148151 Left e -> Left e

149152 (Right (bBytes, bCT)) ->

@@ -151,19 +154,19 @@ performRequest reqMethod req reqHost trigger = do

151154 , _xhrRequestConfig_headers =

152155 Map.insert "Content-Type" bCT (_xhrRequestConfig_headers def)}

153156

154− xhrOpts :: Behavior t (Either String XhrRequestConfig)

157+ xhrOpts :: Behavior t (Either Text (XhrRequestConfig x))

155158 xhrOpts = case reqBody req of

156159 Nothing -> fmap (\h -> Right $ def { _xhrRequestConfig_headers = Map.fromList h }) xhrHeaders

157160 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

158161

159− mkAuth :: Maybe BasicAuthData -> Either String XhrRequestConfig -> Either String XhrRequestConfig

162+ mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)

160163 mkAuth _ (Left e) = Left e

161164 mkAuth Nothing r = r

162165 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

163166 { _xhrRequestConfig_user = Just $ BS.unpack u

164167 , _xhrRequestConfig_password = Just $ BS.unpack p}

165168

166− addAuth :: Behavior t (Either String XhrRequestConfig) -> Behavior t (Either String XhrRequestConfig)

169+ addAuth :: Behavior t (Either Text (XhrRequestConfig x)) -> Behavior t (Either Text (XhrRequestConfig x))

167170 addAuth xhr = case authData req of

168171 Nothing -> xhr

169172 Just auth -> liftA2 mkAuth auth xhr

@@ -179,8 +182,8 @@ performRequest reqMethod req reqHost trigger = do

179182

180183 -- let oneNamedPair :: String -> [QueryPart] -> String

181184 -- oneNamedPair pName ps =

182− -- L.intercalate "&" $ ffor ps $ \case

183− -- QueryPartParam pval -> pName ++ "=" ++ pval

185+ -- T.intercalate "&" $ ffor ps $ \case

186+ -- QueryPartParam pval -> pName <> "=" <> pval

184187 -- QueryPartFlag True -> pName

185188 -- QueryPartFlag False -> error "Impossible case"

186189

@@ -189,15 +192,15 @@ performRequest reqMethod req reqHost trigger = do

189192 -- (qParams req)

190193

191194 -- queryString :: Behavior t String

192− -- queryString = fmap (L.intercalate "&") (sequence t')

195+ -- queryString = fmap (T.intercalate "&") (sequence t')

193196

194− -- xhrUrl = (liftA2 . liftA2) (\u q -> u ++ '?' : q) urlPath (fmap Just queryString)

197+ -- xhrUrl = (liftA2 . liftA2) (\u q -> u <> '?' : q) urlPath (fmap Just queryString)

195198

196199-- TODO implement

197200-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]

198201 -- TODO Proxy probably not needed

199202performRequestNoBody ::

200− forall t m .MonadWidget t m => String -> Req t -> Dynamic t BaseUrl

203+ forall t m .MonadWidget t m => Text -> Req t -> Dynamic t BaseUrl

201204-- -> Event t () -> m (Event t (Maybe NoContent, XhrResponse))

202205 -> Event t () -> m (Event t (ReqResult NoContent))

203206performRequestNoBody reqMethod req reqHost trigger = do

@@ -206,7 +209,7 @@ performRequestNoBody reqMethod req reqHost trigger = do

206209 -- return hdrs

207210

208211performRequestCT :: (MonadWidget t m, MimeUnrender ct a)

209− => Proxy ct -> String -> Req t -> Dynamic t BaseUrl

212+ => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl

210213 -> Event t () -> m (Event t (ReqResult a))

211214performRequestCT ct reqMethod req reqHost trigger = do

212215 (resp, badReq) <- performRequest reqMethod req reqHost trigger

@@ -282,16 +285,16 @@ note e = maybe (Left e) Right

282285-- , uriAuthority = Just $

283286-- URIAuth { uriUserInfo = ""

284287-- , uriRegName = reqHost

285−-- , uriPort = ":" ++ show reqPort

288+-- , uriPort = ":" <> show reqPort

286289-- }

287−-- , uriPath = path ++ reqPath req

290+-- , uriPath = path <> reqPath req

288291-- }

289292

290293-- setrqb r = case reqBody req of

291294-- Nothing -> r

292295-- Just (b,t) -> r { requestBody = RequestBodyLBS b

293296-- , requestHeaders = requestHeaders r

294−-- ++ [(hContentType, cs . show $ t)] }

297+-- <> [(hContentType, cs . show $ t)] }

295298-- setQS = setQueryString $ queryTextToQuery (qs req)

296299-- setheaders r = r { requestHeaders = requestHeaders r

297300-- <> fmap toProperHeader (headers req) }