git.iko.soy/servant
on ebc2660 help sign in
servant/src/Servant/API/ContentTypes.hs
170 lines 6.1 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 qualified Data.ByteString as BS
15import Data.ByteString.Lazy (ByteString)
16import Data.String.Conversions (cs)
17import Data.Typeable
18import GHC.Exts (Constraint)
19import qualified Network.HTTP.Media as M
21-- * Provided content types
22data XML deriving Typeable
23data HTML deriving Typeable
24data JSON deriving Typeable
25data JavaScript deriving Typeable
26data CSS deriving Typeable
27data PlainText deriving Typeable
28data OctetStream deriving Typeable
30-- * Accept class
32-- | Instances of 'Accept' represent mimetypes. They are used for matching
33-- against the @Accept@ HTTP header of the request, and for setting the
34-- @Content-Type@ header of the response
35--
36-- Example:
37--
38-- > instance Accept HTML where
39-- > contentType _ = "text" // "html"
40--
41class Accept ctype where
42 contentType :: Proxy ctype -> M.MediaType
44-- | @text/html;charset=utf-8@
45instance Accept HTML where
46 contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
48-- | @application/json;charset=utf-8@
49instance Accept JSON where
50 contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
52-- | @application/xml;charset=utf-8@
53instance Accept XML where
54 contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
56-- | @application/javascript;charset=utf-8@
57instance Accept JavaScript where
58 contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
60-- | @text/css;charset=utf-8@
61instance Accept CSS where
62 contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
64-- | @text/plain;charset=utf-8@
65instance Accept PlainText where
66 contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
68-- | @application/octet-stream@
69instance Accept OctetStream where
70 contentType _ = "application" M.// "octet-stream"
72newtype AcceptHeader = AcceptHeader BS.ByteString
73 deriving (Eq, Show)
75-- * Render (serializing)
77-- | Instantiate this class to register a way of serializing a type based
78-- on the @Accept@ header.
79--
80-- Example:
81--
82-- > data MyContentType
83-- >
84-- > instance Accept MyContentType where
85-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
86-- >
87-- > instance Show a => MimeRender MyContentType where
88-- > toByteString _ val = pack ("This is MINE! " ++ show val)
89-- >
90-- > type MyAPI = "path" :> Get '[MyContentType] Int
91class Accept ctype => MimeRender ctype a where
92 toByteString :: Proxy ctype -> a -> ByteString
94class AllCTRender list a where
95 -- If the Accept header can be matched, returns (Just) a tuple of the
96 -- Content-Type and response (serialization of @a@ into the appropriate
97 -- mimetype).
98 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
100instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
101 ) => AllCTRender ctyps a where
102 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
103 where pctyps = Proxy :: Proxy ctyps
104 amrs = allMimeRender pctyps val
105 lkup = fmap (\(a,b) -> (a, (cs $ show a, b))) amrs
108--------------------------------------------------------------------------
109-- * Unrender
110class Accept ctype => MimeUnrender ctype a where
111 fromByteString :: Proxy ctype -> ByteString -> Either String a
113class (IsNonEmpty list) => AllCTUnrender list a where
114 handleCTypeH :: Proxy list
115 -> ByteString -- Content-Type header
116 -> ByteString -- Request body
117 -> Maybe (Either String a)
119instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
120 ) => AllCTUnrender ctyps a where
121 handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
122 where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
124--------------------------------------------------------------------------
125-- * Utils (Internal)
128--------------------------------------------------------------------------
129-- Check that all elements of list are instances of MimeRender
130--------------------------------------------------------------------------
131class AllMimeRender ls a where
132 allMimeRender :: Proxy ls
133 -> a -- value to serialize
134 -> [(M.MediaType, ByteString)] -- content-types/response pairs
136instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
137 allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)]
138 where pctyp = Proxy :: Proxy ctyp
140instance ( MimeRender ctyp a
141 , AllMimeRender (ctyp' ': ctyps) a
142 ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
143 allMimeRender _ a = (contentType pctyp, toByteString pctyp a)
144 :(allMimeRender pctyps a)
145 where pctyp = Proxy :: Proxy ctyp
146 pctyps = Proxy :: Proxy (ctyp' ': ctyps)
149instance AllMimeRender '[] a where
150 allMimeRender _ _ = []
152--------------------------------------------------------------------------
153-- Check that all elements of list are instances of MimeUnrender
154--------------------------------------------------------------------------
155class AllMimeUnrender ls a where
156 allMimeUnrender :: Proxy ls -> ByteString -> [(M.MediaType, Either String a)]
158instance AllMimeUnrender '[] a where
159 allMimeUnrender _ _ = []
161instance ( MimeUnrender ctyp a
162 , AllMimeUnrender ctyps a
163 ) => AllMimeUnrender (ctyp ': ctyps) a where
164 allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val)
165 :(allMimeUnrender pctyps val)
166 where pctyp = Proxy :: Proxy ctyp
167 pctyps = Proxy :: Proxy ctyps
169type family IsNonEmpty (ls::[*]) :: Constraint where
170 IsNonEmpty (x ': xs) = ()