master...629fbac · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on 629fbac help sign in

servant-reflex.cabal+11−1

since splitsnapshots

unifiedsplit

@@ -22,11 +22,14 @@ library

23 other-modules:

24 Servant.Common.BaseUrl

25+ Servant.Common.MimeUnrender

25 Servant.Common.Req

26 Servant.Common.Req

27 hs-source-dirs: src

28 hs-source-dirs: src

28 build-depends:

29 build-depends:

29 base >= 4.8 && < 4.10,

30 base >= 4.8 && < 4.10,

31+ aeson >= 0.11.2 && < 0.12,

32+ attoparsec >= 0.13 && < 0.14,

30 bytestring >= 0.10 && < 0.11,

33 bytestring >= 0.10 && < 0.11,

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

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

32 containers >= 0.5.6 && < 0.6,

35 containers >= 0.5.6 && < 0.6,

@@ -40,11 +43,18 @@ library

40 reflex >= 0.5 && < 0.6,

43 reflex >= 0.5 && < 0.6,

41 reflex-dom == 0.4 && < 0.5,

44 reflex-dom == 0.4 && < 0.5,

42 safe >= 0.3.9 && < 0.4,

45 safe >= 0.3.9 && < 0.4,

43− servant >= 0.8 && < 0.11,

46+ servant >= 0.7 && < 0.11,

44 string-conversions >= 0.4 && < 0.5,

47 string-conversions >= 0.4 && < 0.5,

45 text >= 1.2 && < 1.3,

48 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

49 transformers >= 0.4 && < 0.6

51+ if impl(ghcjs)

52+ build-depends:

53+ ghcjs-base >= 0.2 && < 0.3,

54+ scientific >= 0.3 && < 0.4,

55+ unordered-containers >= 0.2 && < 0.3,

56+ vector >= 0.11 && < 0.13

57+

48 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

58 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

50 default-language: Haskell2010

60 default-language: Haskell2010

src/Servant/Common/Req.hs+218−38

@@ -1,38 +1,88 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+#ifdef ghcjs_HOST_OS

16+{-# LANGUAGE JavaScriptFFI #-}

17+#endif

10module Servant.Common.Req where

19module Servant.Common.Req where

12-------------------------------------------------------------------------------

21-------------------------------------------------------------------------------

13import Control.Concurrent

22import Control.Concurrent

14import Control.Applicative (liftA2, liftA3)

23import Control.Applicative (liftA2, liftA3)

24+import Control.Arrow (left)

15import Control.Monad (join)

25import Control.Monad (join)

16import Control.Monad.IO.Class (MonadIO, liftIO)

26import Control.Monad.IO.Class (MonadIO, liftIO)

27+import Data.Aeson

28+import qualified Data.Aeson as Aeson

29+import Data.Aeson.Types

30+import qualified Data.Aeson.Parser

17import Data.Bifunctor (first)

31import Data.Bifunctor (first)

32+import qualified Data.ByteString.Char8 as BS

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

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

19import qualified Data.Map as Map

34import qualified Data.Map as Map

20−import Data.Maybe (catMaybes, fromMaybe)

35+import Data.Maybe (catMaybes, fromMaybe, isJust)

21import Data.Functor.Compose

36import Data.Functor.Compose

22import Data.Monoid ((<>))

37import Data.Monoid ((<>))

23import Data.Proxy (Proxy(..))

38import Data.Proxy (Proxy(..))

24import Data.Text (Text)

39import Data.Text (Text)

25import qualified Data.Text as T

40import qualified Data.Text as T

26import qualified Data.Text.Encoding as TE

41import qualified Data.Text.Encoding as TE

42+import qualified Data.Text.Lazy as TextL

43+import qualified Data.Text.Lazy.Encoding as TextL

27import Data.Traversable (forM)

44import Data.Traversable (forM)

45+import Data.Typeable

46+import qualified Network.HTTP.Media.MediaType as M

47+import qualified Network.HTTP.Media as M

28import Reflex.Dom hiding (tag)

48import Reflex.Dom hiding (tag)

29import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

49import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

30 SupportsServantReflex)

50 SupportsServantReflex)

31−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

51+import Servant.API.ContentTypes (Accept, AcceptHeader(..), AllMime(..), JSON, -- MimeUnrender(..),

52+ PlainText,

53+ NoContent(..),

54+ OctetStream, contentType)

32import Web.HttpApiData (ToHttpApiData(..))

55import Web.HttpApiData (ToHttpApiData(..))

33-------------------------------------------------------------------------------

56-------------------------------------------------------------------------------

34import Servant.API.BasicAuth

