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

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