Symantic/HTTP/Server.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE ConstraintKinds #-}
   5 {-# LANGUAGE DeriveFunctor #-}
   6 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   7 {-# LANGUAGE InstanceSigs #-}
   8 {-# LANGUAGE OverloadedStrings #-}
   9 {-# LANGUAGE Rank2Types #-}
  10 {-# LANGUAGE TypeApplications #-}
  11 {-# LANGUAGE TypeFamilies #-}
  12 {-# LANGUAGE TypeOperators #-}
  13 module Symantic.HTTP.Server where
  14
  15 import Control.Arrow (first)
  16 import Control.Monad (Monad(..), unless, sequence, guard)
  17 import Control.Monad.Trans.Class (MonadTrans(..))
  18 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
  19 import Data.Bool
  20 import Data.Either (Either(..))
  21 import Data.Eq (Eq(..))
  22 import Data.Function (($), (.), id)
  23 import Data.Functor (Functor, (<$>))
  24 import Data.Int (Int)
  25 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.String (String, IsString(..))
  28 import Data.Text (Text)
  29 import Prelude ((+))
  30 import System.IO (IO)
  31 import Text.Show (Show(..))
  32 import qualified Control.Monad.Classes as MC
  33 import qualified Control.Monad.Trans.State as S
  34 import qualified Data.ByteString as BS
  35 import qualified Data.ByteString.Base64 as BS64
  36 import qualified Data.ByteString.Lazy as BSL
  37 import qualified Data.List as List
  38 import qualified Data.Text.Encoding as Text
  39 import qualified Data.Word8 as Word8
  40 import qualified Network.HTTP.Media as Media
  41 import qualified Network.HTTP.Types as HTTP
  42 import qualified Network.HTTP.Types.Header as HTTP
  43 import qualified Network.Wai as Wai
  44 import qualified Web.HttpApiData as Web
  45
  46 import Symantic.HTTP.API
  47 import Symantic.HTTP.Mime
  48
  49 -- * Type 'Server'
  50 -- | @Server f k@ is a recipe to produce an 'Wai.Application'
  51 -- from handlers 'f' (one per number of alternative routes).
  52 --
  53 -- 'Server' is analogous to a scanf using a format customized for HTTP routing.
  54 --
  55 -- The multiple monad transformers are there to prioritize the errors
  56 -- according to the type of check raising them,
  57 -- instead of the order of the combinators within an actual API specification.
  58 newtype Server f k = Server { unServer ::
  59         S.StateT ServerState
  60          (ServerCheckT [ServerErrorBody]        -- 8th check, 400 error
  61          (ServerCheckT [ServerErrorHeader]      -- 7th check, 400 error
  62          (ServerCheckT [ServerErrorQuery]       -- 6th check, 400 error
  63          (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
  64          (ServerCheckT [ServerErrorAccept]      -- 4th check, 406 error
  65          (ServerCheckT [ServerErrorBasicAuth]   -- 3rd check, 401 error
  66          (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error
  67          (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error
  68          IO))))))))
  69          (f -> k)
  70  } deriving (Functor)
  71
  72 -- | @'server' api handlers@ returns a 'Wai.Application'
  73 -- ready to be given to @Warp.run 80@.
  74 server ::
  75  Server handlers ServerResponse ->
  76  handlers ->
  77  Wai.Application
  78 server (Server api) handlers rq re = do
  79         lrPath <- runServerChecks api $ ServerState 0 rq
  80         case lrPath of
  81          Left err -> respondError status404 [] err
  82          Right lrMethod ->
  83                 case lrMethod of
  84                  Left err -> respondError status405 [] err
  85                  Right lrBasicAuth ->
  86                         case lrBasicAuth of
  87                          Left err ->
  88                                 case failError err of
  89                                  [] -> respondError status500 [] err
  90                                  ServerErrorBasicAuth realm ba:_ ->
  91                                         case ba of
  92                                          BasicAuth_Unauthorized ->
  93                                                 respondError status403 [] err
  94                                          _ ->
  95                                                 respondError status401
  96                                                  [ ( HTTP.hWWWAuthenticate
  97                                                    , "Basic realm=\""<>Web.toHeader realm<>"\""
  98                                                    ) ] err
  99                          Right lrAccept ->
 100                                 case lrAccept of
 101                                  Left err -> respondError status406 [] err
 102                                  Right lrContentType ->
 103                                         case lrContentType of
 104                                          Left err -> respondError status415 [] err
 105                                          Right lrQuery ->
 106                                                 case lrQuery of
 107                                                  Left err -> respondError status400 [] err
 108                                                  Right lrHeader ->
 109                                                         case lrHeader of
 110                                                          Left err -> respondError status400 [] err
 111                                                          Right lrBody ->
 112                                                                 case lrBody of
 113                                                                  Left err -> respondError status400 [] err
 114                                                                  Right (a2k, _st) ->
 115                                                                         let ServerResponse app = a2k handlers in
 116                                                                         app rq re
 117         where
 118         respondError ::
 119          Show err =>
 120          HTTP.Status ->
 121          [(HTTP.HeaderName, HeaderValue)] ->
 122          err -> IO Wai.ResponseReceived
 123         respondError st hs err =
 124                 -- Trace.trace (show err) $
 125                 re $ Wai.responseLBS st
 126                  ( (HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)
 127                  : hs
 128                  ) (fromString $ show err) -- TODO: see what to return in the body
 129
 130
 131 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
 132 runServerChecks ::
 133  S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
 134  ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
 135 runServerChecks s st =
 136         runExceptT $
 137         runExceptT $
 138         runExceptT $
 139         runExceptT $
 140         runExceptT $
 141         runExceptT $
 142         runExceptT $
 143         runExceptT $
 144         S.runStateT s st
 145
 146 -- ** Type 'ServerCheckT'
 147 type ServerCheckT e = ExceptT (Fail e)
 148
 149 -- *** Type 'RouteResult'
 150 type RouteResult e = Either (Fail e)
 151
 152 -- *** Type 'Fail'
 153 data Fail e
 154  =   Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
 155  |   FailFatal !ServerState !e -- ^ Don't try other paths.
 156  deriving (Show)
 157 failState :: Fail e -> ServerState
 158 failState (Fail st _)      = st
 159 failState (FailFatal st _) = st
 160 failError :: Fail e -> e
 161 failError (Fail _st e)      = e
 162 failError (FailFatal _st e) = e
 163 instance Semigroup e => Semigroup (Fail e) where
 164         Fail _ x      <> Fail st y      = Fail      st (x<>y)
 165         FailFatal _ x <> Fail st y      = FailFatal st (x<>y)
 166         Fail _ x      <> FailFatal st y = FailFatal st (x<>y)
 167         FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
 168
 169 -- ** Type 'ServerState'
 170 data ServerState = ServerState
 171  { serverState_offset  :: Offset -- TODO: remove
 172  , serverState_request :: Wai.Request
 173  } -- deriving (Show)
 174 type Offset = Int
 175
 176 instance Show ServerState where
 177         show _ = "ServerState"
 178
 179 type instance HttpApiData Server = Web.FromHttpApiData
 180 instance Cat Server where
 181         (<.>) ::
 182          forall a b c repr.
 183          repr ~ Server =>
 184          repr a b -> repr b c -> repr a c
 185         -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
 186         -- And if so, fail with y instead of x.
 187         --
 188         -- This long spaghetti code may probably be avoided
 189         -- with a more sophisticated 'Server' using a binary tree
 190         -- instead of nested 'Either's, so that its 'Monad' instance
 191         -- would do the right thing. But to my mind,
 192         -- with the very few priorities of checks currently needed,
 193         -- this is not worth the cognitive pain to design it.
 194         -- A copy/paste/adapt will do for now.
 195         Server x <.> Server y = Server $
 196                 S.StateT $ \st -> do
 197                         xPath <- liftIO $ runServerChecks x st
 198                         case xPath of
 199                          Left xe -> MC.throw xe
 200                          Right xMethod ->
 201                                 case xMethod of
 202                                  Left xe -> do
 203                                         yPath <- liftIO $ runServerChecks y (failState xe)
 204                                         case yPath of
 205                                          Left ye -> MC.throw ye
 206                                          Right _yMethod -> MC.throw xe
 207                                  Right xBasicAuth ->
 208                                         case xBasicAuth of
 209                                          Left xe -> do
 210                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 211                                                 case yPath of
 212                                                  Left ye -> MC.throw ye
 213                                                  Right yMethod ->
 214                                                         case yMethod of
 215                                                          Left ye -> MC.throw ye
 216                                                          Right _yBasicAuth -> MC.throw xe
 217                                          Right xAccept ->
 218                                                 case xAccept of
 219                                                  Left xe -> do
 220                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 221                                                         case yPath of
 222                                                          Left ye -> MC.throw ye
 223                                                          Right yMethod ->
 224                                                                 case yMethod of
 225                                                                  Left ye -> MC.throw ye
 226                                                                  Right yBasicAuth ->
 227                                                                         case yBasicAuth of
 228                                                                          Left ye -> MC.throw ye
 229                                                                          Right _yAccept -> MC.throw xe
 230                                                  Right xContentType ->
 231                                                         case xContentType of
 232                                                          Left xe -> do
 233                                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 234                                                                 case yPath of
 235                                                                  Left ye -> MC.throw ye
 236                                                                  Right yMethod ->
 237                                                                         case yMethod of
 238                                                                          Left ye -> MC.throw ye
 239                                                                          Right yBasicAuth ->
 240                                                                                 case yBasicAuth of
 241                                                                                  Left ye -> MC.throw ye
 242                                                                                  Right yAccept ->
 243                                                                                         case yAccept of
 244                                                                                          Left ye -> MC.throw ye
 245                                                                                          Right _yQuery -> MC.throw xe
 246                                                          Right xQuery ->
 247                                                                 case xQuery of
 248                                                                  Left xe -> do
 249                                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 250                                                                         case yPath of
 251                                                                          Left ye -> MC.throw ye
 252                                                                          Right yMethod ->
 253                                                                                 case yMethod of
 254                                                                                  Left ye -> MC.throw ye
 255                                                                                  Right yBasicAuth ->
 256                                                                                         case yBasicAuth of
 257                                                                                          Left ye -> MC.throw ye
 258                                                                                          Right yAccept ->
 259                                                                                                 case yAccept of
 260                                                                                                  Left ye -> MC.throw ye
 261                                                                                                  Right yQuery ->
 262                                                                                                         case yQuery of
 263                                                                                                          Left ye -> MC.throw ye
 264                                                                                                          Right _yHeader -> MC.throw xe
 265                                                                  Right xHeader ->
 266                                                                         case xHeader of
 267                                                                          Left xe -> do
 268                                                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 269                                                                                 case yPath of
 270                                                                                  Left ye -> MC.throw ye
 271                                                                                  Right yMethod ->
 272                                                                                         case yMethod of
 273                                                                                          Left ye -> MC.throw ye
 274                                                                                          Right yBasicAuth ->
 275                                                                                                 case yBasicAuth of
 276                                                                                                  Left ye -> MC.throw ye
 277                                                                                                  Right yAccept ->
 278                                                                                                         case yAccept of
 279                                                                                                          Left ye -> MC.throw ye
 280                                                                                                          Right yQuery ->
 281                                                                                                                 case yQuery of
 282                                                                                                                  Left ye -> MC.throw ye
 283                                                                                                                  Right yHeader ->
 284                                                                                                                         case yHeader of
 285                                                                                                                          Left ye -> MC.throw ye
 286                                                                                                                          Right _yBody -> MC.throw xe
 287                                                                          Right xBody ->
 288                                                                                 case xBody of
 289                                                                                  Left xe -> do
 290                                                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 291                                                                                         case yPath of
 292                                                                                          Left ye -> MC.throw ye
 293                                                                                          Right yMethod ->
 294                                                                                                 case yMethod of
 295                                                                                                  Left ye -> MC.throw ye
 296                                                                                                  Right yBasicAuth ->
 297                                                                                                         case yBasicAuth of
 298                                                                                                          Left ye -> MC.throw ye
 299                                                                                                          Right yAccept ->
 300                                                                                                                 case yAccept of
 301                                                                                                                  Left ye -> MC.throw ye
 302                                                                                                                  Right yQuery ->
 303                                                                                                                         case yQuery of
 304                                                                                                                          Left ye -> MC.throw ye
 305                                                                                                                          Right yHeader ->
 306                                                                                                                                 case yHeader of
 307                                                                                                                                  Left ye -> MC.throw ye
 308                                                                                                                                  Right _yBody -> MC.throw xe
 309                                                                                  Right (a2b, st') ->
 310                                                                                         (first (. a2b)) <$> S.runStateT y st'
 311 instance Alt Server where
 312         Server x <!> Server y = Server $
 313                 S.StateT $ \st -> do
 314                         xPath <- liftIO $ runServerChecks x st
 315                         yPath <- liftIO $ runServerChecks y st
 316                         let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
 317                         case xPath of
 318                          Left xe | FailFatal{} <- xe -> MC.throw xe
 319                                  | otherwise ->
 320                                 case yPath of
 321                                  Left ye -> MC.throw (xe<>ye)
 322                                  Right yMethod ->
 323                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 324                                                 return $ Right yMethod
 325                          Right xMethod ->
 326                                 case xMethod of
 327                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 328                                          | otherwise ->
 329                                         case yPath of
 330                                          Left _ye -> MC.throw xe
 331                                          Right yMethod ->
 332                                                 case yMethod of
 333                                                  Left ye -> MC.throw (xe<>ye)
 334                                                  Right yBasicAuth ->
 335                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 336                                                                 return $ Right $ yBasicAuth
 337                                  Right xBasicAuth ->
 338                                         case xBasicAuth of
 339                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 340                                                  | otherwise ->
 341                                                 case yPath of
 342                                                  Left _ye -> MC.throw xe
 343                                                  Right yMethod ->
 344                                                         case yMethod of
 345                                                          Left _ye -> MC.throw xe
 346                                                          Right yBasicAuth ->
 347                                                                 case yBasicAuth of
 348                                                                  Left ye -> MC.throw (xe<>ye)
 349                                                                  Right yAccept ->
 350                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 351                                                                                 return $ Right yAccept
 352                                          Right xAccept ->
 353                                                 case xAccept of
 354                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 355                                                          | otherwise ->
 356                                                         case yPath of
 357                                                          Left _ye -> MC.throw xe
 358                                                          Right yMethod ->
 359                                                                 case yMethod of
 360                                                                  Left _ye -> MC.throw xe
 361                                                                  Right yBasicAuth ->
 362                                                                         case yBasicAuth of
 363                                                                          Left _ye -> MC.throw xe
 364                                                                          Right yAccept ->
 365                                                                                 case yAccept of
 366                                                                                  Left ye -> MC.throw (xe<>ye)
 367                                                                                  Right yContentType ->
 368                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 369                                                                                                 return $ Right yContentType
 370                                                  Right xContentType ->
 371                                                         case xContentType of
 372                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 373                                                                  | otherwise ->
 374                                                                 case yPath of
 375                                                                  Left _ye -> MC.throw xe
 376                                                                  Right yMethod ->
 377                                                                         case yMethod of
 378                                                                          Left _ye -> MC.throw xe
 379                                                                          Right yBasicAuth ->
 380                                                                                 case yBasicAuth of
 381                                                                                  Left _ye -> MC.throw xe
 382                                                                                  Right yAccept ->
 383                                                                                         case yAccept of
 384                                                                                          Left _ye -> MC.throw xe
 385                                                                                          Right yContentType ->
 386                                                                                                 case yContentType of
 387                                                                                                  Left ye -> MC.throw (xe<>ye)
 388                                                                                                  Right yQuery ->
 389                                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 390                                                                                                                 return $ Right yQuery
 391                                                          Right xQuery ->
 392                                                                 case xQuery of
 393                                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 394                                                                          | otherwise ->
 395                                                                         case yPath of
 396                                                                          Left _ye -> MC.throw xe
 397                                                                          Right yMethod ->
 398                                                                                 case yMethod of
 399                                                                                  Left _ye -> MC.throw xe
 400                                                                                  Right yBasicAuth ->
 401                                                                                         case yBasicAuth of
 402                                                                                          Left _ye -> MC.throw xe
 403                                                                                          Right yAccept ->
 404                                                                                                 case yAccept of
 405                                                                                                  Left _ye -> MC.throw xe
 406                                                                                                  Right yContentType ->
 407                                                                                                         case yContentType of
 408                                                                                                          Left _ye -> MC.throw xe
 409                                                                                                          Right yQuery ->
 410                                                                                                                 case yQuery of
 411                                                                                                                  Left ye -> MC.throw (xe<>ye)
 412                                                                                                                  Right yHeader ->
 413                                                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $
 414                                                                                                                                 return $ Right yHeader
 415                                                                  Right xHeader ->
 416                                                                         case xHeader of
 417                                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 418                                                                                  | otherwise ->
 419                                                                                 case yPath of
 420                                                                                  Left _ye -> MC.throw xe
 421                                                                                  Right yMethod ->
 422                                                                                         case yMethod of
 423                                                                                          Left _ye -> MC.throw xe
 424                                                                                          Right yBasicAuth ->
 425                                                                                                 case yBasicAuth of
 426                                                                                                  Left _ye -> MC.throw xe
 427                                                                                                  Right yAccept ->
 428                                                                                                         case yAccept of
 429                                                                                                          Left _ye -> MC.throw xe
 430                                                                                                          Right yContentType ->
 431                                                                                                                 case yContentType of
 432                                                                                                                  Left _ye -> MC.throw xe
 433                                                                                                                  Right yQuery ->
 434                                                                                                                         case yQuery of
 435                                                                                                                          Left _ye -> MC.throw xe
 436                                                                                                                          Right yHeader ->
 437                                                                                                                                 case yHeader of
 438                                                                                                                                  Left ye -> MC.throw (xe<>ye)
 439                                                                                                                                  Right yBody ->
 440                                                                                                                                         fy $ ExceptT $ ExceptT $
 441                                                                                                                                                 return $ Right yBody
 442                                                                          Right xBody ->
 443                                                                                 case xBody of
 444                                                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 445                                                                                          | otherwise ->
 446                                                                                         case yPath of
 447                                                                                          Left _ye -> MC.throw xe
 448                                                                                          Right yMethod ->
 449                                                                                                 case yMethod of
 450                                                                                                  Left _ye -> MC.throw xe
 451                                                                                                  Right yBasicAuth ->
 452                                                                                                         case yBasicAuth of
 453                                                                                                          Left _ye -> MC.throw xe
 454                                                                                                          Right yAccept ->
 455                                                                                                                 case yAccept of
 456                                                                                                                  Left _ye -> MC.throw xe
 457                                                                                                                  Right yContentType ->
 458                                                                                                                         case yContentType of
 459                                                                                                                          Left _ye -> MC.throw xe
 460                                                                                                                          Right yQuery ->
 461                                                                                                                                 case yQuery of
 462                                                                                                                                  Left _ye -> MC.throw xe
 463                                                                                                                                  Right yHeader ->
 464                                                                                                                                         case yHeader of
 465                                                                                                                                          Left _ye -> MC.throw xe
 466                                                                                                                                          Right yBody ->
 467                                                                                                                                                 case yBody of
 468                                                                                                                                                  Left ye -> MC.throw (xe<>ye)
 469                                                                                                                                                  Right yr ->
 470                                                                                                                                                         fy $ ExceptT $
 471                                                                                                                                                                 return $ Right yr
 472                                                                                  Right xr ->
 473                                                                                         return $ first (\a2k (a:!:_b) -> a2k a) xr
 474 instance Pro Server where
 475         dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
 476
 477 -- ** Type 'ServerErrorPath'
 478 data ServerErrorPath = ServerErrorPath Offset Text
 479  deriving (Eq, Show)
 480 instance HTTP_Path Server where
 481         segment expSegment = Server $ do
 482                 st@ServerState
 483                  { serverState_offset  = o
 484                  , serverState_request = req
 485                  } <- S.get
 486                 case Wai.pathInfo req of
 487                  []   -> MC.throw $ Fail st [ServerErrorPath o "segment: empty"]
 488                  [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
 489                  curr:next
 490                   | curr /= expSegment ->
 491                         MC.throw $ Fail st [ServerErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
 492                   | otherwise -> do
 493                         S.put st
 494                          { serverState_offset  = o+1
 495                          , serverState_request = req{ Wai.pathInfo = next }
 496                          }
 497                         return id
 498         capture' :: forall a k. HttpApiData Server a => Name -> Server (a -> k) k
 499         capture' name = Server $ do
 500                 st@ServerState
 501                  { serverState_offset  = o
 502                  , serverState_request = req
 503                  } <- S.get
 504                 case Wai.pathInfo req of
 505                  []   -> MC.throw $ Fail st [ServerErrorPath o "empty"]
 506                  [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
 507                  curr:next ->
 508                         case Web.parseUrlPiece curr of
 509                          Left err -> MC.throw $ Fail st [ServerErrorPath o $ "capture: "<>fromString name<>": "<>err]
 510                          Right a -> do
 511                                 S.put st
 512                                  { serverState_offset  = o+1
 513                                  , serverState_request = req{ Wai.pathInfo = next }
 514                                  }
 515                                 return ($ a)
 516         captureAll = Server $ do
 517                 req <- S.gets serverState_request
 518                 return ($ Wai.pathInfo req)
 519
 520 -- ** Type 'ServerErrorMethod'
 521 data ServerErrorMethod = ServerErrorMethod
 522  deriving (Eq, Show)
 523
 524 -- | TODO: add its own error?
 525 instance HTTP_Version Server where
 526         version exp = Server $ do
 527                 st <- S.get
 528                 let got = Wai.httpVersion $ serverState_request st
 529                 if got == exp
 530                  then return id
 531                  else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
 532
 533 -- ** Type 'ServerErrorAccept'
 534 data ServerErrorAccept =
 535  ServerErrorAccept
 536   [MediaType]
 537   (Maybe (Either BS.ByteString MediaType))
 538  deriving (Eq, Show)
 539
 540 -- ** Type 'ServerErrorContentType'
 541 data ServerErrorContentType = ServerErrorContentType
 542  deriving (Eq, Show)
 543
 544 -- ** Type 'ServerErrorQuery'
 545 newtype ServerErrorQuery = ServerErrorQuery Text
 546  deriving (Show)
 547 instance HTTP_Query Server where
 548         queryParams' name = Server $ do
 549                 st <- S.get
 550                 lift $ ExceptT $ ExceptT $ ExceptT $ return $
 551                         let qs = Wai.queryString $ serverState_request st in
 552                         let vals = catMaybes $ (<$> qs) $ \(n,v) ->
 553                                 if n == name
 554                                  then Web.parseQueryParam . Text.decodeUtf8 <$> v
 555                                  else Nothing in
 556                         case sequence vals of
 557                          Left err -> Left  $ Fail st [ServerErrorQuery err]
 558                          Right vs -> Right $ Right $ Right ($ vs)
 559
 560 -- ** Type 'ServerErrorHeader'
 561 data ServerErrorHeader = ServerErrorHeader
 562  deriving (Eq, Show)
 563 instance HTTP_Header Server where
 564         header n = Server $ do
 565                 st <- S.get
 566                 lift $ ExceptT $ ExceptT $ return $
 567                         let hs = Wai.requestHeaders $ serverState_request st in
 568                         case List.lookup n hs of
 569                          Nothing -> Left $ Fail st [ServerErrorHeader]
 570                          Just v -> Right $ Right ($ v)
 571
 572 -- ** Type 'ServerErrorBasicAuth'
 573 data ServerErrorBasicAuth =
 574      ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
 575  deriving (Show)
 576
 577 -- ** Class 'ServerBasicAuth'
 578 class ServerBasicAuth a where
 579         serverBasicAuth ::
 580          BasicAuthUser ->
 581          BasicAuthPass ->
 582          IO (BasicAuth a)
 583
 584 data Dict a where Dict :: a => Dict a
 585
 586 -- | WARNING: current implementation of Basic Access Authentication
 587 -- is not immune to certian kinds of timing attacks.
 588 -- Decoding payloads does not take a fixed amount of time.
 589 instance HTTP_BasicAuth Server where
 590         type BasicAuthConstraint Server = ServerBasicAuth
 591         type BasicAuthArgs Server a k = a -> k
 592         basicAuth' realm = Server $ do
 593                 st <- S.get
 594                 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
 595                 case decodeAuthorization $ serverState_request st of
 596                  Nothing -> err BasicAuth_BadPassword
 597                  Just (user, pass) -> do
 598                         liftIO (serverBasicAuth user pass) >>= \case
 599                          BasicAuth_BadPassword  -> err BasicAuth_BadPassword
 600                          BasicAuth_NoSuchUser   -> err BasicAuth_NoSuchUser
 601                          BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
 602                          BasicAuth_Authorized a -> return ($ a)
 603                 where
 604                 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
 605                 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
 606                 decodeAuthorization req = do
 607                         hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
 608                         let (basic, rest) = BS.break Word8.isSpace hAuthorization
 609                         guard (BS.map Word8.toLower basic == "basic")
 610                         let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
 611                         let (user, colon_pass) = BS.break (== Word8._colon) decoded
 612                         (_, pass) <- BS.uncons colon_pass
 613                         return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
 614
 615 -- ** Type 'ServerErrorBody'
 616 newtype ServerErrorBody = ServerErrorBody String
 617  deriving (Eq, Show)
 618
 619 -- *** Type 'ServerBodyArg'
 620 newtype ServerBodyArg a (ts::[*]) = ServerBodyArg a
 621
 622 instance HTTP_Body Server where
 623         type BodyArg Server = ServerBodyArg
 624         type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
 625         body' ::
 626          forall a ts k repr.
 627          BodyConstraint repr a ts =>
 628          repr ~ Server =>
 629          repr (BodyArg repr a ts -> k) k
 630         body'= Server $ do
 631                 st <- S.get
 632                 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
 633                         let hs = Wai.requestHeaders $ serverState_request st
 634                         let reqContentType =
 635                                 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 636                                 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 637                                 fromMaybe "application/octet-stream" $
 638                                 List.lookup HTTP.hContentType hs
 639                         case matchContent @ts @(MimeDecodable a) reqContentType of
 640                          Nothing -> return $ Left $ Fail st [ServerErrorContentType]
 641                          Just (MimeType mt) -> do
 642                                 bodyBS <- liftIO $ Wai.requestBody $ serverState_request st
 643                                 return $ Right $ Right $ Right $
 644                                         -- NOTE: delay unSerialize after all checks
 645                                         case mimeDecode mt $ BSL.fromStrict bodyBS of
 646                                          Left err -> Left $ Fail st [ServerErrorBody err]
 647                                          Right a -> Right ($ ServerBodyArg a)
 648
 649 -- ** Type 'ServerResponse'
 650 newtype ServerResponse = ServerResponse
 651  ( -- the request made to the server
 652    Wai.Request ->
 653    -- the continuation for the server to respond
 654    (Wai.Response -> IO Wai.ResponseReceived) ->
 655    IO Wai.ResponseReceived
 656  )
 657 instance Show ServerResponse where
 658         show _ = "ServerResponse"
 659
 660 -- *** Type 'ServerRespond'
 661 newtype ServerRespond a (ts::[*]) = ServerRespond
 662   (HTTP.Status ->
 663    HTTP.ResponseHeaders ->
 664    a -> Wai.Response)
 665
 666 instance HTTP_Response Server where
 667         type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
 668         type ResponseArgs       Server a ts = ServerRespond a ts -> ServerResponse
 669         type Response           Server a ts = ServerResponse
 670         response ::
 671          forall a ts repr.
 672          ResponseConstraint repr a ts =>
 673          repr ~ Server =>
 674          HTTP.Method ->
 675          repr (ResponseArgs repr a ts)
 676               (Response repr a ts)
 677         response expMethod = Server $ do
 678                 st@ServerState
 679                  { serverState_offset  = o
 680                  , serverState_request = req
 681                  } <- S.get
 682
 683                 -- Check the path has been fully consumed
 684                 unless (List.null $ Wai.pathInfo req) $
 685                         MC.throw $ Fail st [ServerErrorPath o "path is longer"]
 686
 687                 -- Check the method
 688                 let reqMethod = Wai.requestMethod $ serverState_request st
 689                 unless (reqMethod == expMethod
 690                  || reqMethod == HTTP.methodHead
 691                  && expMethod == HTTP.methodGet) $
 692                         MC.throw $ Fail st [ServerErrorMethod]
 693
 694                 -- Check the Accept header
 695                 let reqHeaders = Wai.requestHeaders $ serverState_request st
 696                 MimeType reqAccept <- do
 697                         case List.lookup HTTP.hAccept reqHeaders of
 698                          Nothing -> return $ List.head $ listMimeTypes @ts @(MimeEncodable a)
 699                          Just h ->
 700                                 case matchAccept @ts @(MimeEncodable a) h of
 701                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (listMediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
 702                                  Just mt -> return mt
 703                                 {-
 704                                 case Media.parseAccept h of
 705                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaType expAccept) (Just (Left h))]
 706                                  Just gotAccept
 707                                   | mediaType expAccept`Media.matches`gotAccept -> return expAccept
 708                                         -- FIXME: return gotAccept, maybe with GADTs
 709                                   | otherwise -> MC.throw $ Fail st
 710                                          [ServerErrorAccept (mediaType expAccept) (Just (Right gotAccept))]
 711                                 -}
 712
 713                 -- Respond
 714                 return ($ ServerRespond $ \s hs a ->
 715                         Wai.responseLBS s
 716                          ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
 717                          (if reqMethod == HTTP.methodHead
 718                                 then ""
 719                                 else mimeEncode reqAccept a))
 720
 721 -- * Status
 722 status200 :: HTTP.Status
 723 status200 = HTTP.mkStatus 200 "Success"
 724 status400 :: HTTP.Status
 725 status400 = HTTP.mkStatus 400 "Bad Request"
 726 status401 :: HTTP.Status
 727 status401 = HTTP.mkStatus 401 "Unauthorized"
 728 status403 :: HTTP.Status
 729 status403 = HTTP.mkStatus 403 "Forbidden"
 730 status404 :: HTTP.Status
 731 status404 = HTTP.mkStatus 404 "Not Found"
 732 status405 :: HTTP.Status
 733 status405 = HTTP.mkStatus 405 "Method Not Allowed"
 734 status406 :: HTTP.Status
 735 status406 = HTTP.mkStatus 406 "Not Acceptable"
 736 status415 :: HTTP.Status
 737 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
 738 status500 :: HTTP.Status
 739 status500 = HTTP.mkStatus 500 "Server Error"
 740
 741 -- * Utils
 742 liftIO :: MC.MonadExec IO m => IO a -> m a
 743 liftIO = MC.exec
 744 {-# INLINE liftIO #-}