@@ -11,7 +11,6 @@
11{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12module Servant.API.ContentTypes where
12module Servant.API.ContentTypes where
14−import Control.Monad (join)
15import qualified Data.ByteString as BS
14import qualified Data.ByteString as BS
16import Data.ByteString.Lazy (ByteString)
15import Data.ByteString.Lazy (ByteString)
17import Data.String.Conversions (cs)
16import Data.String.Conversions (cs)
@@ -102,27 +101,25 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
102 ) => AllCTRender ctyps a where
101 ) => AllCTRender ctyps a where
103 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
102 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
104 where pctyps = Proxy :: Proxy ctyps
103 where pctyps = Proxy :: Proxy ctyps
105− amrs = amr pctyps val
104+ amrs = allMimeRender pctyps val
106− lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
105+ lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
111--------------------------------------------------------------------------
108--------------------------------------------------------------------------
112-- * Unrender
109-- * Unrender
113class Accept ctype => MimeUnrender ctype a where
110class Accept ctype => MimeUnrender ctype a where
114− fromByteString :: Proxy ctype -> ByteString -> Maybe a
111+ fromByteString :: Proxy ctype -> ByteString -> Either String a
116class AllCTUnrender list a where
113class AllCTUnrender list a where
117 handleCTypeH :: Proxy list
114 handleCTypeH :: Proxy list
118 -> ByteString -- Content-Type header
115 -> ByteString -- Content-Type header
119 -> ByteString -- Request body
116 -> ByteString -- Request body
120− -> Maybe a
117+ -> Maybe (Either String a)
122instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
119instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
123 ) => AllCTUnrender ctyps a where
120 ) => AllCTUnrender ctyps a where
124− handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
121+ handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
125− where lkup = amu (Proxy :: Proxy ctyps) body
122+ where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
127--------------------------------------------------------------------------
124--------------------------------------------------------------------------
128-- * Utils (Internal)
125-- * Utils (Internal)
@@ -132,50 +129,42 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
132-- Check that all elements of list are instances of MimeRender
129-- Check that all elements of list are instances of MimeRender
133--------------------------------------------------------------------------
130--------------------------------------------------------------------------
134class AllMimeRender ls a where
131class AllMimeRender ls a where
135− amr :: Proxy ls
132+ allMimeRender :: Proxy ls
136− -> a -- value to serialize
133+ -> a -- value to serialize
137− -> [(M.MediaType, ByteString)] -- content-types/response pairs
134+ -> [(M.MediaType, ByteString)] -- content-types/response pairs
139instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
136instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
140− amr _ a = [(contentType pctyp, toByteString pctyp a)]
137+ allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
141 where pctyp = Proxy :: Proxy ctyp
138 where pctyp = Proxy :: Proxy ctyp
143instance ( MimeRender ctyp a
140instance ( MimeRender ctyp a
144− , MimeRender ctyp' a -- at least two elems to avoid overlap
141+ , AllMimeRender (ctyp' ': ctyps) a
145− , AllMimeRender ctyps a
146 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
142 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
147− amr _ a = (contentType pctyp, toByteString pctyp a)
143+ allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
148− :(contentType pctyp', toByteString pctyp' a)
149− :(amr pctyps a)
144+ :(allMimeRender pctyps a)
150 where pctyp = Proxy :: Proxy ctyp
145 where pctyp = Proxy :: Proxy ctyp
151− pctyps = Proxy :: Proxy ctyps
146+ pctyps = Proxy :: Proxy (ctyp' ': ctyps)
152− pctyp' = Proxy :: Proxy ctyp'
155instance AllMimeRender '[] a where
149instance AllMimeRender '[] a where
156− amr _ _ = []
150+ allMimeRender _ _ = []
158--------------------------------------------------------------------------
152--------------------------------------------------------------------------
159-- Check that all elements of list are instances of MimeUnrender
153-- Check that all elements of list are instances of MimeUnrender
160--------------------------------------------------------------------------
154--------------------------------------------------------------------------
161class AllMimeUnrender ls a where
155class AllMimeUnrender ls a where
162− amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
156+ allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
164−instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
158+instance AllMimeUnrender '[] a where
165− amu _ val = [(contentType pctyp, fromByteString pctyp val)]
159+ allMimeUnrender _ _ = []
166− where pctyp = Proxy :: Proxy ctyp
168instance ( MimeUnrender ctyp a
161instance ( MimeUnrender ctyp a
169− , MimeUnrender ctyp' a
170 , AllMimeUnrender ctyps a
162 , AllMimeUnrender ctyps a
171− ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
163+ ) => AllMimeUnrender (ctyp ': ctyps) a where
172− amu _ val = (contentType pctyp, fromByteString pctyp val)
164+ allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
173− :(contentType pctyp', fromByteString pctyp' val)
174− :(amu pctyps val)
165+ :(allMimeUnrender pctyps val)
175 where pctyp = Proxy :: Proxy ctyp
166 where pctyp = Proxy :: Proxy ctyp
176 pctyps = Proxy :: Proxy ctyps
167 pctyps = Proxy :: Proxy ctyps
177− pctyp' = Proxy :: Proxy ctyp'
179type family IsNonEmpty (ls::[*]) :: Constraint where
169type family IsNonEmpty (ls::[*]) :: Constraint where
180− IsNonEmpty '[] = 'False ~ 'True
170+ IsNonEmpty (x ': xs) = ()