@@ -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,77 @@ 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 "console.log($1); $r = JSON['parse']($1);"
400+ js_jsonParse :: JSVal -> JSVal
401+
402+rawDecode :: (FromJSON a) => T.Text -> Maybe a
403+rawDecode bs = do
404+ -- Below copied from Reflex.Dom.WebSocket.Foreign
405+ -- tmp <- Just $ unsafePerformIO $ putStrLn ("bs: " ++ BS.unpack bs)
406+ -- error ("bs: " ++ BS.unpack bs)
407+ -- let (b, off, len) = fromByteString bs
408+ -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
409+ -- tmp <- error (BS.unpack bs)
410+
411+ -- let jsv = if BS.length bs == 0
412+ -- then unsafePerformIO $ jsval . getArrayBuffer <$> create 0
413+ -- else js_dataView off len $ jsval $ getArrayBuffer b
414+
415+ let jsv = T.textToJSString bs
416+
417+ -- let jsv = _ bs
418+ -- TODO pFromJSVal to avoid unsafePerformIO
419+ let res = unsafePerformIO $ try $ aesonFromJSVal $ js_jsonParse $ jsval jsv
420+ case res of
421+ Left (_e :: SomeException) -> Nothing
422+ Right (v :: (Maybe Aeson.Value)) -> maybe Nothing go v
423+ where
424+ go v = case Aeson.fromJSON v of
425+ Aeson.Success a -> Just a
426+ _ -> Nothing
427+
428+
429+-- copied from http://lpaste.net/raw/353535 Thanks ncl28!
430+aesonFromJSVal :: JSVal -> IO (Maybe A.Value)
431+aesonFromJSVal r = do
432+ putStrLn "Hello"
433+ print $ jsonTypeOf r
434+ case jsonTypeOf r of
435+ JSONNull -> return (Just A.Null)
436+ JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))
437+ <$> fromJSVal r
438+ JSONFloat -> liftM (A.Number . (fromFloatDigits :: Double -> Scientific))
439+ <$> fromJSVal r
440+ JSONBool -> liftM A.Bool <$> fromJSVal r
441+ JSONString -> liftM A.String <$> fromJSVal r
442+ JSONArray -> liftM (A.Array . V.fromList) <$>
443+ runMaybeT (traverse (MaybeT . aesonFromJSVal) =<<
444+ (MaybeT (fromJSVal r)))
445+ JSONObject -> do
446+ props <- OI.listProps (OI.Object r)
447+ runMaybeT $ do
448+ propVals <- forM props $ \p -> do
449+ v <- MaybeT (aesonFromJSVal =<< OI.getProp p (OI.Object r))
450+ return (T.textFromJSString p, v)
451+ return (A.Object (H.fromList propVals))
452+{-# INLINE aesonFromJSVal #-}
453+
454+#else
455+rawDecode :: FromJSON a => BS.ByteString -> Maybe a
456+rawDecode = decode . BL.fromStrict
457+#endif
372458
373459performRequestsNoBody
374460 :: (SupportsServantReflex t m,
@@ -391,7 +477,7 @@ evalResponse
391477 :: (XhrResponse -> Either Text a)
392478 -> (tag, XhrResponse)
393479 -> ReqResult tag a
394−evalResponse decode (tag, xhr) =
480+evalResponse decodeFun (tag, xhr) =
395481 let okStatus = _xhrResponse_status xhr < 400
396482 errMsg = fromMaybe
397483 ("Empty response with error code " <>
@@ -401,7 +487,7 @@ evalResponse decode (tag, xhr) =
401487 then either
402488 (\e -> ResponseFailure tag e xhr)
403489 (\v -> ResponseSuccess tag v xhr)
404− (decode xhr)
490+ (decodeFun xhr)
405491 else ResponseFailure tag errMsg xhr
406492 in respPayld
407493
@@ -414,3 +500,98 @@ note e = maybe (Left e) Right
414500fmapL :: (e -> e') -> Either e a -> Either e' a
415501fmapL _ (Right a) = Right a
416502fmapL f (Left e) = Left (f e)
503+
504+
505+--------------------------------------------------------------------------
506+-- * MimeUnrender Instances
507+
508+-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
509+-- objects and arrays.
510+--
511+-- Will handle trailing whitespace, but not trailing junk. ie.
512+--
513+-- >>> eitherDecodeLenient "1 " :: Either String Int
514+-- Right 1
515+--
516+-- >>> eitherDecodeLenient "1 junk" :: Either String Int
517+-- Left "trailing junk after valid JSON: endOfInput"
518+eitherDecodeLenient :: FromJSON a => BL.ByteString -> Either String a
519+eitherDecodeLenient input =
520+ parseOnly parser (BL.toStrict input) >>= parseEither parseJSON
521+ where
522+ parser = skipSpace
523+ *> Data.Aeson.Parser.value
524+ <* skipSpace
525+ <* (endOfInput <?> "trailing junk after valid JSON")
526+
527+-- | `eitherDecode`
528+instance FromJSON a => MimeUnrender JSON a where
529+ mimeUnrender _ t =
530+#ifdef ghcjs_HOST_OS
531+ note "Raw JSON decode failure" $ rawDecode t -- (BL.toStrict bs)
532+#else
533+ eitherDecodeLenient (BL.fromStrict $ TE.encodeUtf8 t)
534+#endif
535+
536+-- -- | @urlDecodeAsForm@
537+-- -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
538+-- -- holds if every element of x is non-null (i.e., not @("", "")@)
539+-- instance FromForm a => MimeUnrender FormUrlEncoded a where
540+-- mimeUnrender _ = left TextS.unpack . urlDecodeAsForm
541+
542+-- | @left show . TextL.decodeUtf8'@
543+instance MimeUnrender PlainText TextL.Text where
544+ mimeUnrender _ = return . TextL.fromStrict
545+
546+-- | @left show . TextS.decodeUtf8' . toStrict@
547+instance MimeUnrender PlainText T.Text where
548+ mimeUnrender _ = return
549+
550+-- | @Right . BC.unpack@
551+instance MimeUnrender PlainText String where
552+ mimeUnrender _ = Right . T.unpack
553+
554+-- | @Right . id@
555+instance MimeUnrender OctetStream BL.ByteString where
556+ mimeUnrender _ = return . TextL.encodeUtf8 . TextL.fromStrict
557+
558+-- | @Right . toStrict@
559+instance MimeUnrender OctetStream BS.ByteString where
560+ mimeUnrender _ = Right . TE.encodeUtf8
561+
562+class Accept ctype => MimeUnrender ctype a where
563+ mimeUnrender :: Proxy ctype -> T.Text -> Either String a
564+
565+class AllCTUnrender (list :: [*]) a where
566+ handleCTypeH :: Proxy list
567+ -> BL.ByteString -- Content-Type header
568+ -> T.Text -- Request body
569+ -> Maybe (Either String a)
570+
571+instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
572+ handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
573+ where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
574+
575+
576+canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
577+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
578+
579+
580+--------------------------------------------------------------------------
581+-- Check that all elements of list are instances of MimeUnrender
582+--------------------------------------------------------------------------
583+class (AllMime list) => AllMimeUnrender (list :: [*]) a where
584+ allMimeUnrender :: Proxy list
585+ -> T.Text
586+ -> [(M.MediaType, Either String a)]
587+
588+instance AllMimeUnrender '[] a where
589+ allMimeUnrender _ _ = []
590+
591+instance ( MimeUnrender ctyp a
592+ , AllMimeUnrender ctyps a
593+ ) => AllMimeUnrender (ctyp ': ctyps) a where
594+ allMimeUnrender _ val = (contentType pctyp, mimeUnrender pctyp val)
595+ :(allMimeUnrender pctyps val)
596+ where pctyp = Proxy :: Proxy ctyp
597+ pctyps = Proxy :: Proxy ctyps