@@ -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,
@@ -369,6 +385,75 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
369385 )
370386 resps
371387
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
372457
373458performRequestsNoBody
374459 :: (SupportsServantReflex t m,
@@ -391,7 +476,7 @@ evalResponse
391476 :: (XhrResponse -> Either Text a)
392477 -> (tag, XhrResponse)
393478 -> ReqResult tag a
394−evalResponse decode (tag, xhr) =
479+evalResponse decodeFun (tag, xhr) =
395480 let okStatus = _xhrResponse_status xhr < 400
396481 errMsg = fromMaybe
397482 ("Empty response with error code " <>
@@ -401,7 +486,7 @@ evalResponse decode (tag, xhr) =
401486 then either
402487 (\e -> ResponseFailure tag e xhr)
403488 (\v -> ResponseSuccess tag v xhr)
404− (decode xhr)
489+ (decodeFun xhr)
405490 else ResponseFailure tag errMsg xhr
406491 in respPayld
407492
@@ -414,3 +499,98 @@ note e = maybe (Left e) Right
414499fmapL :: (e -> e') -> Either e a -> Either e' a
415500fmapL _ (Right a) = Right a
416501fmapL 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