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