git.iko.soy/servant
on 21667cc help sign in
servant/src/Servant/API/ContentTypes.hs
181 lines 6.4 kB history raw
1{-# 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 #-}
12module Servant.API.ContentTypes where
14import Control.Monad (join)
15import qualified Data.ByteString as BS
16import Data.ByteString.Lazy (ByteString)
17import Data.String.Conversions (cs)
18import Data.Typeable
19import GHC.Exts (Constraint)
20import qualified Network.HTTP.Media as M
22-- * Provided content types
23data XML deriving Typeable
24data HTML deriving Typeable
25data JSON deriving Typeable
26data JavaScript deriving Typeable
27data CSS deriving Typeable
28data PlainText deriving Typeable
29data OctetStream deriving Typeable
31-- * Accept class
33-- | Instances of 'Accept' represent mimetypes. They are used for matching
34-- against the @Accept@ HTTP header of the request, and for setting the
35-- @Content-Type@ header of the response
36--
37-- Example:
38--
39-- > instance Accept HTML where
40-- > contentType _ = "text" // "html"
41--
42class Accept ctype where
43 contentType :: Proxy ctype -> M.MediaType
45-- | @text/html;charset=utf-8@
46instance Accept HTML where
47 contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
49-- | @application/json;charset=utf-8@
50instance Accept JSON where
51 contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
53-- | @application/xml;charset=utf-8@
54instance Accept XML where
55 contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
57-- | @application/javascript;charset=utf-8@
58instance Accept JavaScript where
59 contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
61-- | @text/css;charset=utf-8@
62instance Accept CSS where
63 contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
65-- | @text/plain;charset=utf-8@
66instance Accept PlainText where
67 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
69-- | @application/octet-stream@
70instance Accept OctetStream where
71 contentType _ = "application" M.// "octet-stream"
73newtype AcceptHeader = AcceptHeader BS.ByteString
74 deriving (Eq, Show)
76-- * Render (serializing)
78-- | Instantiate this class to register a way of serializing a type based
79-- on the @Accept@ header.
80--
81-- Example:
82--
83-- > data MyContentType
84-- >
85-- > instance Accept MyContentType where
86-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
87-- >
88-- > instance Show a => MimeRender MyContentType where
89-- > toByteString _ val = pack ("This is MINE! " ++ show val)
90-- >
91-- > type MyAPI = "path" :> Get '[MyContentType] Int
92class Accept ctype => MimeRender ctype a where
93 toByteString :: Proxy ctype -> a -> ByteString
95class AllCTRender list a where
96 -- If the Accept header can be matched, returns (Just) a tuple of the
97 -- Content-Type and response (serialization of @a@ into the appropriate
98 -- mimetype).
99 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
101instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
102 ) => AllCTRender ctyps a where
103 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
104 where pctyps = Proxy :: Proxy ctyps
105 amrs = amr pctyps val
106 lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
111--------------------------------------------------------------------------
112-- * Unrender
113class Accept ctype => MimeUnrender ctype a where
114 fromByteString :: Proxy ctype -> ByteString -> Maybe a
116class AllCTUnrender list a where
117 handleCTypeH :: Proxy list
118 -> ByteString -- Content-Type header
119 -> ByteString -- Request body
120 -> Maybe a
122instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
123 ) => AllCTUnrender ctyps a where
124 handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
125 where lkup = amu (Proxy :: Proxy ctyps) body
127--------------------------------------------------------------------------
128-- * Utils (Internal)
131--------------------------------------------------------------------------
132-- Check that all elements of list are instances of MimeRender
133--------------------------------------------------------------------------
134class AllMimeRender ls a where
135 amr :: Proxy ls
136 -> a -- value to serialize
137 -> [(M.MediaType, ByteString)] -- content-types/response pairs
139instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
140 amr _ a = [(contentType pctyp, toByteString pctyp a)]
141 where pctyp = Proxy :: Proxy ctyp
143instance ( MimeRender ctyp a
144 , MimeRender ctyp' a -- at least two elems to avoid overlap
145 , AllMimeRender ctyps a
146 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
147 amr _ a = (contentType pctyp, toByteString pctyp a)
148 :(contentType pctyp', toByteString pctyp' a)
149 :(amr pctyps a)
150 where pctyp = Proxy :: Proxy ctyp
151 pctyps = Proxy :: Proxy ctyps
152 pctyp' = Proxy :: Proxy ctyp'
155instance AllMimeRender '[] a where
156 amr _ _ = []
158--------------------------------------------------------------------------
159-- Check that all elements of list are instances of MimeUnrender
160--------------------------------------------------------------------------
161class AllMimeUnrender ls a where
162 amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
164instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
165 amu _ val = [(contentType pctyp, fromByteString pctyp val)]
166 where pctyp = Proxy :: Proxy ctyp
168instance ( MimeUnrender ctyp a
169 , MimeUnrender ctyp' a
170 , AllMimeUnrender ctyps a
171 ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
172 amu _ val = (contentType pctyp, fromByteString pctyp val)
173 :(contentType pctyp', fromByteString pctyp' val)
174 :(amu pctyps val)
175 where pctyp = Proxy :: Proxy ctyp
176 pctyps = Proxy :: Proxy ctyps
177 pctyp' = Proxy :: Proxy ctyp'
179type family IsNonEmpty (ls::[*]) :: Constraint where
180 IsNonEmpty '[] = 'False ~ 'True
181 IsNonEmpty x = ()