Symantic/HTTP/Mime/Type.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE KindSignatures #-}
   4 {-# LANGUAGE DataKinds #-}
   5 {-# LANGUAGE GADTs #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE TypeApplications #-}
   8 {-# LANGUAGE TypeOperators #-}
   9 module Symantic.HTTP.Mime.Type where
  10
  11 -- import Text.Show (Show(..))
  12 import Data.Function (($))
  13 import Data.Functor ((<$>))
  14 import Data.Kind (Constraint)
  15 import Data.Maybe (Maybe(..))
  16 import Data.Proxy (Proxy(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Tuple (fst, snd)
  19 import Data.Typeable (Typeable)
  20 import qualified Data.ByteString as BS
  21 import qualified Network.HTTP.Media as Media
  22
  23 -- * Class 'MediaTypeable'
  24 class MediaTypeable mt where
  25         mediaType  :: Proxy mt -> MediaType
  26         mediaTypes :: Proxy mt -> [MediaType]
  27         mediaTypes mt = [mediaType mt]
  28 type MediaType = Media.MediaType
  29 instance MediaTypeable () where
  30         mediaType _mt = mimeAny
  31
  32 charsetUTF8 :: MediaType -> MediaType
  33 charsetUTF8 = (Media./: ("charset", "utf-8"))
  34
  35 mimeAny :: MediaType
  36 mimeAny = "*/*"
  37
  38 -- ** Type 'JSON'
  39 data JSON deriving (Typeable)
  40 instance MediaTypeable JSON where
  41         mediaType _mt = charsetUTF8 $ "application"Media.//"json"
  42         mediaTypes mt = [mediaType mt, "application"Media.//"json"]
  43
  44 -- ** Type 'HTML'
  45 data HTML
  46 mimeHTML :: Proxy HTML
  47 mimeHTML = Proxy
  48 instance MediaTypeable HTML where
  49         mediaType _mt = charsetUTF8 $ "text"Media.//"html"
  50         mediaTypes mt = [mediaType mt, "text"Media.//"html"]
  51
  52 -- ** Type 'FormUrlEncoded'
  53 data FormUrlEncoded
  54 mimeFormUrlEncoded :: Proxy FormUrlEncoded
  55 mimeFormUrlEncoded = Proxy
  56 instance MediaTypeable FormUrlEncoded where
  57         mediaType _mt = "application"Media.//"x-www-form-urlencoded"
  58
  59 -- ** Type 'OctetStream'
  60 data OctetStream
  61 mimeOctetStream :: Proxy OctetStream
  62 mimeOctetStream = Proxy
  63 instance MediaTypeable OctetStream where
  64         mediaType _mt = "application"Media.//"octet-stream"
  65
  66 -- ** Type 'PlainText'
  67 data PlainText
  68 mimePlainText :: Proxy PlainText
  69 mimePlainText = Proxy
  70 instance MediaTypeable PlainText where
  71         mediaType _mt = charsetUTF8 $ "text"Media.//"plain"
  72
  73
  74 -- * Type 'MimeType'
  75 data MimeType c where
  76         MimeType :: c t => Proxy t -> MimeType c
  77
  78 -- ** Type 'MimeTypeT'
  79 data MimeTypeT = forall t. MimeTypeT (MimeType t)
  80
  81 -- * Class 'MimeTypes'
  82 class MimeTypes (ts::[*]) (c:: * -> Constraint) where
  83         mimeTypesMap :: [(MediaType, MimeType c)]
  84          -- TODO: Map
  85 instance
  86  (MediaTypeable t, c t) =>
  87  MimeTypes '[t] c where
  88         mimeTypesMap =
  89          [ (t, MimeType @c @t Proxy)
  90          | t <- mediaTypes (Proxy @t)
  91          ]
  92 instance
  93  ( MediaTypeable t
  94  , MediaTypeable t1
  95  , MimeTypes ts c
  96  , c t
  97  , c t1
  98  ) =>
  99  MimeTypes (t ': t1 ': ts) c where
 100         mimeTypesMap =
 101          [ (t, MimeType @c @t Proxy)
 102          | t <- mediaTypes (Proxy @t)
 103          ] <>
 104          [ (t, MimeType @c @t1 Proxy)
 105          | t <- mediaTypes (Proxy @t1)
 106          ] <> mimeTypesMap @ts @c
 107
 108 listMediaTypes :: forall ts c. MimeTypes ts c => [MediaType]
 109 listMediaTypes = fst <$> mimeTypesMap @ts @c
 110
 111 listMimeTypes :: forall ts c. MimeTypes ts c => [MimeType c]
 112 listMimeTypes = snd <$> mimeTypesMap @ts @c
 113
 114 matchAccept ::
 115  forall ts c. MimeTypes ts c =>
 116  BS.ByteString -> Maybe (MimeType c)
 117 matchAccept = Media.mapAccept (mimeTypesMap @ts @c)
 118
 119 matchContent ::
 120  forall ts c. MimeTypes ts c =>
 121  BS.ByteString -> Maybe (MimeType c)
 122 matchContent = Media.mapContent (mimeTypesMap @ts @c)
 123
 124 {-
 125 class MediaTypeable t where
 126         mimeTypeParse :: BS.ByteString -> Maybe (MimeType t)
 127
 128 -- parseAccept :: Proxy ts -> BS.ByteString -> Maybe (MimeTypeIn ts t)
 129
 130 -- mimeDecode :: Proxy mt -> Unserializer a
 131 -- * Class 'MimeTypesInj'
 132 type MimeTypesInj  ts
 133  =   MimeTypesInjR ts ts
 134
 135 mimeTypeInj ::
 136  forall ts.
 137  MimeTypesInj ts =>
 138  Either Error_MimeType (MimeTypes ts)
 139 mimeTypeInj = mimeTypeInjR @_ @ts
 140
 141 -- ** Class 'MimeTypesInjR'
 142 class MimeTypesInjR (ts::[*]) (rs::[*]) where
 143         mimeTypeInjR :: Either Error_MimeType (MimeTypes ts)
 144 instance MimeTypesInjR ts '[] where
 145         mimeTypeInjR = Right $ MimeTypes mempty
 146 instance ( MimeTypeFor ts t
 147          , MimeTypesInjR ts rs
 148          ) => MimeTypesInjR ts (Proxy t ': rs) where
 149         mimeTypeInjR = do
 150                 x <- mimeTypeInjR @_ @rs
 151                 let (n, m) = moduleFor @_  @t
 152                 MimeTypes (Map.singleton n m) `unionMimeTypes` x
 153
 154 -}
 155 {-
 156 MimeType ss s
 157
 158 -- | Return the position of a type within a list of them.
 159 -- This is useful to work around @OverlappingInstances@.
 160 type family Index xs x where
 161         Index (x     ': xs) x = Zero
 162         Index (not_x ': xs) x = Succ (Index xs x)
 163
 164 -- ** Type 'MimeTypeInj'
 165 -- | Convenient type synonym wrapping 'MimeTypePInj'
 166 -- applied on the correct 'Index'.
 167 type MimeTypeInj ss s = MimeTypeInjP (Index ss (Proxy s)) ss s
 168
 169 -- | Inject a given /symantic/ @s@ into a list of them,
 170 -- by returning a function which given a 'TeMimeType' on @s@
 171 -- returns the same 'TeMimeType' on @ss@.
 172 mimeTypeInj ::
 173  forall s ss.
 174  MimeTypeInj ss s =>
 175  MimeType '[Proxy s] ->
 176  MimeType ss
 177 mimeTypeInj = mimeTypeInjP @(Index ss (Proxy s))
 178
 179 -- *** Class 'MimeTypePInj'
 180 class MimeTypeInjP p ss s where
 181         mimeTypeInjP :: MimeType '[Proxy s] -> MimeType ss
 182 instance MimeTypeInjP Zero (Proxy s ': ss) (s::k) where
 183         mimeTypeInjP (MimeType te) = MimeType te
 184 instance MimeTypeInjP p ss s => MimeTypeInjP (Succ p) (Proxy not_s ': ss) s where
 185         mimeTypeInjP (te::MimeType '[Proxy s]) =
 186                 case mimeTypeInjP @p te :: MimeType ss of
 187                  MimeType te' -> MimeType te'
 188 -}