Symantic/HTTP/Server.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE Rank2Types #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 -- | See @demo/server/Main.hs@ for an example of how to use this module.
  10 module Symantic.HTTP.Server where
  11
  12 import Control.Arrow (first)
  13 import Control.Applicative (Applicative(..))
  14 import Control.Monad (Monad(..), unless, sequence, guard, (=<<))
  15 import Control.Monad.Trans.Class (MonadTrans(..))
  16 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
  17 import Data.Bool
  18 import Data.Either (Either(..))
  19 import Data.Eq (Eq(..))
  20 import Data.Function (($), (.), id)
  21 import Data.Functor (Functor(..), (<$>))
  22 import Data.Int (Int)
  23 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
  24 import Data.Monoid (Monoid(..))
  25 import Data.Ord (Ord(..))
  26 import Data.Proxy (Proxy(..))
  27 import Data.Semigroup (Semigroup(..))
  28 import Data.String (String, IsString(..))
  29 import Data.Text (Text)
  30 import System.IO (IO)
  31 import Text.Show (Show(..))
  32 import qualified Control.Monad.Classes as MC
  33 import qualified Control.Monad.Trans.Cont as C
  34 import qualified Control.Monad.Trans.Reader as R
  35 import qualified Control.Monad.Trans.State.Strict as S
  36 import qualified Control.Monad.Trans.Writer.Strict as W
  37 import qualified Data.ByteString as BS
  38 import qualified Data.ByteString.Base64 as BS64
  39 import qualified Data.ByteString.Builder as BSB
  40 import qualified Data.ByteString.Lazy as BSL
  41 import qualified Data.List as List
  42 import qualified Data.List.NonEmpty as NonEmpty
  43 import qualified Data.Text.Encoding as Text
  44 import qualified Data.Word8 as Word8
  45 import qualified Network.HTTP.Media as Media
  46 import qualified Network.HTTP.Types as HTTP
  47 import qualified Network.HTTP.Types.Header as HTTP
  48 import qualified Network.Wai as Wai
  49 import qualified Web.HttpApiData as Web
  50
  51 import Symantic.HTTP.Utils
  52 import Symantic.HTTP.MIME
  53 import Symantic.HTTP.API
  54
  55 -- * Type 'Server'
  56 -- | @'Server' responses k@ is a recipe to produce an 'Wai.Application'
  57 -- from arguments 'responses' (one per number of alternative routes),
  58 -- separated by (':!:').
  59 --
  60 -- 'Server' is analogous to a scanf using a format customized for HTTP routing.
  61 --
  62 -- The multiple 'ServerCheckT' monad transformers are there
  63 -- to prioritize the errors according to the type of check raising them,
  64 -- instead of the order of the combinators within an actual API specification.
  65 newtype Server responses k = Server { unServer ::
  66         S.StateT ServerState
  67          (ServerCheckT [ServerErrorBody]        -- 8th check, 400 error
  68          (ServerCheckT [ServerErrorHeader]      -- 7th check, 400 error
  69          (ServerCheckT [ServerErrorQuery]       -- 6th check, 400 error
  70          (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
  71          (ServerCheckT [ServerErrorAccept]      -- 4th check, 406 error
  72          (ServerCheckT [ServerErrorBasicAuth]   -- 3rd check, 401 or 403 error
  73          (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error
  74          (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error
  75          IO))))))))
  76          (responses -> k)
  77  } deriving (Functor)
  78
  79 -- | @'server' api responses@ returns a 'Wai.Application'
  80 -- ready to be given to @Warp.run 80@.
  81 server ::
  82  Server responses (Response Server) ->
  83  responses ->
  84  Wai.Application
  85 server (Server api) responses rq re = do
  86         lrPath <- runServerChecks api $ ServerState rq
  87         case lrPath of
  88          Left err -> respondError HTTP.status404 [] err
  89          Right lrMethod ->
  90                 case lrMethod of
  91                  Left err -> respondError HTTP.status405 [] err
  92                  Right lrBasicAuth ->
  93                         case lrBasicAuth of
  94                          Left err ->
  95                                 case failError err of
  96                                  [] -> respondError HTTP.status500 [] err
  97                                  ServerErrorBasicAuth realm ba:_ ->
  98                                         case ba of
  99                                          BasicAuth_Unauthorized ->
 100                                                 respondError HTTP.status403 [] err
 101                                          _ ->
 102                                                 respondError HTTP.status401
 103                                                  [ ( HTTP.hWWWAuthenticate
 104                                                    , "Basic realm=\""<>Web.toHeader realm<>"\""
 105                                                    ) ] err
 106                          Right lrAccept ->
 107                                 case lrAccept of
 108                                  Left err -> respondError HTTP.status406 [] err
 109                                  Right lrContentType ->
 110                                         case lrContentType of
 111                                          Left err -> respondError HTTP.status415 [] err
 112                                          Right lrQuery ->
 113                                                 case lrQuery of
 114                                                  Left err -> respondError HTTP.status400 [] err
 115                                                  Right lrHeader ->
 116                                                         case lrHeader of
 117                                                          Left err -> respondError HTTP.status400 [] err
 118                                                          Right lrBody ->
 119                                                                 case lrBody of
 120                                                                  Left err -> respondError HTTP.status400 [] err
 121                                                                  Right (app, _st) ->
 122                                                                         app responses rq re
 123         where
 124         respondError ::
 125          Show err =>
 126          HTTP.Status ->
 127          [(HTTP.HeaderName, HeaderValue)] ->
 128          err -> IO Wai.ResponseReceived
 129         respondError st hs err =
 130                 -- Trace.trace (show err) $
 131                 re $ Wai.responseLBS st
 132                  ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
 133                  : hs
 134                  ) (fromString $ show err) -- TODO: see what to return in the body
 135
 136 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
 137 runServerChecks ::
 138  S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
 139  ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
 140 runServerChecks s st =
 141         runExceptT $
 142         runExceptT $
 143         runExceptT $
 144         runExceptT $
 145         runExceptT $
 146         runExceptT $
 147         runExceptT $
 148         runExceptT $
 149         S.runStateT s st
 150
 151 -- ** Type 'ServerCheckT'
 152 type ServerCheckT e = ExceptT (Fail e)
 153
 154 -- *** Type 'RouteResult'
 155 type RouteResult e = Either (Fail e)
 156
 157 -- *** Type 'Fail'
 158 data Fail e
 159  =   Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
 160  |   FailFatal !ServerState !e -- ^ Don't try other paths.
 161  deriving (Show)
 162 failState :: Fail e -> ServerState
 163 failState (Fail st _)      = st
 164 failState (FailFatal st _) = st
 165 failError :: Fail e -> e
 166 failError (Fail _st e)      = e
 167 failError (FailFatal _st e) = e
 168 instance Semigroup e => Semigroup (Fail e) where
 169         Fail _ x      <> Fail st y      = Fail      st (x<>y)
 170         FailFatal _ x <> Fail st y      = FailFatal st (x<>y)
 171         Fail _ x      <> FailFatal st y = FailFatal st (x<>y)
 172         FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
 173
 174 -- ** Type 'ServerState'
 175 newtype ServerState = ServerState
 176  { serverState_request :: Wai.Request
 177  }
 178 instance Show ServerState where
 179         show _ = "ServerState"
 180
 181 instance Cat Server where
 182         (<.>) ::
 183          forall a b c repr.
 184          repr ~ Server =>
 185          repr a b -> repr b c -> repr a c
 186         -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
 187         -- And if so, fail with y instead of x.
 188         --
 189         -- This long spaghetti code may probably be avoided
 190         -- with a more sophisticated 'Server' using a binary tree
 191         -- instead of nested 'Either's, so that its 'Monad' instance
 192         -- would do the right thing. But to my mind,
 193         -- with the very few priorities of checks currently needed,
 194         -- this is not worth the cognitive pain to design it.
 195         -- Some copying/pasting/adapting will do for now.
 196         Server x <.> Server y = Server $
 197                 S.StateT $ \st -> do
 198                         xPath <- liftIO $ runServerChecks x st
 199                         case xPath of
 200                          Left xe -> MC.throw xe
 201                          Right xMethod ->
 202                                 case xMethod of
 203                                  Left xe -> do
 204                                         yPath <- liftIO $ runServerChecks y (failState xe)
 205                                         case yPath of
 206                                          Left ye -> MC.throw ye
 207                                          Right _yMethod -> MC.throw xe
 208                                  Right xBasicAuth ->
 209                                         case xBasicAuth of
 210                                          Left xe -> do
 211                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 212                                                 case yPath of
 213                                                  Left ye -> MC.throw ye
 214                                                  Right yMethod ->
 215                                                         case yMethod of
 216                                                          Left ye -> MC.throw ye
 217                                                          Right _yBasicAuth -> MC.throw xe
 218                                          Right xAccept ->
 219                                                 case xAccept of
 220                                                  Left xe -> do
 221                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 222                                                         case yPath of
 223                                                          Left ye -> MC.throw ye
 224                                                          Right yMethod ->
 225                                                                 case yMethod of
 226                                                                  Left ye -> MC.throw ye
 227                                                                  Right yBasicAuth ->
 228                                                                         case yBasicAuth of
 229                                                                          Left ye -> MC.throw ye
 230                                                                          Right _yAccept -> MC.throw xe
 231                                                  Right xContentType ->
 232                                                         case xContentType of
 233                                                          Left xe -> do
 234                                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 235                                                                 case yPath of
 236                                                                  Left ye -> MC.throw ye
 237                                                                  Right yMethod ->
 238                                                                         case yMethod of
 239                                                                          Left ye -> MC.throw ye
 240                                                                          Right yBasicAuth ->
 241                                                                                 case yBasicAuth of
 242                                                                                  Left ye -> MC.throw ye
 243                                                                                  Right yAccept ->
 244                                                                                         case yAccept of
 245                                                                                          Left ye -> MC.throw ye
 246                                                                                          Right _yQuery -> MC.throw xe
 247                                                          Right xQuery ->
 248                                                                 case xQuery of
 249                                                                  Left xe -> do
 250                                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 251                                                                         case yPath of
 252                                                                          Left ye -> MC.throw ye
 253                                                                          Right yMethod ->
 254                                                                                 case yMethod of
 255                                                                                  Left ye -> MC.throw ye
 256                                                                                  Right yBasicAuth ->
 257                                                                                         case yBasicAuth of
 258                                                                                          Left ye -> MC.throw ye
 259                                                                                          Right yAccept ->
 260                                                                                                 case yAccept of
 261                                                                                                  Left ye -> MC.throw ye
 262                                                                                                  Right yQuery ->
 263                                                                                                         case yQuery of
 264                                                                                                          Left ye -> MC.throw ye
 265                                                                                                          Right _yHeader -> MC.throw xe
 266                                                                  Right xHeader ->
 267                                                                         case xHeader of
 268                                                                          Left xe -> do
 269                                                                                 yPath <- liftIO $ runServerChecks y (failState xe)
 270                                                                                 case yPath of
 271                                                                                  Left ye -> MC.throw ye
 272                                                                                  Right yMethod ->
 273                                                                                         case yMethod of
 274                                                                                          Left ye -> MC.throw ye
 275                                                                                          Right yBasicAuth ->
 276                                                                                                 case yBasicAuth of
 277                                                                                                  Left ye -> MC.throw ye
 278                                                                                                  Right yAccept ->
 279                                                                                                         case yAccept of
 280                                                                                                          Left ye -> MC.throw ye
 281                                                                                                          Right yQuery ->
 282                                                                                                                 case yQuery of
 283                                                                                                                  Left ye -> MC.throw ye
 284                                                                                                                  Right yHeader ->
 285                                                                                                                         case yHeader of
 286                                                                                                                          Left ye -> MC.throw ye
 287                                                                                                                          Right _yBody -> MC.throw xe
 288                                                                          Right xBody ->
 289                                                                                 case xBody of
 290                                                                                  Left xe -> do
 291                                                                                         yPath <- liftIO $ runServerChecks y (failState xe)
 292                                                                                         case yPath of
 293                                                                                          Left ye -> MC.throw ye
 294                                                                                          Right yMethod ->
 295                                                                                                 case yMethod of
 296                                                                                                  Left ye -> MC.throw ye
 297                                                                                                  Right yBasicAuth ->
 298                                                                                                         case yBasicAuth of
 299                                                                                                          Left ye -> MC.throw ye
 300                                                                                                          Right yAccept ->
 301                                                                                                                 case yAccept of
 302                                                                                                                  Left ye -> MC.throw ye
 303                                                                                                                  Right yQuery ->
 304                                                                                                                         case yQuery of
 305                                                                                                                          Left ye -> MC.throw ye
 306                                                                                                                          Right yHeader ->
 307                                                                                                                                 case yHeader of
 308                                                                                                                                  Left ye -> MC.throw ye
 309                                                                                                                                  Right _yBody -> MC.throw xe
 310                                                                                  Right (a2b, st') ->
 311                                                                                         (first (. a2b)) <$> S.runStateT y st'
 312 instance Alt Server where
 313         Server x <!> Server y = Server $
 314                 S.StateT $ \st -> do
 315                         xPath <- liftIO $ runServerChecks x st
 316                         yPath <- liftIO $ runServerChecks y st
 317                         let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
 318                         case xPath of
 319                          Left xe | FailFatal{} <- xe -> MC.throw xe
 320                                  | otherwise ->
 321                                 case yPath of
 322                                  Left ye -> MC.throw (xe<>ye)
 323                                  Right yMethod ->
 324                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 325                                                 return $ Right yMethod
 326                          Right xMethod ->
 327                                 case xMethod of
 328                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 329                                          | otherwise ->
 330                                         case yPath of
 331                                          Left _ye -> MC.throw xe
 332                                          Right yMethod ->
 333                                                 case yMethod of
 334                                                  Left ye -> MC.throw (xe<>ye)
 335                                                  Right yBasicAuth ->
 336                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 337                                                                 return $ Right $ yBasicAuth
 338                                  Right xBasicAuth ->
 339                                         case xBasicAuth of
 340                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 341                                                  | otherwise ->
 342                                                 case yPath of
 343                                                  Left _ye -> MC.throw xe
 344                                                  Right yMethod ->
 345                                                         case yMethod of
 346                                                          Left _ye -> MC.throw xe
 347                                                          Right yBasicAuth ->
 348                                                                 case yBasicAuth of
 349                                                                  Left ye -> MC.throw (xe<>ye)
 350                                                                  Right yAccept ->
 351                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 352                                                                                 return $ Right yAccept
 353                                          Right xAccept ->
 354                                                 case xAccept of
 355                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 356                                                          | otherwise ->
 357                                                         case yPath of
 358                                                          Left _ye -> MC.throw xe
 359                                                          Right yMethod ->
 360                                                                 case yMethod of
 361                                                                  Left _ye -> MC.throw xe
 362                                                                  Right yBasicAuth ->
 363                                                                         case yBasicAuth of
 364                                                                          Left _ye -> MC.throw xe
 365                                                                          Right yAccept ->
 366                                                                                 case yAccept of
 367                                                                                  Left ye -> MC.throw (xe<>ye)
 368                                                                                  Right yContentType ->
 369                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 370                                                                                                 return $ Right yContentType
 371                                                  Right xContentType ->
 372                                                         case xContentType of
 373                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 374                                                                  | otherwise ->
 375                                                                 case yPath of
 376                                                                  Left _ye -> MC.throw xe
 377                                                                  Right yMethod ->
 378                                                                         case yMethod of
 379                                                                          Left _ye -> MC.throw xe
 380                                                                          Right yBasicAuth ->
 381                                                                                 case yBasicAuth of
 382                                                                                  Left _ye -> MC.throw xe
 383                                                                                  Right yAccept ->
 384                                                                                         case yAccept of
 385                                                                                          Left _ye -> MC.throw xe
 386                                                                                          Right yContentType ->
 387                                                                                                 case yContentType of
 388                                                                                                  Left ye -> MC.throw (xe<>ye)
 389                                                                                                  Right yQuery ->
 390                                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
 391                                                                                                                 return $ Right yQuery
 392                                                          Right xQuery ->
 393                                                                 case xQuery of
 394                                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 395                                                                          | otherwise ->
 396                                                                         case yPath of
 397                                                                          Left _ye -> MC.throw xe
 398                                                                          Right yMethod ->
 399                                                                                 case yMethod of
 400                                                                                  Left _ye -> MC.throw xe
 401                                                                                  Right yBasicAuth ->
 402                                                                                         case yBasicAuth of
 403                                                                                          Left _ye -> MC.throw xe
 404                                                                                          Right yAccept ->
 405                                                                                                 case yAccept of
 406                                                                                                  Left _ye -> MC.throw xe
 407                                                                                                  Right yContentType ->
 408                                                                                                         case yContentType of
 409                                                                                                          Left _ye -> MC.throw xe
 410                                                                                                          Right yQuery ->
 411                                                                                                                 case yQuery of
 412                                                                                                                  Left ye -> MC.throw (xe<>ye)
 413                                                                                                                  Right yHeader ->
 414                                                                                                                         fy $ ExceptT $ ExceptT $ ExceptT $
 415                                                                                                                                 return $ Right yHeader
 416                                                                  Right xHeader ->
 417                                                                         case xHeader of
 418                                                                          Left xe | FailFatal{} <- xe -> MC.throw xe
 419                                                                                  | otherwise ->
 420                                                                                 case yPath of
 421                                                                                  Left _ye -> MC.throw xe
 422                                                                                  Right yMethod ->
 423                                                                                         case yMethod of
 424                                                                                          Left _ye -> MC.throw xe
 425                                                                                          Right yBasicAuth ->
 426                                                                                                 case yBasicAuth of
 427                                                                                                  Left _ye -> MC.throw xe
 428                                                                                                  Right yAccept ->
 429                                                                                                         case yAccept of
 430                                                                                                          Left _ye -> MC.throw xe
 431                                                                                                          Right yContentType ->
 432                                                                                                                 case yContentType of
 433                                                                                                                  Left _ye -> MC.throw xe
 434                                                                                                                  Right yQuery ->
 435                                                                                                                         case yQuery of
 436                                                                                                                          Left _ye -> MC.throw xe
 437                                                                                                                          Right yHeader ->
 438                                                                                                                                 case yHeader of
 439                                                                                                                                  Left ye -> MC.throw (xe<>ye)
 440                                                                                                                                  Right yBody ->
 441                                                                                                                                         fy $ ExceptT $ ExceptT $
 442                                                                                                                                                 return $ Right yBody
 443                                                                          Right xBody ->
 444                                                                                 case xBody of
 445                                                                                  Left xe | FailFatal{} <- xe -> MC.throw xe
 446                                                                                          | otherwise ->
 447                                                                                         case yPath of
 448                                                                                          Left _ye -> MC.throw xe
 449                                                                                          Right yMethod ->
 450                                                                                                 case yMethod of
 451                                                                                                  Left _ye -> MC.throw xe
 452                                                                                                  Right yBasicAuth ->
 453                                                                                                         case yBasicAuth of
 454                                                                                                          Left _ye -> MC.throw xe
 455                                                                                                          Right yAccept ->
 456                                                                                                                 case yAccept of
 457                                                                                                                  Left _ye -> MC.throw xe
 458                                                                                                                  Right yContentType ->
 459                                                                                                                         case yContentType of
 460                                                                                                                          Left _ye -> MC.throw xe
 461                                                                                                                          Right yQuery ->
 462                                                                                                                                 case yQuery of
 463                                                                                                                                  Left _ye -> MC.throw xe
 464                                                                                                                                  Right yHeader ->
 465                                                                                                                                         case yHeader of
 466                                                                                                                                          Left _ye -> MC.throw xe
 467                                                                                                                                          Right yBody ->
 468                                                                                                                                                 case yBody of
 469                                                                                                                                                  Left ye -> MC.throw (xe<>ye)
 470                                                                                                                                                  Right yr ->
 471                                                                                                                                                         fy $ ExceptT $
 472                                                                                                                                                                 return $ Right yr
 473                                                                                  Right xr ->
 474                                                                                         return $ first (\a2k (a:!:_b) -> a2k a) xr
 475 instance Pro Server where
 476         dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
 477
 478 -- ** Type 'ServerErrorPath'
 479 newtype ServerErrorPath = ServerErrorPath Text
 480  deriving (Eq, Show)
 481 instance HTTP_Path Server where
 482         type PathConstraint Server a = Web.FromHttpApiData a
 483         segment expSegment = Server $ do
 484                 st@ServerState
 485                  { serverState_request = req
 486                  } <- S.get
 487                 case Wai.pathInfo req of
 488                  []   -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
 489                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
 490                  curr:next
 491                   | curr /= expSegment ->
 492                         MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr]
 493                   | otherwise -> do
 494                         S.put st
 495                          { serverState_request = req{ Wai.pathInfo = next }
 496                          }
 497                         return id
 498         capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k
 499         capture' name = Server $ do
 500                 st@ServerState
 501                  { serverState_request = req
 502                  } <- S.get
 503                 case Wai.pathInfo req of
 504                  []   -> MC.throw $ Fail st [ServerErrorPath "empty"]
 505                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
 506                  curr:next ->
 507                         case Web.parseUrlPiece curr of
 508                          Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err]
 509                          Right a -> do
 510                                 S.put st
 511                                  { serverState_request = req{ Wai.pathInfo = next }
 512                                  }
 513                                 return ($ a)
 514         captureAll = Server $ do
 515                 req <- S.gets serverState_request
 516                 return ($ Wai.pathInfo req)
 517
 518 -- ** Type 'ServerErrorMethod'
 519 data ServerErrorMethod = ServerErrorMethod
 520  deriving (Eq, Show)
 521
 522 -- | TODO: add its own error?
 523 instance HTTP_Version Server where
 524         version exp = Server $ do
 525                 st <- S.get
 526                 let got = Wai.httpVersion $ serverState_request st
 527                 if got == exp
 528                  then return id
 529                  else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
 530
 531 -- ** Type 'ServerErrorAccept'
 532 data ServerErrorAccept =
 533  ServerErrorAccept
 534   MediaTypes
 535   (Maybe (Either BS.ByteString MediaType))
 536  deriving (Eq, Show)
 537
 538 -- ** Type 'ServerErrorContentType'
 539 data ServerErrorContentType = ServerErrorContentType
 540  deriving (Eq, Show)
 541
 542 -- ** Type 'ServerErrorQuery'
 543 newtype ServerErrorQuery = ServerErrorQuery Text
 544  deriving (Show)
 545 instance HTTP_Query Server where
 546         type QueryConstraint Server a = Web.FromHttpApiData a
 547         queryParams' name = Server $ do
 548                 st <- S.get
 549                 lift $ ExceptT $ ExceptT $ ExceptT $ return $
 550                         let qs = Wai.queryString $ serverState_request st in
 551                         let vals = catMaybes $ (<$> qs) $ \(n,v) ->
 552                                 if n == name
 553                                  then Web.parseQueryParam . Text.decodeUtf8 <$> v
 554                                  else Nothing in
 555                         case sequence vals of
 556                          Left err -> Left  $ Fail st [ServerErrorQuery err]
 557                          Right vs -> Right $ Right $ Right ($ vs)
 558
 559 -- ** Type 'ServerErrorHeader'
 560 data ServerErrorHeader = ServerErrorHeader
 561  deriving (Eq, Show)
 562 instance HTTP_Header Server where
 563         header n = Server $ do
 564                 st <- S.get
 565                 lift $ ExceptT $ ExceptT $ return $
 566                         let hs = Wai.requestHeaders $ serverState_request st in
 567                         case List.lookup n hs of
 568                          Nothing -> Left $ Fail st [ServerErrorHeader]
 569                          Just v -> Right $ Right ($ v)
 570
 571 -- ** Type 'ServerErrorBasicAuth'
 572 data ServerErrorBasicAuth =
 573      ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
 574  deriving (Show)
 575
 576 -- ** Class 'ServerBasicAuth'
 577 class ServerBasicAuth a where
 578         serverBasicAuth ::
 579          BasicAuthUser ->
 580          BasicAuthPass ->
 581          IO (BasicAuth 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 (ts::[*]) a = ServerBodyArg a
 618
 619 instance HTTP_Body Server where
 620         type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
 621         type BodyArg Server a ts = ServerBodyArg ts 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 'mimeDecode' 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 'ServerBodyStreamArg'
 647 newtype ServerBodyStreamArg as (ts::[*]) framing
 648  =      ServerBodyStreamArg as
 649 instance HTTP_BodyStream Server where
 650         type BodyStreamConstraint Server as ts framing =
 651          ( FramingDecode framing as
 652          , MC.MonadExec IO (FramingMonad as)
 653          , MimeTypes ts (MimeDecodable (FramingYield as))
 654          )
 655         type BodyStreamArg Server as ts framing =
 656          ServerBodyStreamArg as ts framing
 657         bodyStream' ::
 658          forall as ts framing k repr.
 659          BodyStreamConstraint repr as ts framing =>
 660          repr ~ Server =>
 661          repr (BodyStreamArg repr as ts framing -> k) k
 662         bodyStream'= Server $ do
 663                 st <- S.get
 664                 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
 665                         let hs = Wai.requestHeaders $ serverState_request st
 666                         let reqContentType =
 667                                 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 668                                 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 669                                 fromMaybe "application/octet-stream" $
 670                                 List.lookup HTTP.hContentType hs
 671                         case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
 672                          Nothing -> return $ Left $ Fail st [ServerErrorContentType]
 673                          Just (MimeType mt) -> do
 674                                 let bodyBS = Wai.requestBody $ serverState_request st
 675                                 return $ Right $ Right $ Right $
 676                                         Right ($ ServerBodyStreamArg $
 677                                                 framingDecode (Proxy @framing) (mimeDecode mt) $
 678                                                         liftIO bodyBS
 679                                          )
 680
 681 -- * Type 'ServerResponse'
 682 -- | A continuation for |server|'s users to respond.
 683 --
 684 -- This newtype has two uses :
 685 -- * Carrying the 'ts' type variable to 'server'.
 686 -- * Providing a 'return' for the simple response case
 687 --   of 'HTTP.status200' and no extra headers.
 688 newtype ServerRes (ts::[*]) m a
 689  =      ServerResponse
 690  {    unServerResponse :: m a
 691  } deriving (Functor, Applicative, Monad)
 692 type ServerResponse ts m = ServerRes ts
 693  (R.ReaderT Wai.Request
 694  (W.WriterT HTTP.ResponseHeaders
 695  (W.WriterT HTTP.Status
 696  (C.ContT Wai.Response m))))
 697 instance MonadTrans (ServerRes ts) where
 698         lift = ServerResponse
 699 -- | All supported effects are handled by nested 'Monad's.
 700 type instance MC.CanDo (ServerResponse ts m) eff = 'False
 701 type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False
 702
 703 instance HTTP_Response Server where
 704         type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
 705         type ResponseArgs Server a ts = ServerResponse ts IO a
 706         type Response Server =
 707          Wai.Request ->
 708          (Wai.Response -> IO Wai.ResponseReceived) ->
 709          IO Wai.ResponseReceived
 710         response ::
 711          forall a ts repr.
 712          ResponseConstraint repr a ts =>
 713          repr ~ Server =>
 714          HTTP.Method ->
 715          repr (ResponseArgs repr a ts)
 716               (Response repr)
 717         response expMethod = Server $ do
 718                 st@ServerState
 719                  { serverState_request = req
 720                  } <- S.get
 721
 722                 -- Check the path has been fully consumed
 723                 unless (List.null $ Wai.pathInfo req) $
 724                         MC.throw $ Fail st [ServerErrorPath "path is longer"]
 725
 726                 -- Check the method
 727                 let reqMethod = Wai.requestMethod $ serverState_request st
 728                 unless (reqMethod == expMethod
 729                  || reqMethod == HTTP.methodHead
 730                  && expMethod == HTTP.methodGet) $
 731                         MC.throw $ Fail st [ServerErrorMethod]
 732
 733                 -- Check the Accept header
 734                 let reqHeaders = Wai.requestHeaders $ serverState_request st
 735                 MimeType reqAccept <- do
 736                         case List.lookup HTTP.hAccept reqHeaders of
 737                          Nothing ->
 738                                 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
 739                          Just h ->
 740                                 case matchAccept @ts @(MimeEncodable a) h of
 741                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
 742                                  Just mt -> return mt
 743
 744                 return $ \(ServerResponse k) rq re -> re =<< do
 745                         C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
 746                                 return{-IO-} $
 747                                         Wai.responseLBS sta
 748                                          ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
 749                                          (if reqMethod == HTTP.methodHead
 750                                                 then ""
 751                                                 else mimeEncode reqAccept a)
 752
 753 -- * Type 'ServerResponseStream'
 754 --
 755 -- This newtype has three uses :
 756 -- * Carrying the 'framing' type variable to 'server'.
 757 -- * Carrying the 'ts' type variable to 'server'.
 758 -- * Providing a 'return' for the simple response case
 759 --   of 'HTTP.status200' and no extra headers.
 760 newtype ServerResStream framing (ts::[*]) m as
 761  =      ServerResponseStream
 762  {    unServerResponseStream :: m as
 763  } deriving (Functor, Applicative, Monad)
 764 instance MonadTrans (ServerResStream framing ts) where
 765         lift = ServerResponseStream
 766 type ServerResponseStream framing ts m = ServerResStream framing ts
 767  (R.ReaderT Wai.Request
 768  (W.WriterT HTTP.ResponseHeaders
 769  (W.WriterT HTTP.Status
 770  (C.ContT Wai.Response m))))
 771 -- | All supported effects are handled by nested 'Monad's.
 772 type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False
 773
 774 instance HTTP_ResponseStream Server where
 775         type ResponseStreamConstraint Server as ts framing =
 776          ( FramingEncode framing as
 777          , MimeTypes ts (MimeEncodable (FramingYield as))
 778          )
 779         type ResponseStreamArgs Server as ts framing =
 780          ServerResponseStream framing ts IO as
 781         type ResponseStream Server =
 782          Wai.Request ->
 783          (Wai.Response -> IO Wai.ResponseReceived) ->
 784          IO Wai.ResponseReceived
 785         responseStream ::
 786          forall as ts framing repr.
 787          ResponseStreamConstraint repr as ts framing =>
 788          repr ~ Server =>
 789          HTTP.Method ->
 790          repr (ResponseStreamArgs repr as ts framing)
 791               (ResponseStream repr)
 792         responseStream expMethod = Server $ do
 793                 st@ServerState
 794                  { serverState_request = req
 795                  } <- S.get
 796
 797                 -- Check the path has been fully consumed
 798                 unless (List.null $ Wai.pathInfo req) $
 799                         MC.throw $ Fail st [ServerErrorPath "path is longer"]
 800
 801                 -- Check the method
 802                 let reqMethod = Wai.requestMethod $ serverState_request st
 803                 unless (reqMethod == expMethod
 804                  || reqMethod == HTTP.methodHead
 805                  && expMethod == HTTP.methodGet) $
 806                         MC.throw $ Fail st [ServerErrorMethod]
 807
 808                 -- Check the Accept header
 809                 let reqHeaders = Wai.requestHeaders $ serverState_request st
 810                 MimeType reqAccept <- do
 811                         case List.lookup HTTP.hAccept reqHeaders of
 812                          Nothing ->
 813                                 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
 814                          Just h ->
 815                                 case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
 816                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
 817                                  Just mt -> return mt
 818
 819                 return $ \(ServerResponseStream k) rq re -> re =<< do
 820                         C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
 821                                 return{-IO-} $
 822                                         Wai.responseStream sta
 823                                          ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
 824                                          : hs
 825                                          ) $ \write flush ->
 826                                                 if reqMethod == HTTP.methodHead
 827                                                 then flush
 828                                                 else
 829                                                         let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
 830                                                         let go curr =
 831                                                                 case curr of
 832                                                                  Left _end -> flush
 833                                                                  Right (bsl, next) -> do
 834                                                                         unless (BSL.null bsl) $ do
 835                                                                                 write (BSB.lazyByteString bsl)
 836                                                                                 flush
 837                                                                         enc next >>= go
 838                                                         in enc as >>= go
 839
 840 -- | Return worse 'HTTP.Status'.
 841 instance Semigroup HTTP.Status where
 842         x <> y =
 843                 if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
 844                 then x
 845                 else y
 846                 where
 847                 rank :: Int -> Int
 848                 rank 404 = 0 -- Not Found
 849                 rank 405 = 1 -- Method Not Allowed
 850                 rank 401 = 2 -- Unauthorized
 851                 rank 415 = 3 -- Unsupported Media Type
 852                 rank 406 = 4 -- Not Acceptable
 853                 rank 400 = 5 -- Bad Request
 854                 rank _   = 6
 855 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
 856 instance Monoid HTTP.Status where
 857         mempty  = HTTP.status200
 858         mappend = (<>)