git.iko.soy/servant
on a75c723 help sign in
servant/src/Servant/API/ContentTypes.hs
182 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 Data.Typeable
16import Control.Monad (join)
17import qualified Data.ByteString as BS
18import Data.ByteString.Lazy (ByteString)
19import Data.String.Conversions (cs)
20import GHC.Exts (Constraint)
21import qualified Network.HTTP.Media as M
23-- * Provided content types
24data XML deriving Typeable
25data HTML deriving Typeable
26data JSON deriving Typeable
27data JavaScript deriving Typeable
28data CSS deriving Typeable
29data PlainText deriving Typeable
30data OctetStream deriving Typeable
32-- * Accept class
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--
43class Accept ctype where
44 contentType :: Proxy ctype -> M.MediaType
46-- | @text/html;charset=utf-8@
47instance Accept HTML where
48 contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
50-- | @application/json;charset=utf-8@
51instance Accept JSON where
52 contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
54-- | @application/xml;charset=utf-8@
55instance Accept XML where
56 contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
58-- | @application/javascript;charset=utf-8@
59instance Accept JavaScript where
60 contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
62-- | @text/css;charset=utf-8@
63instance Accept CSS where
64 contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
66-- | @text/plain;charset=utf-8@
67instance Accept PlainText where
68 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
70-- | @application/octet-stream@
71instance Accept OctetStream where
72 contentType _ = "application" M.// "octet-stream"
74newtype AcceptHeader = AcceptHeader BS.ByteString
75 deriving (Eq, Show)
77-- * Render (serializing)
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
93class Accept ctype => MimeRender ctype a where
94 toByteString :: Proxy ctype -> a -> ByteString
96class 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)
102instance ( 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
112--------------------------------------------------------------------------
113-- * Unrender
114class Accept ctype => MimeUnrender ctype a where
115 fromByteString :: Proxy ctype -> ByteString -> Maybe a
117class AllCTUnrender list a where
118 handleCTypeH :: Proxy list
119 -> ByteString -- Content-Type header
120 -> ByteString -- Request body
121 -> Maybe a
123instance ( 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
128--------------------------------------------------------------------------
129-- * Utils (Internal)
132--------------------------------------------------------------------------
133-- Check that all elements of list are instances of MimeRender
134--------------------------------------------------------------------------
135class AllMimeRender ls a where
136 amr :: Proxy ls
137 -> a -- value to serialize
138 -> [(M.MediaType, ByteString)] -- content-types/response pairs
140instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
141 amr _ a = [(contentType pctyp, toByteString pctyp a)]
142 where pctyp = Proxy :: Proxy ctyp
144instance ( 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'
156instance AllMimeRender '[] a where
157 amr _ _ = []
159--------------------------------------------------------------------------
160-- Check that all elements of list are instances of MimeUnrender
161--------------------------------------------------------------------------
162class AllMimeUnrender ls a where
163 amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
165instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
166 amu _ val = [(contentType pctyp, fromByteString pctyp val)]
167 where pctyp = Proxy :: Proxy ctyp
169instance ( 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'
180type family IsNonEmpty (ls::[*]) :: Constraint where
181 IsNonEmpty '[] = 'False ~ 'True
182 IsNonEmpty x = ()