57import Servant.API.BasicAuth

59+import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,

60+ skipSpace, (<?>))

61+import Data.String.Conversions (cs)

62+

63+#ifdef ghcjs_HOST_OS

64+import Control.Exception

65+import Control.Monad (liftM)

66+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

67+import qualified Data.JSString.Text as T

68+import qualified Data.Aeson as A

69+import qualified Data.HashMap.Strict as H

70+import qualified Data.Text.Internal as T

71+import qualified Data.Vector as V

72+import System.IO.Unsafe (unsafePerformIO)

73+import GHCJS.Buffer (create, fromByteString, getArrayBuffer)

74+import GHCJS.Types (JSVal, jsval)

75+import GHCJS.Marshal (FromJSVal(..), fromJSVal)

76+import GHCJS.Marshal.Pure (pToJSVal)

77+import qualified JavaScript.Object.Internal as OI

78+import Data.Scientific (Scientific, scientific, fromFloatDigits)

79+import GHCJS.Types

80+import GHCJS.Marshal

81+import GHCJS.Marshal.Pure

82+import GHCJS.Foreign.Internal

83+import GHCJS.Marshal.Internal

84+#endif

85+

37------------------------------------------------------------------------------

87------------------------------------------------------------------------------

38-- | The result of a request event

88-- | The result of a request event

@@ -311,40 +361,6 @@ bytesToPayload :: BL.ByteString -> XhrPayload

311bytesToPayload = TE.decodeUtf8 . BL.toStrict

361bytesToPayload = TE.decodeUtf8 . BL.toStrict

312

362

313

363

314−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

315−-- => Text

316−-- -> Req t

317−-- -> Dynamic t BaseUrl

318−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))

319−-- performRequestNoBody reqMeth req reqHost trigger = do

320−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

321−-- let decodeResp = const $ Right NoContent

322−-- return $ leftmost [ fmap (evalResponse decodeResp) resp

323−-- , fmap (uncurry RequestFailure) badReq

324−-- ]

325−

326−

327−-- performRequestCT

328−-- :: (SupportsServantReflex t m,

329−-- MimeUnrender ct a)

330−-- => Proxy ct

331−-- -> Text

332−-- -> Req t

333−-- -> Dynamic t BaseUrl

334−-- -> Event t tag

335−-- -> m (Event t (ReqResult tag a))

336−-- performRequestCT ct reqMeth req reqHost trigger = do

337−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

338−-- let decodeResp x = first T.pack .

339−-- mimeUnrender ct .

340−-- BL.fromStrict .

341−-- TE.encodeUtf8 =<< note "No body text"

342−-- (_xhrResponse_responseText x)

343−

344−-- return $ leftmost [fmap (evalResponse decodeResp) resp

345−-- , fmap (uncurry RequestFailure) badReq

346−-- ]

347−

348

364

349performRequestsCT

365performRequestsCT

350 :: (SupportsServantReflex t m,

366 :: (SupportsServantReflex t m,

@@ -369,6 +385,75 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do

369 )

385 )

370 resps

386 resps

371

387

388+-- mimeUnrender' :: (MimeUnrender ct a, Typeable ct) => Proxy ct -> BS.ByteString -> Either String a

389+-- mimeUnrender' p bs

390+-- -- | cantRawJson = mimeUnrender p (BL.fromStrict bs)

391+-- | otherwise = note "Raw JSON decode failure" $ rawDecode bs

392+-- where

393+-- cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p

394+

395+-- copied from http://lpaste.net/6122658287709061120

396+#ifdef ghcjs_HOST_OS

397+foreign import javascript safe "new DataView($3,$1,$2)"

398+ js_dataView :: Int -> Int -> JSVal -> JSVal

399+

400+foreign import javascript unsafe "console.log($1); $r = JSON['parse']($1);"

401+ js_jsonParse :: JSVal -> JSVal

402+

403+rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a

404+rawDecode bs = do

405+ -- Below copied from Reflex.Dom.WebSocket.Foreign

406+ -- tmp <- Just $ unsafePerformIO $ putStrLn ("bs: " ++ BS.unpack bs)

407+ -- error ("bs: " ++ BS.unpack bs)

408+ let (b, off, len) = fromByteString bs

409+ -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _

410+ -- tmp <- error (BS.unpack bs)

411+ let jsv = if BS.length bs == 0

412+ then error "ZERO!!" -- unsafePerformIO $ jsval . getArrayBuffer <$> create 0

413+ else js_dataView off len $ jsval $ getArrayBuffer b

414+

415+ -- let jsv = _ bs

