629fbac · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

Vendor MimeUnrender

629fbacGreg Hale10 years ago

servant-reflex.cabal+2

compare with master

unifiedsplit

@@ -22,12 +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,

30 aeson >= 0.11.2 && < 0.12,

31 aeson >= 0.11.2 && < 0.12,

32+ attoparsec >= 0.13 && < 0.14,

31 bytestring >= 0.10 && < 0.11,

33 bytestring >= 0.10 && < 0.11,

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

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

33 containers >= 0.5.6 && < 0.6,

35 containers >= 0.5.6 && < 0.6,

src/Servant/Common/Req.hs+142−50

@@ -1,43 +1,64 @@

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)

17import Data.Aeson

27import Data.Aeson

18import qualified Data.Aeson as Aeson

28import qualified Data.Aeson as Aeson

29+import Data.Aeson.Types

30+import qualified Data.Aeson.Parser

19import Data.Bifunctor (first)

31import Data.Bifunctor (first)

20import qualified Data.ByteString.Char8 as BS

32import qualified Data.ByteString.Char8 as BS

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

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

22import qualified Data.Map as Map

34import qualified Data.Map as Map

23−import Data.Maybe (catMaybes, fromMaybe)

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

24import Data.Functor.Compose

36import Data.Functor.Compose

25import Data.Monoid ((<>))

37import Data.Monoid ((<>))

26import Data.Proxy (Proxy(..))

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

27import Data.Text (Text)

39import Data.Text (Text)

28import qualified Data.Text as T

40import qualified Data.Text as T

29import 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

30import Data.Traversable (forM)

44import Data.Traversable (forM)

31import Data.Typeable

45import Data.Typeable

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

47+import qualified Network.HTTP.Media as M

32import Reflex.Dom hiding (tag)

48import Reflex.Dom hiding (tag)

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

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

34 SupportsServantReflex)

50 SupportsServantReflex)

35−import Servant.API.ContentTypes (JSON, MimeUnrender(..),

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

52+ PlainText,

36− NoContent(..))

53+ NoContent(..),

54+ OctetStream, contentType)

37import Web.HttpApiData (ToHttpApiData(..))

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

38-------------------------------------------------------------------------------

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

39import Servant.API.BasicAuth

57import Servant.API.BasicAuth

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

60+ skipSpace, (<?>))

61+import Data.String.Conversions (cs)

42#ifdef ghcjs_HOST_OS

63#ifdef ghcjs_HOST_OS

43import Control.Exception

64import Control.Exception

@@ -340,44 +361,10 @@ bytesToPayload :: BL.ByteString -> XhrPayload

340bytesToPayload = TE.decodeUtf8 . BL.toStrict

361bytesToPayload = TE.decodeUtf8 . BL.toStrict

341

362

342

363

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

344−-- => Text

345−-- -> Req t

346−-- -> Dynamic t BaseUrl

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

348−-- performRequestNoBody reqMeth req reqHost trigger = do

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

350−-- let decodeResp = const $ Right NoContent

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

352−-- , fmap (uncurry RequestFailure) badReq

353−-- ]

354−

355−

356−-- performRequestCT

357−-- :: (SupportsServantReflex t m,

358−-- MimeUnrender ct a)

359−-- => Proxy ct

360−-- -> Text

361−-- -> Req t

362−-- -> Dynamic t BaseUrl

363−-- -> Event t tag

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

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

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

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

368−-- mimeUnrender ct .

369−-- BL.fromStrict .

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

371−-- (_xhrResponse_responseText x)

372−

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

374−-- , fmap (uncurry RequestFailure) badReq

375−-- ]

376−

377

364

378performRequestsCT

365performRequestsCT

379 :: (SupportsServantReflex t m,

366 :: (SupportsServantReflex t m,

380− MimeUnrender ct a, Traversable f, Typeable ct)

367+ MimeUnrender ct a, Traversable f)

381 => Proxy ct

368 => Proxy ct

382 -> Text

369 -> Text

383 -> Dynamic t (f (Req t))

370 -> Dynamic t (f (Req t))

@@ -387,8 +374,8 @@ performRequestsCT

387performRequestsCT ct reqMeth reqs reqHost trigger = do

374performRequestsCT ct reqMeth reqs reqHost trigger = do

388 resps <- performRequests reqMeth reqs reqHost trigger

375 resps <- performRequests reqMeth reqs reqHost trigger

389 let decodeResp x = first T.pack .

376 let decodeResp x = first T.pack .

390− mimeUnrender' ct .

377+ mimeUnrender ct .

391− -- BL.fromStrict .

378+ BL.fromStrict .

392 TE.encodeUtf8 =<< note "No body text"

379 TE.encodeUtf8 =<< note "No body text"

393 (_xhrResponse_responseText x)

380 (_xhrResponse_responseText x)

394 return $ fmap

381 return $ fmap

@@ -398,24 +385,31 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do

398 )

385 )

399 resps

386 resps

400

387

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

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

402−mimeUnrender' p bs

389+-- mimeUnrender' p bs

403− -- | cantRawJson = mimeUnrender p (BL.fromStrict bs)

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

404− | otherwise = note "Raw JSON decode failure" $ rawDecode bs

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

405− where

392+-- where

406− cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p

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

407

394

408-- copied from http://lpaste.net/6122658287709061120

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

409#ifdef ghcjs_HOST_OS

396#ifdef ghcjs_HOST_OS

410−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

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

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

399+

411−foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal

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

401+ js_jsonParse :: JSVal -> JSVal

402+

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

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

413rawDecode bs = do

404rawDecode bs = do

414 -- Below copied from Reflex.Dom.WebSocket.Foreign

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

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

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

415 let (b, off, len) = fromByteString bs

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

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

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

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

417 let jsv = if BS.length bs == 0

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

418− then unsafePerformIO $ jsval . getArrayBuffer <$> create 0

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

419 else js_dataView off len $ jsval $ getArrayBuffer b

413 else js_dataView off len $ jsval $ getArrayBuffer b

420

414

421 -- let jsv = _ bs

415 -- let jsv = _ bs

@@ -432,7 +426,10 @@ rawDecode bs = do

432

426

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

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

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

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

429+aesonFromJSVal r = do

430+ putStrLn "Hello"

431+ print $ jsonTypeOf r

435−aesonFromJSVal r = case jsonTypeOf r of

432+ case jsonTypeOf r of

436 JSONNull -> return (Just A.Null)

433 JSONNull -> return (Just A.Null)

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

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

438 <$> fromJSVal r

435 <$> fromJSVal r

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

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

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

503fmapL _ (Right a) = Right a

500fmapL _ (Right a) = Right a

504fmapL 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,