Symantic/HTTP/Server.hs

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