416+ -- TODO pFromJSVal to avoid unsafePerformIO

417+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse jsv

418+ case res of

419+ Left (_e :: SomeException) -> Nothing

420+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v

421+ where

422+ go v = case Aeson.fromJSON v of

423+ Aeson.Success a -> Just a

424+ _ -> Nothing

425+

426+

427+-- copied from http://lpaste.net/raw/353535 Thanks ncl28!

428+aesonFromJSVal :: JSVal -> IO (Maybe A.Value)

429+aesonFromJSVal r = do

430+ putStrLn "Hello"

431+ print $ jsonTypeOf r

432+ case jsonTypeOf r of

433+ JSONNull -> return (Just A.Null)

434+ JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))

435+ <$> fromJSVal r

436+ JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))

437+ <$> fromJSVal r

438+ JSONBool -> liftM A.Bool <$> fromJSVal r

439+ JSONString -> liftM (A.String . ("TEST" <>)) <$> fromJSVal r

440+ -- JSONArray -> liftM (A.Array . V.fromList) <$> (fromJSVal r :: _)

441+ JSONArray -> liftM (A.Array . V.fromList) <$>

442+ runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<

443+ (MaybeT (fromJSVal r)))

444+ JSONObject -> do

445+ props <- OI.listProps (OI.Object r)

446+ runMaybeT $ do

447+ propVals <- forM props $ \p -> do

448+ v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))

449+ return (T.textFromJSString p, v)

450+ return (A.Object (H.fromList propVals <> H.fromList [("extratest", A.Null)]))

