Symantic/HTTP/Server.hs

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