@@ -1,9 +1,26 @@
11{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
212module Servant.API.ContentTypes where
313
4−import Data.Typeable
14+import Data.Typeable
515
16+import Control.Monad (join)
17+import qualified Data.ByteString as BS
18+import Data.ByteString.Lazy (ByteString)
19+import Data.String.Conversions (cs)
20+import GHC.Exts (Constraint)
21+import qualified Network.HTTP.Media as M
622
23+-- * Provided content types
724data XML deriving Typeable
825data HTML deriving Typeable
926data JSON deriving Typeable
@@ -11,3 +28,155 @@ data JavaScript deriving Typeable
1128data CSS deriving Typeable
1229data PlainText deriving Typeable
1330data OctetStream deriving Typeable
31+
32+-- * Accept class
33+
34+-- | Instances of 'Accept' represent mimetypes. They are used for matching
35+-- against the @Accept@ HTTP header of the request, and for setting the
36+-- @Content-Type@ header of the response
37+--
38+-- Example:
39+--
40+-- > instance Accept HTML where
41+-- > contentType _ = "text" // "html"
42+--
43+class Accept ctype where
44+ contentType :: Proxy ctype -> M.MediaType
45+
46+-- | @text/html;charset=utf-8@
47+instance Accept HTML where
48+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
49+
50+-- | @application/json;charset=utf-8@
51+instance Accept JSON where
52+ contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
53+
54+-- | @application/xml;charset=utf-8@
55+instance Accept XML where
56+ contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
57+
58+-- | @application/javascript;charset=utf-8@
59+instance Accept JavaScript where
60+ contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
61+
62+-- | @text/css;charset=utf-8@
63+instance Accept CSS where
64+ contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
65+
66+-- | @text/plain;charset=utf-8@
67+instance Accept PlainText where
68+ contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
69+
70+-- | @application/octet-stream@
71+instance Accept OctetStream where
72+ contentType _ = "application" M.// "octet-stream"
73+
74+newtype AcceptHeader = AcceptHeader BS.ByteString
75+ deriving (Eq, Show)
76+
77+-- * Render (serializing)
78+
79+-- | Instantiate this class to register a way of serializing a type based
80+-- on the @Accept@ header.
81+--
82+-- Example:
83+--
84+-- > data MyContentType
85+-- >
86+-- > instance Accept MyContentType where
87+-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
88+-- >
89+-- > instance Show a => MimeRender MyContentType where
90+-- > toByteString _ val = pack ("This is MINE! " ++ show val)
91+-- >
92+-- > type MyAPI = "path" :> Get '[MyContentType] Int
93+class Accept ctype => MimeRender ctype a where
94+ toByteString :: Proxy ctype -> a -> ByteString
95+
96+class AllCTRender list a where
97+ -- If the Accept header can be matched, returns (Just) a tuple of the
98+ -- Content-Type and response (serialization of @a@ into the appropriate
99+ -- mimetype).
100+ handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
101+
102+instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
103+ ) => AllCTRender ctyps a where
104+ handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
105+ where pctyps = Proxy :: Proxy ctyps
106+ amrs = amr pctyps val
107+ lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
108+
109+
110+
111+
112+--------------------------------------------------------------------------
113+-- * Unrender
114+class Accept ctype => MimeUnrender ctype a where
115+ fromByteString :: Proxy ctype -> ByteString -> Maybe a
116+
117+class AllCTUnrender list a where
118+ handleCTypeH :: Proxy list
119+ -> ByteString -- Content-Type header
120+ -> ByteString -- Request body
121+ -> Maybe a
122+
123+instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
124+ ) => AllCTUnrender ctyps a where
125+ handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
126+ where lkup = amu (Proxy :: Proxy ctyps) body
127+
128+--------------------------------------------------------------------------
129+-- * Utils (Internal)
130+
131+
132+--------------------------------------------------------------------------
133+-- Check that all elements of list are instances of MimeRender
134+--------------------------------------------------------------------------
135+class AllMimeRender ls a where
136+ amr :: Proxy ls
137+ -> a -- value to serialize
138+ -> [(M.MediaType, ByteString)] -- content-types/response pairs
139+
140+instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
141+ amr _ a = [(contentType pctyp, toByteString pctyp a)]
142+ where pctyp = Proxy :: Proxy ctyp
143+
144+instance ( MimeRender ctyp a
145+ , MimeRender ctyp' a -- at least two elems to avoid overlap
146+ , AllMimeRender ctyps a
147+ ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
148+ amr _ a = (contentType pctyp, toByteString pctyp a)
149+ :(contentType pctyp', toByteString pctyp' a)
150+ :(amr pctyps a)
151+ where pctyp = Proxy :: Proxy ctyp
152+ pctyps = Proxy :: Proxy ctyps
153+ pctyp' = Proxy :: Proxy ctyp'
154+
155+
156+instance AllMimeRender '[] a where
157+ amr _ _ = []
158+
159+--------------------------------------------------------------------------
160+-- Check that all elements of list are instances of MimeUnrender
161+--------------------------------------------------------------------------
162+class AllMimeUnrender ls a where
163+ amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
164+
165+instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
166+ amu _ val = [(contentType pctyp, fromByteString pctyp val)]
167+ where pctyp = Proxy :: Proxy ctyp
168+
169+instance ( MimeUnrender ctyp a
170+ , MimeUnrender ctyp' a
171+ , AllMimeUnrender ctyps a
172+ ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
173+ amu _ val = (contentType pctyp, fromByteString pctyp val)
174+ :(contentType pctyp', fromByteString pctyp' val)
175+ :(amu pctyps val)
176+ where pctyp = Proxy :: Proxy ctyp
177+ pctyps = Proxy :: Proxy ctyps
178+ pctyp' = Proxy :: Proxy ctyp'
179+
180+type family IsNonEmpty (ls::[*]) :: Constraint where
181+ IsNonEmpty '[] = 'False ~ 'True
182+ IsNonEmpty x = ()