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