451+{-# INLINE aesonFromJSVal #-}

452+

453+#else

454+rawDecode :: FromJSON a => BS.ByteString -> Maybe a

455+rawDecode = decode . BL.fromStrict

456+#endif

372

457

373performRequestsNoBody

458performRequestsNoBody

374 :: (SupportsServantReflex t m,

459 :: (SupportsServantReflex t m,

@@ -391,7 +476,7 @@ evalResponse

391 :: (XhrResponse -> Either Text a)

476 :: (XhrResponse -> Either Text a)

392 -> (tag, XhrResponse)

477 -> (tag, XhrResponse)

393 -> ReqResult tag a

478 -> ReqResult tag a

394−evalResponse decode (tag, xhr) =

479+evalResponse decodeFun (tag, xhr) =

395 let okStatus = _xhrResponse_status xhr < 400

480 let okStatus = _xhrResponse_status xhr < 400

396 errMsg = fromMaybe

481 errMsg = fromMaybe

397 ("Empty response with error code " <>

482 ("Empty response with error code " <>

@@ -401,7 +486,7 @@ evalResponse decode (tag, xhr) =

401 then either

486 then either

402 (\e -> ResponseFailure tag e xhr)

487 (\e -> ResponseFailure tag e xhr)

403 (\v -> ResponseSuccess tag v xhr)

488 (\v -> ResponseSuccess tag v xhr)

404− (decode xhr)

489+ (decodeFun xhr)

405 else ResponseFailure tag errMsg xhr

490 else ResponseFailure tag errMsg xhr

406 in respPayld

491 in respPayld

407

492

@@ -414,3 +499,98 @@ note e = maybe (Left e) Right

414fmapL :: (e -> e') -> Either e a -> Either e' a

499fmapL :: (e -> e') -> Either e a -> Either e' a

415fmapL _ (Right a) = Right a

500fmapL _ (Right a) = Right a

416fmapL f (Left e) = Left (f e)

501fmapL f (Left e) = Left (f e)

502+

503+

504+--------------------------------------------------------------------------

505+-- * MimeUnrender Instances

506+

507+-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just

508+-- objects and arrays.

509+--

510+-- Will handle trailing whitespace, but not trailing junk. ie.

511+--

512+-- >>> eitherDecodeLenient "1 " :: Either String Int

513+-- Right 1

514+--

515+-- >>> eitherDecodeLenient "1 junk" :: Either String Int

516+-- Left "trailing junk after valid JSON: endOfInput"

517+eitherDecodeLenient :: FromJSON a => BL.ByteString -> Either String a

518+eitherDecodeLenient input =

519+ parseOnly parser (BL.toStrict input) >>= parseEither parseJSON

520+ where

521+ parser = skipSpace

522+ *> Data.Aeson.Parser.value

523+ <* skipSpace

524+ <* (endOfInput <?> "trailing junk after valid JSON")

525+

526+-- | `eitherDecode`

527+instance FromJSON a => MimeUnrender JSON a where

528+ mimeUnrender _ bs =

529+#ifdef ghcjs_HOST_OS

530+ note "Raw JSON decode failure" $ rawDecode (BL.toStrict bs)

531+#else

532+ eitherDecodeLenient bs

533+#endif

534+

535+-- -- | @urlDecodeAsForm@

536+-- -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

537+-- -- holds if every element of x is non-null (i.e., not @("", "")@)

538+-- instance FromForm a => MimeUnrender FormUrlEncoded a where

539+-- mimeUnrender _ = left TextS.unpack . urlDecodeAsForm

540+

541+-- | @left show . TextL.decodeUtf8'@

542+instance MimeUnrender PlainText TextL.Text where

543+ mimeUnrender _ = left show . TextL.decodeUtf8'

544+

545+-- | @left show . TextS.decodeUtf8' . toStrict@

546+instance MimeUnrender PlainText T.Text where

547+ mimeUnrender _ = left show . TE.decodeUtf8' . BL.toStrict

548+

549+-- | @Right . BC.unpack@

550+instance MimeUnrender PlainText String where

551+ mimeUnrender _ = Right . BL.unpack

552+

553+-- | @Right . id@

554+instance MimeUnrender OctetStream BL.ByteString where

555+ mimeUnrender _ = Right . id

556+

557+-- | @Right . toStrict@

558+instance MimeUnrender OctetStream BS.ByteString where

559+ mimeUnrender _ = Right . BL.toStrict

560+

561+class Accept ctype => MimeUnrender ctype a where

562+ mimeUnrender :: Proxy ctype -> BL.ByteString -> Either String a

563+

564+class AllCTUnrender (list :: [*]) a where

565+ handleCTypeH :: Proxy list

566+ -> BL.ByteString -- Content-Type header

567+ -> BL.ByteString -- Request body

568+ -> Maybe (Either String a)

569+

570+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where

571+ handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)

572+ where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body

573+

574+

575+canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool

576+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h

577+

578+

579+--------------------------------------------------------------------------

580+-- Check that all elements of list are instances of MimeUnrender

581+--------------------------------------------------------------------------

582+class (AllMime list) => AllMimeUnrender (list :: [*]) a where

583+ allMimeUnrender :: Proxy list

584+ -> BL.ByteString

585+ -> [(M.MediaType, Either String a)]

586+

587+instance AllMimeUnrender '[] a where

588+ allMimeUnrender _ _ = []

589+

590+instance ( MimeUnrender ctyp a

591+ , AllMimeUnrender ctyps a

592+ ) => AllMimeUnrender (ctyp ': ctyps) a where

593+ allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)

594+ :(allMimeUnrender pctyps val)

595+ where pctyp = Proxy :: Proxy ctyp

596+ pctyps = Proxy :: Proxy ctyps

src/Servant/Reflex.hs+2−2

@@ -49,7 +49,7 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,

49 BasicAuthData, BuildHeadersTo(..),

50 Capture, contentType, Header,

51 Headers(..), HttpVersion, IsSecure,

52− MimeRender(..), MimeUnrender,

52+ MimeRender(..),

53 NoContent, QueryFlag, QueryParam,

54 QueryParams, Raw, ReflectMethod(..),

55 RemoteHost, ReqBody,

@@ -65,7 +65,7 @@ import Reflex.Dom (Dynamic, Event, Reflex,

65import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

66 showBaseUrl,

67 SupportsServantReflex)

68−import Servant.Common.Req (Req, ReqResult(..), QParam(..),

68+import Servant.Common.Req (MimeUnrender(..), Req, ReqResult(..), QParam(..),

69 QueryPart(..), addHeader, authData,

70 defReq, evalResponse, prependToPathParts,

71 -- performRequestCT,

src/Servant/Reflex/Multi.hs+2−2

@@ -46,7 +46,7 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth,

46 BasicAuthData, BuildHeadersTo (..),

47 Capture, Header, Headers (..),

48 HttpVersion, IsSecure, MimeRender (..),

49− MimeUnrender, NoContent, QueryFlag,

49+ NoContent, QueryFlag,

50 QueryParam, QueryParams, Raw,

51 ReflectMethod (..), RemoteHost,

52 ReqBody, ToHttpApiData (..), Vault,

@@ -59,7 +59,7 @@ import Reflex.Dom (Dynamic, Event, Reflex,

59------------------------------------------------------------------------------

60import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

61 SupportsServantReflex)

62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

62+import Servant.Common.Req (MimeUnrender(..), QParam (..), QueryPart (..), Req,

63 ReqResult (..), addHeader, authData,

64 defReq, performRequestsCT,

65 performRequestsNoBody,