@@ -1,38 +1,88 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
23{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
46{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE KindSignatures #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
59{-# LANGUAGE OverloadedStrings #-}
610{-# LANGUAGE LambdaCase #-}
711{-# LANGUAGE ScopedTypeVariables #-}
812{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+#ifdef ghcjs_HOST_OS
16+{-# LANGUAGE JavaScriptFFI #-}
17+#endif
918
1019module Servant.Common.Req where
1120
1221-------------------------------------------------------------------------------
1322import Control.Concurrent
1423import Control.Applicative (liftA2, liftA3)
24+import Control.Arrow (left)
1525import Control.Monad (join)
1626import 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
1731import Data.Bifunctor (first)
32+import qualified Data.ByteString.Char8 as BS
1833import qualified Data.ByteString.Lazy.Char8 as BL
1934import qualified Data.Map as Map
20−import Data.Maybe (catMaybes, fromMaybe)
35+import Data.Maybe (catMaybes, fromMaybe, isJust)
2136import Data.Functor.Compose
2237import Data.Monoid ((<>))
2338import Data.Proxy (Proxy(..))
2439import Data.Text (Text)
2540import qualified Data.Text as T
2641import qualified Data.Text.Encoding as TE
42+import qualified Data.Text.Lazy as TextL
43+import qualified Data.Text.Lazy.Encoding as TextL
2744import Data.Traversable (forM)
45+import Data.Typeable
46+import qualified Network.HTTP.Media.MediaType as M
47+import qualified Network.HTTP.Media as M
2848import Reflex.Dom hiding (tag)
2949import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3050 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)
3255import Web.HttpApiData (ToHttpApiData(..))
3356-------------------------------------------------------------------------------
3457import Servant.API.BasicAuth
3558
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+
3686
3787------------------------------------------------------------------------------
3888-- | The result of a request event
@@ -311,40 +361,6 @@ bytesToPayload :: BL.ByteString -> XhrPayload
311361bytesToPayload = TE.decodeUtf8 . BL.toStrict
312362
313363
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−
348364
349365performRequestsCT
350366 :: (SupportsServantReflex t m,
@@ -358,9 +374,8 @@ performRequestsCT
358374performRequestsCT ct reqMeth reqs reqHost trigger = do
359375 resps <- performRequests reqMeth reqs reqHost trigger
360376 let decodeResp x = first T.pack .
361− mimeUnrender ct .
362− BL.fromStrict .
363− TE.encodeUtf8 =<< note "No body text"
377+ mimeUnrender ct
378+ =<< note "No body text"
364379 (_xhrResponse_responseText x)
365380 return $ fmap
366381 (\(t,rs) -> ffor rs $ \r -> case r of
@@ -369,6 +384,63 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
369384 )
370385 resps
371386
387+-- mimeUnrender' :: (MimeUnrender ct a, Typeable ct) => Proxy ct -> BS.ByteString -> Either String a
388+-- mimeUnrender' p bs
389+-- -- | cantRawJson = mimeUnrender p (BL.fromStrict bs)
390+-- | otherwise = note "Raw JSON decode failure" $ rawDecode bs
391+-- where
392+-- cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p
393+
394+-- copied from http://lpaste.net/6122658287709061120
395+#ifdef ghcjs_HOST_OS
396+foreign import javascript safe "new DataView($3,$1,$2)"
397+ js_dataView :: Int -> Int -> JSVal -> JSVal
398+
399+foreign import javascript unsafe "JSON['parse']($1)"
400+ js_jsonParse :: JSVal -> JSVal
401+
402+rawDecode :: (FromJSON a) => T.Text -> Maybe a
403+rawDecode bs = do
404+
405+ let jsv = T.textToJSString bs
406+
407+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse $ jsval jsv
408+ case res of
409+ Left (_e :: SomeException) -> Nothing
410+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
411+ where
412+ go v = case Aeson.fromJSON v of
413+ Aeson.Success a -> Just a
414+ _ -> Nothing
415+
416+
417+-- copied from http://lpaste.net/raw/353535 Thanks ncl28!
418+aesonFromJSVal :: JSVal -> IO (Maybe A.Value)
419+aesonFromJSVal r = do
420+ case jsonTypeOf r of
421+ JSONNull -> return (Just A.Null)
422+ JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))
423+ <$> fromJSVal r
424+ JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))
425+ <$> fromJSVal r
426+ JSONBool -> liftM A.Bool <$> fromJSVal r
427+ JSONString -> liftM A.String <$> fromJSVal r
428+ JSONArray -> liftM (A.Array . V.fromList) <$>
429+ runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<
430+ (MaybeT (fromJSVal r)))
431+ JSONObject -> do
432+ props <- OI.listProps (OI.Object r)
433+ runMaybeT $ do
434+ propVals <- forM props $ \p -> do
435+ v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))
436+ return (T.textFromJSString p, v)
437+ return (A.Object (H.fromList propVals))
438+{-# INLINE aesonFromJSVal #-}
439+
440+#else
441+rawDecode :: FromJSON a => BS.ByteString -> Maybe a
442+rawDecode = decode . BL.fromStrict
443+#endif
372444
373445performRequestsNoBody
374446 :: (SupportsServantReflex t m,
@@ -391,7 +463,7 @@ evalResponse
391463 :: (XhrResponse -> Either Text a)
392464 -> (tag, XhrResponse)
393465 -> ReqResult tag a
394−evalResponse decode (tag, xhr) =
466+evalResponse decodeFun (tag, xhr) =
395467 let okStatus = _xhrResponse_status xhr < 400
396468 errMsg = fromMaybe
397469 ("Empty response with error code " <>
@@ -401,7 +473,7 @@ evalResponse decode (tag, xhr) =
401473 then either
402474 (\e -> ResponseFailure tag e xhr)
403475 (\v -> ResponseSuccess tag v xhr)
404− (decode xhr)
476+ (decodeFun xhr)
405477 else ResponseFailure tag errMsg xhr
406478 in respPayld
407479
@@ -414,3 +486,98 @@ note e = maybe (Left e) Right
414486fmapL :: (e -> e') -> Either e a -> Either e' a
415487fmapL _ (Right a) = Right a
416488fmapL f (Left e) = Left (f e)
489+
490+
491+--------------------------------------------------------------------------
492+-- * MimeUnrender Instances
493+
494+-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
495+-- objects and arrays.
496+--
497+-- Will handle trailing whitespace, but not trailing junk. ie.
498+--
499+-- >>> eitherDecodeLenient "1 " :: Either String Int
500+-- Right 1
501+--
502+-- >>> eitherDecodeLenient "1 junk" :: Either String Int
503+-- Left "trailing junk after valid JSON: endOfInput"
504+eitherDecodeLenient :: FromJSON a => BL.ByteString -> Either String a
505+eitherDecodeLenient input =
506+ parseOnly parser (BL.toStrict input) >>= parseEither parseJSON
507+ where
508+ parser = skipSpace
509+ *> Data.Aeson.Parser.value
510+ <* skipSpace
511+ <* (endOfInput <?> "trailing junk after valid JSON")
512+
513+-- | `eitherDecode`
514+instance FromJSON a => MimeUnrender JSON a where
515+ mimeUnrender _ t =
516+#ifdef ghcjs_HOST_OS
517+ note "Raw JSON decode failure" $ rawDecode t -- (BL.toStrict bs)
518+#else
519+ eitherDecodeLenient (BL.fromStrict $ TE.encodeUtf8 t)
520+#endif
521+
522+-- -- | @urlDecodeAsForm@
523+-- -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
524+-- -- holds if every element of x is non-null (i.e., not @("", "")@)
525+-- instance FromForm a => MimeUnrender FormUrlEncoded a where
526+-- mimeUnrender _ = left TextS.unpack . urlDecodeAsForm
527+
528+-- | @left show . TextL.decodeUtf8'@
529+instance MimeUnrender PlainText TextL.Text where
530+ mimeUnrender _ = return . TextL.fromStrict
531+
532+-- | @left show . TextS.decodeUtf8' . toStrict@
533+instance MimeUnrender PlainText T.Text where
534+ mimeUnrender _ = return
535+
536+-- | @Right . BC.unpack@
537+instance MimeUnrender PlainText String where
538+ mimeUnrender _ = Right . T.unpack
539+
540+-- | @Right . id@
541+instance MimeUnrender OctetStream BL.ByteString where
542+ mimeUnrender _ = return . TextL.encodeUtf8 . TextL.fromStrict
543+
544+-- | @Right . toStrict@
545+instance MimeUnrender OctetStream BS.ByteString where
546+ mimeUnrender _ = Right . TE.encodeUtf8
547+
548+class Accept ctype => MimeUnrender ctype a where
549+ mimeUnrender :: Proxy ctype -> T.Text -> Either String a
550+
551+class AllCTUnrender (list :: [*]) a where
552+ handleCTypeH :: Proxy list
553+ -> BL.ByteString -- Content-Type header
554+ -> T.Text -- Request body
555+ -> Maybe (Either String a)
556+
557+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
558+ handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
559+ where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
560+
561+
562+canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
563+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
564+
565+
566+--------------------------------------------------------------------------
567+-- Check that all elements of list are instances of MimeUnrender
568+--------------------------------------------------------------------------
569+class (AllMime list) => AllMimeUnrender (list :: [*]) a where
570+ allMimeUnrender :: Proxy list
571+ -> T.Text
572+ -> [(M.MediaType, Either String a)]
573+
574+instance AllMimeUnrender '[] a where
575+ allMimeUnrender _ _ = []
576+
577+instance ( MimeUnrender ctyp a
578+ , AllMimeUnrender ctyps a
579+ ) => AllMimeUnrender (ctyp ': ctyps) a where
580+ allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
581+ :(allMimeUnrender pctyps val)
582+ where pctyp = Proxy :: Proxy ctyp
583+ pctyps = Proxy :: Proxy ctyps