@@ -1,43 +1,64 @@
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)
1727import Data.Aeson
1828import qualified Data.Aeson as Aeson
29+import Data.Aeson.Types
30+import qualified Data.Aeson.Parser
1931import Data.Bifunctor (first)
2032import qualified Data.ByteString.Char8 as BS
2133import qualified Data.ByteString.Lazy.Char8 as BL
2234import qualified Data.Map as Map
23−import Data.Maybe (catMaybes, fromMaybe)
35+import Data.Maybe (catMaybes, fromMaybe, isJust)
2436import Data.Functor.Compose
2537import Data.Monoid ((<>))
2638import Data.Proxy (Proxy(..))
2739import Data.Text (Text)
2840import qualified Data.Text as T
2941import qualified Data.Text.Encoding as TE
42+import qualified Data.Text.Lazy as TextL
43+import qualified Data.Text.Lazy.Encoding as TextL
3044import Data.Traversable (forM)
3145import Data.Typeable
46+import qualified Network.HTTP.Media.MediaType as M
47+import qualified Network.HTTP.Media as M
3248import Reflex.Dom hiding (tag)
3349import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3450 SupportsServantReflex)
35−import Servant.API.ContentTypes (JSON, MimeUnrender(..),
36− NoContent(..))
51+import Servant.API.ContentTypes (Accept, AcceptHeader(..), AllMime(..), JSON, -- MimeUnrender(..),
52+ PlainText,
53+ NoContent(..),
54+ OctetStream, contentType)
3755import Web.HttpApiData (ToHttpApiData(..))
3856-------------------------------------------------------------------------------
3957import Servant.API.BasicAuth
4058
59+import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
60+ skipSpace, (<?>))
61+import Data.String.Conversions (cs)
4162
4263#ifdef ghcjs_HOST_OS
4364import Control.Exception
@@ -340,44 +361,10 @@ bytesToPayload :: BL.ByteString -> XhrPayload
340361bytesToPayload = TE.decodeUtf8 . BL.toStrict
341362
342363
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−
377364
378365performRequestsCT
379366 :: (SupportsServantReflex t m,
380− MimeUnrender ct a, Traversable f, Typeable ct)
367+ MimeUnrender ct a, Traversable f)
381368 => Proxy ct
382369 -> Text
383370 -> Dynamic t (f (Req t))
@@ -387,8 +374,8 @@ performRequestsCT
387374performRequestsCT ct reqMeth reqs reqHost trigger = do
388375 resps <- performRequests reqMeth reqs reqHost trigger
389376 let decodeResp x = first T.pack .
390− mimeUnrender' ct .
391− -- BL.fromStrict .
377+ mimeUnrender ct .
378+ BL.fromStrict .
392379 TE.encodeUtf8 =<< note "No body text"
393380 (_xhrResponse_responseText x)
394381 return $ fmap
@@ -398,24 +385,31 @@ performRequestsCT ct reqMeth reqs reqHost trigger = do
398385 )
399386 resps
400387
401−mimeUnrender' :: (MimeUnrender ct a, Typeable ct) => Proxy ct -> BS.ByteString -> Either String a
402−mimeUnrender' p bs
403− -- | cantRawJson = mimeUnrender p (BL.fromStrict bs)
404− | otherwise = note "Raw JSON decode failure" $ rawDecode bs
405− where
406− cantRawJson = typeOf (Proxy :: Proxy JSON) /= typeOf p
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
407394
408395-- copied from http://lpaste.net/6122658287709061120
409396#ifdef ghcjs_HOST_OS
410−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
411−foreign import javascript unsafe "JSON['parse']($1)" js_jsonParse :: JSVal -> JSVal
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+
412403rawDecode :: (FromJSON a) => BS.ByteString -> Maybe a
413404rawDecode bs = do
414405 -- Below copied from Reflex.Dom.WebSocket.Foreign
406+ -- tmp <- Just $ unsafePerformIO $ putStrLn ("bs: " ++ BS.unpack bs)
407+ -- error ("bs: " ++ BS.unpack bs)
415408 let (b, off, len) = fromByteString bs
416409 -- x = return $ js_dataView off len $ jsval $ getArrayBuffer b :: _
410+ -- tmp <- error (BS.unpack bs)
417411 let jsv = if BS.length bs == 0
418− then unsafePerformIO $ jsval . getArrayBuffer <$> create 0
412+ then error "ZERO!!" -- unsafePerformIO $ jsval . getArrayBuffer <$> create 0
419413 else js_dataView off len $ jsval $ getArrayBuffer b
420414
421415 -- let jsv = _ bs
@@ -432,7 +426,10 @@ rawDecode bs = do
432426
433427-- copied from http://lpaste.net/raw/353535 Thanks ncl28!
434428aesonFromJSVal :: JSVal -> IO (Maybe A.Value)
435−aesonFromJSVal r = case jsonTypeOf r of
429+aesonFromJSVal r = do
430+ putStrLn "Hello"
431+ print $ jsonTypeOf r
432+ case jsonTypeOf r of
436433 JSONNull -> return (Just A.Null)
437434 JSONInteger -> liftM (A.Number . flip scientific 0 . (toInteger :: Int -> Integer))
438435 <$> fromJSVal r
@@ -502,3 +499,98 @@ note e = maybe (Left e) Right
502499fmapL :: (e -> e') -> Either e a -> Either e' a
503500fmapL _ (Right a) = Right a
504501fmapL 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