Symantic/HTTP/Server.hs

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