symantic-http-server/Symantic/HTTP/Server.hs

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