Symantic/HTTP/Server.hs

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