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