Symantic/HTTP/Router.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE InstanceSigs #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Symantic.HTTP.Router where
   8
   9 import Control.Arrow (first)
  10 import Control.Monad (Monad(..), unless, sequence)
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
  13 import Data.Bool
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Function (($), (.), id)
  17 import Data.Functor (Functor, (<$>))
  18 import Data.Int (Int)
  19 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
  20 import Data.Proxy (Proxy(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.String (String, IsString(..))
  23 import Data.Text (Text)
  24 import Prelude ((+))
  25 import System.IO (IO)
  26 import Text.Show (Show(..))
  27 import qualified Control.Monad.Classes as MC
  28 import qualified Control.Monad.Trans.State as S
  29 import qualified Data.ByteString.Lazy as BSL
  30 import qualified Data.List as List
  31 import qualified Data.Text.Encoding as Text
  32 import qualified Network.HTTP.Media as Media
  33 import qualified Network.HTTP.Types as HTTP
  34 import qualified Network.Wai as Wai
  35 import qualified Web.HttpApiData as Web
  36
  37 import Symantic.HTTP.API
  38 import Symantic.HTTP.Media
  39 import Symantic.HTTP.Mime
  40
  41 {-
  42 import Debug.Trace
  43 debug msg x = trace (msg<>": "<>show x) x
  44 -}
  45
  46 -- | Convenient alias.
  47 liftIO :: MC.MonadExec IO m => IO a -> m a
  48 liftIO = MC.exec
  49
  50 -- * Type 'RouterAPI'
  51 -- | @RouterAPI f k@ is a recipe to produce an 'Wai.Application'
  52 -- from handlers 'f' (one per number of alternative routes).
  53 --
  54 -- 'RouterAPI' is analogous to a scanf using a format customized for HTTP routing.
  55 --
  56 -- The multiple monad transformers are there to prioritize the errors
  57 -- according to the type of check raising them,
  58 -- instead of the order of the combinators within an actual API specification.
  59 newtype RouterAPI f k = RouterAPI { unRouterAPI ::
  60         S.StateT RouterState
  61          (RouterCheckT [RouterErrorBody]          -- 8th check, 400 error
  62          (RouterCheckT [RouterErrorHeader]        -- 7th check, 400 error
  63          (RouterCheckT [RouterErrorQuery]         -- 6th check, 400 error
  64          (RouterCheckT [RouterErrorContentType]   -- 5th check, 415 error
  65          (RouterCheckT [RouterErrorAccept]        -- 4th check, 406 error
  66          (-- TODO: RouterCheckT [RouterErrorAuth] -- 3rd check, 401 error
  67          (RouterCheckT [RouterErrorMethod]        -- 2nd check, 405 error
  68          (RouterCheckT [RouterErrorPath]          -- 1st check, 404 error
  69          IO)))))))) (f -> k) }
  70  deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
  71 type Offset = Int
  72
  73 runRouterAPI ::
  74  S.StateT RouterState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 IO))))))) a ->
  75  RouterState -> IO (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, RouterState))))))))
  76 runRouterAPI s st =
  77         runExceptT $
  78         runExceptT $
  79         runExceptT $
  80         runExceptT $
  81         runExceptT $
  82         runExceptT $
  83         runExceptT $
  84         S.runStateT s st
  85
  86 -- ** Type 'RouterCheckT'
  87 type RouterCheckT e = ExceptT (Fail e)
  88
  89 -- *** Type 'RouteResult'
  90 type RouteResult e = Either (Fail e)
  91
  92 -- *** Type 'Fail'
  93 data Fail e
  94  =   Fail RouterState e -- ^ Keep trying other paths. 404, 405 or 406.
  95  |   FailFatal !RouterState !e -- ^ Don't try other paths.
  96  deriving (Show)
  97 failState :: Fail e -> RouterState
  98 failState (Fail st _)      = st
  99 failState (FailFatal st _) = st
 100 instance Semigroup e => Semigroup (Fail e) where
 101         Fail _ x      <> Fail st y      = Fail      st (x<>y)
 102         FailFatal _ x <> Fail st y      = FailFatal st (x<>y)
 103         Fail _ x      <> FailFatal st y = FailFatal st (x<>y)
 104         FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
 105
 106 -- ** Type 'RouterState'
 107 data RouterState = RouterState
 108  { routerState_offset  :: Offset
 109  , routerState_request :: Wai.Request
 110  } -- deriving (Show)
 111 instance Show RouterState where
 112         show _ = "RouterState"
 113 instance Cat RouterAPI where
 114         (<.>) ::
 115          forall a b c repr.
 116          repr ~ RouterAPI =>
 117          repr a b -> repr b c -> repr a c
 118         -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
 119         -- And if so, fail with y instead of x.
 120         --
 121         -- This long spaghetti code may probably be avoided
 122         -- with a more sophisticated RouterAPI using a binary tree
 123         -- instead of nested Either, so that its Monad instance
 124         -- would do the right thing, but to my mind,
 125         -- with the very few priorities of checks currently needed,
 126         -- this is currently not worth the cognitive pain to design it.
 127         -- A copy/paste/modify will do for now.
 128         RouterAPI x <.> RouterAPI y = RouterAPI $
 129                 S.StateT $ \st -> do
 130                         xPath <- liftIO $ runRouterAPI x st
 131                         case xPath of
 132                          Left xe -> MC.throw xe
 133                          Right xMethod ->
 134                                 case xMethod of
 135                                  Left xe -> do
 136                                         yPath <- liftIO $ runRouterAPI y (failState xe)
 137                                         case yPath of
 138                                          Left ye -> MC.throw ye
 139                                          Right _yMethod -> MC.throw xe
 140                                  Right xAccept ->
 141                                         case xAccept of
 142                                          Left xe -> do
 143                                                 yPath <- liftIO $ runRouterAPI y (failState xe)
 144                                                 case yPath of
 145                                                  Left ye -> MC.throw ye
 146                                                  Right yMethod ->
 147                                                         case yMethod of
 148                                                          Left ye -> MC.throw ye
 149                                                          Right _yAccept -> MC.throw xe
 150                                          Right xContentType ->
 151                                                 case xContentType of
 152                                                  Left xe -> do
 153                                                         yPath <- liftIO $ runRouterAPI y (failState xe)
 154                                                         case yPath of
 155                                                          Left ye -> MC.throw ye
 156                                                          Right yMethod ->
 157                                                                 case yMethod of
 158                                                                  Left ye -> MC.throw ye
 159                                                                  Right yAccept ->
 160                                                                         case yAccept of
 161                                                                          Left ye -> MC.throw ye
 162                                                                          Right _yQuery -> MC.throw xe
 163                                                  Right xQuery ->
 164                                                         case xQuery of
 165                                                          Left xe -> do
 166                                                                 yPath <- liftIO $ runRouterAPI y (failState xe)
 167                                                                 case yPath of
 168                                                                  Left ye -> MC.throw ye
 169                                                                  Right yMethod ->
 170                                                                         case yMethod of
 171                                                                          Left ye -> MC.throw ye
 172                                                                          Right yAccept ->
 173                                                                                 case yAccept of
 174                                                                                  Left ye -> MC.throw ye
 175                                                                                  Right yQuery ->
 176                                                                                         case yQuery of
 177                                                                                          Left ye -> MC.throw ye
 178                                                                                          Right _yHeader -> MC.throw xe
 179                                                          Right xHeader ->
 180                                                                 case xHeader of
 181                                                                  Left xe -> do
 182                                                                         yPath <- liftIO $ runRouterAPI y (failState xe)
 183                                                                         case yPath of
 184                                                                          Left ye -> MC.throw ye
 185                                                                          Right yMethod ->
 186                                                                                 case yMethod of
 187                                                                                  Left ye -> MC.throw ye
 188                                                                                  Right yAccept ->
 189                                                                                         case yAccept of
 190                                                                                          Left ye -> MC.throw ye
 191                                                                                          Right yQuery ->
 192                                                                                                 case yQuery of
 193                                                                                                  Left ye -> MC.throw ye
 194                                                                                                  Right yHeader ->
 195                                                                                                         case yHeader of
 196                                                                                                          Left ye -> MC.throw ye
 197                                                                                                          Right _yBody -> MC.throw xe
 198                                                                  Right xBody ->
 199                                                                         case xBody of
 200                                                                          Left xe -> do
 201                                                                                 yPath <- liftIO $ runRouterAPI y (failState xe)
 202                                                                                 case yPath of
 203                                                                                  Left ye -> MC.throw ye
 204                                                                                  Right yMethod ->
 205                                                                                         case yMethod of
 206                                                                                          Left ye -> MC.throw ye
 207                                                                                          Right yAccept ->
 208                                                                                                 case yAccept of
 209                                                                                                  Left ye -> MC.throw ye
 210                                                                                                  Right yQuery ->
 211                                                                                                         case yQuery of
 212                                                                                                          Left ye -> MC.throw ye
 213                                                                                                          Right yHeader ->
 214                                                                                                                 case yHeader of
 215                                                                                                                  Left ye -> MC.throw ye
 216                                                                                                                  Right _yBody -> MC.throw xe
 217                                                                          Right (a2b, st') ->
 218                                                                                 (first (. a2b)) <$> S.runStateT y st'
 219 instance Alt RouterAPI where
 220         RouterAPI x <!> RouterAPI y = RouterAPI $
 221                 S.StateT $ \st -> do
 222                         xPath <- liftIO $ runRouterAPI x st
 223                         yPath <- liftIO $ runRouterAPI y st
 224                         let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
 225                         case xPath of
 226                          Left xe | FailFatal{} <- xe -> MC.throw xe
 227                                  | otherwise ->
 228                                 case yPath of
 229                                  Left ye -> MC.throw (xe<>ye)
 230                                  Right yMethod ->
 231                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 232                                                 return $ Right yMethod
 233                          Right xMethod ->
 234                                 case xMethod of
 235                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 236                                          | otherwise ->
 237                                         case yPath of
 238                                          Left _ye -> MC.throw xe
 239                                          Right yMethod ->
 240                                                 case yMethod of
 241                                                  Left ye -> MC.throw (xe<>ye)
 242                                                  Right yAccept ->
 243                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 244                                                                 return $ Right $ yAccept
 245                                  Right xAccept ->
 246                                         case xAccept of
 247                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 248                                                  | otherwise ->
 249                                                 case yPath of
 250                                                  Left _ye -> MC.throw xe
 251                                                  Right yMethod ->
 252                                                         case yMethod of
 253                                                          Left _ye -> MC.throw xe
 254                                                          Right yAccept ->
 255                                                                 case yAccept of
 256                                                                  Left ye -> MC.throw (xe<>ye)
 257                                                                  Right yContentType ->
 258                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 259                                                                                 return $ Right yContentType
 260                                          Right xContentType ->
 261                                                 case xContentType of
 262                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 263                                                          | otherwise ->
 264                                                         case yPath of
 265                                                          Left _ye -> MC.throw xe
 266                                                          Right yMethod ->
 267                                                                 case yMethod of
 268                                                                  Left _ye -> MC.throw xe
 269                                                                  Right yAccept ->
 270                                                                         case yAccept of
 271                                                                          Left _ye -> MC.throw xe
 272                                                                          Right yContentType ->
 273                                                                                 case yContentType of
 274                                                                                  Left ye -> MC.throw (xe<>ye)
 275                                                                                  Right yQuery ->
 276                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 277                                                                                                 return $ Right yQuery
 278                                                  Right xQuery ->
 279                                                         case xQuery of
 280                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 281                                                                  | otherwise ->
 282                                                                 case yPath of
 283                                                                  Left _ye -> MC.throw xe
 284                                                                  Right yMethod ->
 285                                                                         case yMethod of
 286                                                                          Left _ye -> MC.throw xe
 287                                                                          Right yAccept ->
 288                                                                                 case yAccept of
 289                                                                                  Left _ye -> MC.throw xe
 290                                                                                  Right yContentType ->
 291                                                                                         case yContentType of
 292                                                                                          Left _ye -> MC.throw xe
 293                                                                                          Right yQuery ->
 294                                                                                                 case yQuery of
 295                                                                                                  Left ye -> MC.throw (xe<>ye)
 296                                                                                                  Right yHeader ->
 297                                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $
 298                                                                                                                 return $ Right yHeader
 299                                                          Right xHeader ->
 300                                                                 case xHeader of
 301                                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 302                                                                          | otherwise ->
 303                                                                         case yPath of
 304                                                                          Left _ye -> MC.throw xe
 305                                                                          Right yMethod ->
 306                                                                                 case yMethod of
 307                                                                                  Left _ye -> MC.throw xe
 308                                                                                  Right yAccept ->
 309                                                                                         case yAccept of
 310                                                                                          Left _ye -> MC.throw xe
 311                                                                                          Right yContentType ->
 312                                                                                                 case yContentType of
 313                                                                                                  Left _ye -> MC.throw xe
 314                                                                                                  Right yQuery ->
 315                                                                                                         case yQuery of
 316                                                                                                          Left _ye -> MC.throw xe
 317                                                                                                          Right yHeader ->
 318                                                                                                                 case yHeader of
 319                                                                                                                  Left ye -> MC.throw (xe<>ye)
 320                                                                                                                  Right yBody ->
 321                                                                                                                         fy $ ExceptT $ ExceptT $
 322                                                                                                                                 return $ Right yBody
 323                                                                  Right xBody ->
 324                                                                         case xBody of
 325                                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 326                                                                                  | otherwise ->
 327                                                                                 case yPath of
 328                                                                                  Left _ye -> MC.throw xe
 329                                                                                  Right yMethod ->
 330                                                                                         case yMethod of
 331                                                                                          Left _ye -> MC.throw xe
 332                                                                                          Right yAccept ->
 333                                                                                                 case yAccept of
 334                                                                                                  Left _ye -> MC.throw xe
 335                                                                                                  Right yContentType ->
 336                                                                                                         case yContentType of
 337                                                                                                          Left _ye -> MC.throw xe
 338                                                                                                          Right yQuery ->
 339                                                                                                                 case yQuery of
 340                                                                                                                  Left _ye -> MC.throw xe
 341                                                                                                                  Right yHeader ->
 342                                                                                                                         case yHeader of
 343                                                                                                                          Left _ye -> MC.throw xe
 344                                                                                                                          Right yBody ->
 345                                                                                                                                 case yBody of
 346                                                                                                                                  Left ye -> MC.throw (xe<>ye)
 347                                                                                                                                  Right yr ->
 348                                                                                                                                         fy $ ExceptT $
 349                                                                                                                                                 return $ Right yr
 350                                                                          Right xr ->
 351                                                                                 return $ first (\a2k (a:!:_b) -> a2k a) xr
 352
 353 instance Pro RouterAPI where
 354         dimap a2b _b2a (RouterAPI r) = RouterAPI $ (\k b2k -> k (b2k . a2b)) <$> r
 355
 356 -- | @'routerAPI' rt api@ returns a 'Wai.Application'
 357 -- ready to be given to @Warp.run 80@.
 358 routerAPI ::
 359  RouterAPI handlers RouterResponse ->
 360  handlers ->
 361  Wai.Application
 362 routerAPI (RouterAPI api) handlers rq re = do
 363         lrPath <- liftIO $ runRouterAPI api (RouterState 0 rq)
 364         case lrPath of
 365          Left err -> respondError status404 err
 366          Right lrMethod ->
 367                 case lrMethod of
 368                  Left err -> respondError status405 err
 369                  Right lrAccept ->
 370                         case lrAccept of
 371                          Left err -> respondError status406 err
 372                          Right lrContentType ->
 373                                 case lrContentType of
 374                                  Left err -> respondError status415 err
 375                                  Right lrQuery ->
 376                                         case lrQuery of
 377                                          Left err -> respondError status400 err
 378                                          Right lrHeader ->
 379                                                 case lrHeader of
 380                                                  Left err -> respondError status400 err
 381                                                  Right lrBody ->
 382                                                         case lrBody of
 383                                                          Left err -> respondError status400 err
 384                                                          Right (a2k, _st) ->
 385                                                                 let RouterResponse app = a2k handlers in app rq re
 386         where
 387         respondError :: Show err => HTTP.Status -> err -> IO Wai.ResponseReceived
 388         respondError st err =
 389                 re $ Wai.responseLBS st
 390                  [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
 391                  (fromString $ show err)
 392
 393 -- ** Type 'RouterErrorPath'
 394 data RouterErrorPath = RouterErrorPath Offset Text
 395  deriving (Eq, Show)
 396 instance HTTP_Path RouterAPI where
 397         segment expSegment = RouterAPI $ do
 398                 st@RouterState
 399                  { routerState_offset  = o
 400                  , routerState_request = req
 401                  } <- S.get
 402                 case Wai.pathInfo req of
 403                  [] -> MC.throw $ Fail st [RouterErrorPath o "segment: empty"]
 404                  [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
 405                  curr:next
 406                   | curr /= expSegment ->
 407                         MC.throw $ Fail st [RouterErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
 408                   | otherwise -> do
 409                         S.put st
 410                          { routerState_offset  = o+1
 411                          , routerState_request = req{ Wai.pathInfo = next }
 412                          }
 413                         return id
 414         capture' :: forall a k.
 415                     Web.FromHttpApiData a =>
 416                     Web.ToHttpApiData a =>
 417                     Name -> RouterAPI (a -> k) k
 418         capture' name = RouterAPI $ do
 419                 st@RouterState
 420                  { routerState_offset  = o
 421                  , routerState_request = req
 422                  } <- S.get
 423                 case Wai.pathInfo req of
 424                  [] -> MC.throw $ Fail st [RouterErrorPath o "empty"]
 425                  [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
 426                  curr:next ->
 427                         case Web.parseUrlPiece curr of
 428                          Left err -> MC.throw $ Fail st [RouterErrorPath o $ "capture: "<>fromString name<>": "<>err]
 429                          Right a -> do
 430                                 S.put st
 431                                  { routerState_offset  = o+1
 432                                  , routerState_request = req{ Wai.pathInfo = next }
 433                                  }
 434                                 return ($ a)
 435         captureAll = RouterAPI $ do
 436                 req <- S.gets routerState_request
 437                 return ($ Wai.pathInfo req)
 438
 439 -- ** Type 'RouterErrorMethod'
 440 data RouterErrorMethod = RouterErrorMethod
 441  deriving (Eq, Show)
 442 instance HTTP_Method RouterAPI where
 443         method exp = RouterAPI $ do
 444                 st <- S.get
 445                 let got = Wai.requestMethod $ routerState_request st
 446                 if  got == exp
 447                  || got == HTTP.methodHead
 448                  && exp == HTTP.methodGet
 449                 then return id
 450                 else MC.throw $ Fail st [RouterErrorMethod]
 451
 452 -- | TODO: add its own error?
 453 instance HTTP_Version RouterAPI where
 454         version exp = RouterAPI $ do
 455                 st <- S.get
 456                 let got = Wai.httpVersion $ routerState_request st
 457                 if got == exp
 458                  then return id
 459                  else MC.throw $ Fail st [RouterErrorMethod] -- FIXME: RouterErrorVersion
 460
 461 -- ** Type 'RouterErrorAccept'
 462 data RouterErrorAccept = RouterErrorAccept
 463  deriving (Eq, Show)
 464 instance HTTP_Accept RouterAPI where
 465         accept exp = RouterAPI $ do
 466                 st <- S.get
 467                 let hs = Wai.requestHeaders $ routerState_request st
 468                 case List.lookup HTTP.hAccept hs of
 469                  Nothing -> MC.throw $ Fail st [RouterErrorAccept]
 470                  Just h ->
 471                         case Media.parseAccept h of
 472                          Nothing -> MC.throw $ Fail st [RouterErrorAccept]
 473                          Just got | mediaType exp`Media.matches`got -> return id
 474                                   | otherwise -> MC.throw $ Fail st [RouterErrorAccept]
 475
 476 -- ** Type 'RouterErrorContentType'
 477 data RouterErrorContentType = RouterErrorContentType
 478  deriving (Eq, Show)
 479 instance HTTP_ContentType RouterAPI where
 480         contentType exp = RouterAPI $ do
 481                 st <- S.get
 482                 let hs = Wai.requestHeaders $ routerState_request st
 483                 let got =
 484                         -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 485                         -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 486                         fromMaybe "application/octet-stream" $
 487                         List.lookup HTTP.hContentType hs
 488                 case Media.mapContentMedia [(mediaType exp, ())] got of
 489                  Nothing -> MC.throw $ Fail st [RouterErrorContentType]
 490                  Just () -> return id -- TODO: mimeUnserialize
 491
 492 -- ** Type 'RouterErrorQuery'
 493 newtype RouterErrorQuery = RouterErrorQuery Text
 494  deriving (Show)
 495 instance HTTP_Query RouterAPI where
 496         queryParams' name = RouterAPI $ do
 497                 st <- S.get
 498                 lift $ ExceptT $ ExceptT $ ExceptT $ return $
 499                         let qs = Wai.queryString $ routerState_request st in
 500                         let vals = catMaybes $ (<$> qs) $ \(n,v) ->
 501                                 if n == name
 502                                  then Web.parseQueryParam . Text.decodeUtf8 <$> v
 503                                  else Nothing in
 504                         case sequence vals of
 505                          Left err -> Left  $ Fail st [RouterErrorQuery err]
 506                          Right vs -> Right $ Right $ Right ($ vs)
 507
 508 -- ** Type 'RouterErrorHeader'
 509 data RouterErrorHeader = RouterErrorHeader
 510  deriving (Eq, Show)
 511 instance HTTP_Header RouterAPI where
 512         header n = RouterAPI $ do
 513                 st <- S.get
 514                 lift $ ExceptT $ ExceptT $ return $
 515                         let hs = Wai.requestHeaders $ routerState_request st in
 516                         case List.lookup n hs of
 517                          Nothing -> Left $ Fail st [RouterErrorHeader]
 518                          Just v -> Right $ Right ($ v)
 519
 520 -- ** Type 'RouterErrorBody'
 521 newtype RouterErrorBody = RouterErrorBody String
 522  deriving (Eq, Show)
 523 -- *** Type 'RouterBodyArg'
 524 newtype RouterBodyArg mt a = RouterBodyArg a
 525
 526 instance HTTP_Body RouterAPI where
 527         type BodyArg RouterAPI = RouterBodyArg
 528         body' ::
 529          forall mt a k repr.
 530          MimeUnserialize mt a =>
 531          MimeSerialize mt a =>
 532          repr ~ RouterAPI =>
 533          repr (BodyArg repr mt a -> k) k
 534         body'= RouterAPI $ do
 535                 st <- S.get
 536                 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
 537                         let hs = Wai.requestHeaders $ routerState_request st
 538                         let expContentType = (Proxy::Proxy mt)
 539                         let reqContentType =
 540                                 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 541                                 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 542                                 fromMaybe "application/octet-stream" $
 543                                 List.lookup HTTP.hContentType hs
 544                         case Media.mapContentMedia
 545                          [ ( mediaType       expContentType
 546                            , mimeUnserialize expContentType )
 547                          ] reqContentType of
 548                          Nothing -> return $ Left $ Fail st [RouterErrorContentType]
 549                          Just unSerialize -> do
 550                                 bodyBS <- liftIO $ Wai.requestBody $ routerState_request st
 551                                 return $ Right $ Right $ Right $
 552                                         -- NOTE: delay unSerialize after all checks
 553                                         case unSerialize $ BSL.fromStrict bodyBS of
 554                                          Left err -> Left $ Fail st [RouterErrorBody err]
 555                                          Right a -> Right ($ RouterBodyArg a)
 556
 557 -- ** Type 'RouterResponse'
 558 newtype RouterResponse = RouterResponse
 559  ( -- the request made to the router
 560    Wai.Request ->
 561    -- the continuation for the router to respond
 562    (Wai.Response -> IO Wai.ResponseReceived) ->
 563    IO Wai.ResponseReceived
 564  )
 565 instance Show RouterResponse where
 566         show _ = "RouterResponse"
 567
 568 -- *** Type 'RouterResponseArg'
 569 newtype RouterResponseArg mt a = RouterResponseArg
 570  (HTTP.Status ->
 571   HTTP.ResponseHeaders ->
 572   a -> Wai.Response)
 573
 574 instance HTTP_Response RouterAPI where
 575         type Response    RouterAPI = RouterResponse
 576         type ResponseArg RouterAPI = RouterResponseArg
 577         response' ::
 578          forall mt a k repr.
 579          MimeUnserialize mt a =>
 580          MimeSerialize mt a =>
 581          k ~ Response repr =>
 582          repr ~ RouterAPI =>
 583          HTTP.Method ->
 584          repr (ResponseArg repr mt a -> k) k
 585         response' expMethod = RouterAPI $ do
 586                 st <- S.get
 587                 let reqMethod = Wai.requestMethod $ routerState_request st
 588                 unless (reqMethod == expMethod
 589                  || reqMethod == HTTP.methodHead
 590                  && expMethod == HTTP.methodGet) $
 591                         MC.throw $ Fail st [RouterErrorMethod]
 592
 593                 let reqHeaders = Wai.requestHeaders $ routerState_request st
 594                 let expAccept = (Proxy::Proxy mt)
 595                 reqAccept <- do
 596                         case List.lookup HTTP.hAccept reqHeaders of
 597                          Nothing -> MC.throw $ Fail st [RouterErrorAccept]
 598                          Just h ->
 599                                 case Media.parseAccept h of
 600                                  Nothing -> MC.throw $ Fail st [RouterErrorAccept]
 601                                  Just got | mediaType expAccept`Media.matches`got ->
 602                                         return expAccept -- FIXME: return got, maybe with GADTs
 603                                           | otherwise -> MC.throw $ Fail st [RouterErrorAccept]
 604
 605                 return ($ RouterResponseArg $ \s hs a ->
 606                         Wai.responseLBS s
 607                          ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
 608                          (if reqMethod == HTTP.methodHead
 609                                 then ""
 610                                 else mimeSerialize reqAccept a))