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

   1 {-# LANGUAGE GADTs #-} -- for 'Router' and 'Router_Union'
   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 (serverState_request st) 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 instance HTTP_Raw Server where
 585         type RawConstraint Server = ()
 586         type RawArgs Server = Wai.Application
 587         type Raw Server = Wai.Application
 588         raw = Server $ return id
 589
 590 -- ** Type 'ServerErrorBasicAuth'
 591 data ServerErrorBasicAuth =
 592      ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
 593  deriving (Show)
 594
 595 -- ** Class 'ServerBasicAuth'
 596 -- | Custom 'BasicAuth' check.
 597 class ServerBasicAuth a where
 598         serverBasicAuth ::
 599          BasicAuthUser ->
 600          BasicAuthPass ->
 601          IO (BasicAuth a)
 602
 603 -- | WARNING: current implementation of Basic Access Authentication
 604 -- is not immune to certain kinds of timing attacks.
 605 -- Decoding payloads does not take a fixed amount of time.
 606 instance HTTP_BasicAuth Server where
 607         type BasicAuthConstraint Server a = ServerBasicAuth a
 608         type BasicAuthArgs Server a k = a -> k
 609         basicAuth' realm = Server $ do
 610                 st <- S.get
 611                 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
 612                 case decodeAuthorization $ serverState_request st of
 613                  Nothing -> err BasicAuth_BadPassword
 614                  Just (user, pass) -> do
 615                         MC.exec @IO (serverBasicAuth user pass) >>= \case
 616                          BasicAuth_BadPassword  -> err BasicAuth_BadPassword
 617                          BasicAuth_NoSuchUser   -> err BasicAuth_NoSuchUser
 618                          BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
 619                          BasicAuth_Authorized u -> return ($ u)
 620                 where
 621                 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
 622                 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
 623                 decodeAuthorization req = do
 624                         hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
 625                         let (basic, rest) = BS.break Word8.isSpace hAuthorization
 626                         guard (BS.map Word8.toLower basic == "basic")
 627                         let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
 628                         let (user, colon_pass) = BS.break (== Word8._colon) decoded
 629                         (_, pass) <- BS.uncons colon_pass
 630                         return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
 631
 632 -- ** Type 'ServerErrorBody'
 633 newtype ServerErrorBody = ServerErrorBody String
 634  deriving (Eq, Show)
 635
 636 -- *** Type 'ServerBodyArg'
 637 newtype ServerBodyArg (ts::[Type]) a = ServerBodyArg a
 638
 639 instance HTTP_Body Server where
 640         type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
 641         type BodyArg Server a ts = ServerBodyArg ts a
 642         body' ::
 643          forall a ts k repr.
 644          BodyConstraint repr a ts =>
 645          repr ~ Server =>
 646          repr (BodyArg repr a ts -> k) k
 647         body'= Server $ do
 648                 st <- S.get
 649                 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
 650                         let hs = Wai.requestHeaders $ serverState_request st
 651                         let reqContentType =
 652                                 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 653                                 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 654                                 fromMaybe "application/octet-stream" $
 655                                 List.lookup HTTP.hContentType hs
 656                         case matchContent @ts @(MimeDecodable a) reqContentType of
 657                          Nothing -> return $ Left $ Fail st [ServerErrorContentType]
 658                          Just (MimeType mt) -> do
 659                                 bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st
 660                                 return $ Right $ Right $ Right $
 661                                         -- NOTE: delay 'mimeDecode' after all checks.
 662                                         case mimeDecode mt $ BSL.fromStrict bodyBS of
 663                                          Left err -> Left $ Fail st [ServerErrorBody err]
 664                                          Right a -> Right ($ ServerBodyArg a)
 665
 666 -- *** Type 'ServerBodyStreamArg'
 667 newtype ServerBodyStreamArg as (ts::[Type]) framing
 668  =      ServerBodyStreamArg as
 669 instance HTTP_BodyStream Server where
 670         type BodyStreamConstraint Server as ts framing =
 671          ( FramingDecode framing as
 672          , MC.MonadExec IO (FramingMonad as)
 673          , MimeTypes ts (MimeDecodable (FramingYield as))
 674          )
 675         type BodyStreamArg Server as ts framing =
 676          ServerBodyStreamArg as ts framing
 677         bodyStream' ::
 678          forall as ts framing k repr.
 679          BodyStreamConstraint repr as ts framing =>
 680          repr ~ Server =>
 681          repr (BodyStreamArg repr as ts framing -> k) k
 682         bodyStream'= Server $ do
 683                 st <- S.get
 684                 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
 685                         let hs = Wai.requestHeaders $ serverState_request st
 686                         let reqContentType =
 687                                 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
 688                                 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
 689                                 fromMaybe "application/octet-stream" $
 690                                 List.lookup HTTP.hContentType hs
 691                         case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
 692                          Nothing -> return $ Left $ Fail st [ServerErrorContentType]
 693                          Just (MimeType mt) -> do
 694                                 let bodyBS = Wai.requestBody $ serverState_request st
 695                                 return $ Right $ Right $ Right $
 696                                         Right ($ ServerBodyStreamArg $
 697                                                 framingDecode (Proxy @framing) (mimeDecode mt) $
 698                                                         MC.exec @IO bodyBS
 699                                          )
 700
 701 -- * Type 'ServerResponse'
 702 -- | A continuation for 'server''s users to respond.
 703 --
 704 -- This newtype has two uses :
 705 --
 706 --   * Carrying the 'ts' type variable to 'server'.
 707 --   * Providing a 'return' for the simple response case
 708 --     of 'HTTP.status200' and no extra headers.
 709 newtype ServerRes (ts::[Type]) m a
 710  =      ServerResponse
 711  {    unServerResponse :: m a
 712  } deriving (Functor, Applicative, Monad)
 713 type ServerResponse ts m = ServerRes ts
 714  (R.ReaderT Wai.Request
 715  (W.WriterT HTTP.ResponseHeaders
 716  (W.WriterT HTTP.Status
 717  (C.ContT Wai.Response m))))
 718 instance MonadTrans (ServerRes ts) where
 719         lift = ServerResponse
 720 -- | All supported effects are handled by nested 'Monad's.
 721 type instance MC.CanDo (ServerResponse ts m) eff = 'False
 722 type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False
 723
 724 instance HTTP_Response Server where
 725         type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
 726         type ResponseArgs Server a ts = ServerResponse ts IO a
 727         type Response Server =
 728          Wai.Request ->
 729          (Wai.Response -> IO Wai.ResponseReceived) ->
 730          IO Wai.ResponseReceived
 731         response ::
 732          forall a ts repr.
 733          ResponseConstraint repr a ts =>
 734          repr ~ Server =>
 735          HTTP.Method ->
 736          repr (ResponseArgs repr a ts)
 737               (Response repr)
 738         response expMethod = Server $ do
 739                 st@ServerState
 740                  { serverState_request = req
 741                  } <- S.get
 742
 743                 -- Check the path has been fully consumed
 744                 unless (List.null $ Wai.pathInfo req) $
 745                         MC.throw $ Fail st [ServerErrorPath "path is longer"]
 746
 747                 -- Check the method
 748                 let reqMethod = Wai.requestMethod $ serverState_request st
 749                 unless (reqMethod == expMethod
 750                  || reqMethod == HTTP.methodHead
 751                  && expMethod == HTTP.methodGet) $
 752                         MC.throw $ Fail st [ServerErrorMethod]
 753
 754                 -- Check the Accept header
 755                 let reqHeaders = Wai.requestHeaders $ serverState_request st
 756                 MimeType reqAccept <- do
 757                         case List.lookup HTTP.hAccept reqHeaders of
 758                          Nothing ->
 759                                 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
 760                          Just h ->
 761                                 case matchAccept @ts @(MimeEncodable a) h of
 762                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
 763                                  Just mt -> return mt
 764
 765                 return $ \(ServerResponse k) rq re -> re =<< do
 766                         C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
 767                                 return{-IO-} $
 768                                         Wai.responseLBS sta
 769                                          ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
 770                                          (if reqMethod == HTTP.methodHead
 771                                                 then ""
 772                                                 else mimeEncode reqAccept a)
 773
 774 -- * Type 'ServerResponseStream'
 775 --
 776 -- This newtype has three uses :
 777 --
 778 --   * Carrying the 'framing' type variable to 'server'.
 779 --   * Carrying the 'ts' type variable to 'server'.
 780 --   * Providing a 'return' for the simple response case
 781 --     of 'HTTP.status200' and no extra headers.
 782 newtype ServerResStream framing (ts::[Type]) m as
 783  =      ServerResponseStream
 784  {    unServerResponseStream :: m as
 785  } deriving (Functor, Applicative, Monad)
 786 instance MonadTrans (ServerResStream framing ts) where
 787         lift = ServerResponseStream
 788 type ServerResponseStream framing ts m = ServerResStream framing ts
 789  (R.ReaderT Wai.Request
 790  (W.WriterT HTTP.ResponseHeaders
 791  (W.WriterT HTTP.Status
 792  (C.ContT Wai.Response m))))
 793 -- | All supported effects are handled by nested 'Monad's.
 794 type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False
 795
 796 instance HTTP_ResponseStream Server where
 797         type ResponseStreamConstraint Server as ts framing =
 798          ( FramingEncode framing as
 799          , MimeTypes ts (MimeEncodable (FramingYield as))
 800          )
 801         type ResponseStreamArgs Server as ts framing =
 802          ServerResponseStream framing ts IO as
 803         type ResponseStream Server =
 804          Wai.Application
 805          {-
 806          Wai.Request ->
 807          (Wai.Response -> IO Wai.ResponseReceived) ->
 808          IO Wai.ResponseReceived
 809          -}
 810         responseStream ::
 811          forall as ts framing repr.
 812          ResponseStreamConstraint repr as ts framing =>
 813          repr ~ Server =>
 814          HTTP.Method ->
 815          repr (ResponseStreamArgs repr as ts framing)
 816               (ResponseStream repr)
 817         responseStream expMethod = Server $ do
 818                 st@ServerState
 819                  { serverState_request = req
 820                  } <- S.get
 821
 822                 -- Check the path has been fully consumed
 823                 unless (List.null $ Wai.pathInfo req) $
 824                         MC.throw $ Fail st [ServerErrorPath "path is longer"]
 825
 826                 -- Check the method
 827                 let reqMethod = Wai.requestMethod $ serverState_request st
 828                 unless (reqMethod == expMethod
 829                  || reqMethod == HTTP.methodHead
 830                  && expMethod == HTTP.methodGet) $
 831                         MC.throw $ Fail st [ServerErrorMethod]
 832
 833                 -- Check the Accept header
 834                 let reqHeaders = Wai.requestHeaders $ serverState_request st
 835                 MimeType reqAccept <- do
 836                         case List.lookup HTTP.hAccept reqHeaders of
 837                          Nothing ->
 838                                 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
 839                          Just h ->
 840                                 case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
 841                                  Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
 842                                  Just mt -> return mt
 843
 844                 return $ \(ServerResponseStream k) rq re -> re =<< do
 845                         C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
 846                                 return{-IO-} $
 847                                         Wai.responseStream sta
 848                                          ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
 849                                          : hs
 850                                          ) $ \write flush ->
 851                                                 if reqMethod == HTTP.methodHead
 852                                                 then flush
 853                                                 else
 854                                                         let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
 855                                                         let go curr =
 856                                                                 case curr of
 857                                                                  Left _end -> flush
 858                                                                  Right (bsl, next) -> do
 859                                                                         unless (BSL.null bsl) $ do
 860                                                                                 write (BSB.lazyByteString bsl)
 861                                                                                 flush
 862                                                                         enc next >>= go
 863                                                         in enc as >>= go
 864
 865 -- | Return worse 'HTTP.Status'.
 866 instance Semigroup HTTP.Status where
 867         x <> y =
 868                 if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
 869                 then x
 870                 else y
 871                 where
 872                 rank :: Int -> Int
 873                 rank 404 = 0 -- Not Found
 874                 rank 405 = 1 -- Method Not Allowed
 875                 rank 401 = 2 -- Unauthorized
 876                 rank 415 = 3 -- Unsupported Media Type
 877                 rank 406 = 4 -- Not Acceptable
 878                 rank 400 = 5 -- Bad Request
 879                 rank _   = 6
 880 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
 881 instance Monoid HTTP.Status where
 882         mempty  = HTTP.status200
 883         mappend = (<>)
 884
 885 -- * Type 'Router'
 886 -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.
 887 data Router repr a b where
 888  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 889  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 890  Router_Any :: repr a b -> Router repr a b
 891  -- | Represent 'segment'.
 892  Router_Seg :: PathSegment -> Router repr k k
 893  -- | Represent ('<.>').
 894  Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
 895  -- | Represent 'routing'.
 896  Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
 897  -- | Represent ('<!>').
 898  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 899  -- | Represent 'capture''.
 900  Router_Cap :: PathConstraint Server a => Name -> Router repr (a->k) k
 901  -- | Represent 'captures'.
 902  Router_Caps :: Captures (Router repr) cs k -> Router repr (AltFromBinTree cs) k
 903  -- | Unify 'Router's which have different 'handlers'.
 904  -- Useful to put alternative 'Router's in a 'Map.Map' as in 'Router_Map'.
 905  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 906
 907 -- ** Type 'Captures'
 908 data Captures repr (cs::BinTree Type) k where
 909  Captures0 :: PathConstraint Server a =>
 910               Proxy a -> Name -> repr x k ->
 911               Captures repr ('BinTree0 (a->x)) k
 912  Captures2 :: Captures repr x k ->
 913               Captures repr y k ->
 914               Captures repr ('BinTree2 x y) k
 915
 916 -- *** Type 'BinTree'
 917 -- | Use @DataKinds@ to define a 'BinTree' of 'Type's.
 918 -- Useful for gathering together 'capture's of different 'Type's.
 919 data BinTree a
 920  =   BinTree0 a
 921  |   BinTree2 (BinTree a) (BinTree a)
 922
 923 -- *** Type family 'AltFromBinTree'
 924 type family AltFromBinTree (cs::BinTree Type) :: Type where
 925  AltFromBinTree ('BinTree0 x)   = x
 926  AltFromBinTree ('BinTree2 x y) = AltFromBinTree x :!: AltFromBinTree y
 927
 928 instance Trans (Router Server) where
 929         type UnTrans (Router Server) = Server
 930         noTrans = Router_Any
 931         unTrans (Router_Any x)   = x
 932         unTrans (Router_Seg s)   = segment s
 933         unTrans (Router_Cat x y) = unTrans x <.> unTrans y
 934         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 935         unTrans (Router_Map ms)  = routing (unTrans <$> ms)
 936         unTrans (Router_Cap n)   = capture' n
 937         unTrans (Router_Caps xs) = captures $ unTransCaptures xs
 938                 where
 939                 unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k
 940                 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
 941                 unTransCaptures (Captures2 x y)   = unTransCaptures x `Captures2` unTransCaptures y
 942         unTrans (Router_Union u x) = Server $ (. u) <$> unServer (unTrans x)
 943
 944 instance Cat (Router Server) where
 945         (<.>) = Router_Cat
 946 instance Alt (Router Server) where
 947         (<!>) = Router_Alt
 948 instance repr ~ Server => HTTP_Path (Router repr) where
 949         type PathConstraint (Router repr) a = PathConstraint repr a
 950         segment  = Router_Seg
 951         capture' = Router_Cap
 952 instance HTTP_Routing (Router Server) where
 953         routing  = Router_Map
 954         captures = Router_Caps
 955 instance HTTP_Raw (Router Server)
 956 instance Pro (Router Server)
 957 instance HTTP_Query (Router Server)
 958 instance HTTP_Header (Router Server)
 959 instance HTTP_Body (Router Server)
 960 instance HTTP_BodyStream (Router Server)
 961 instance HTTP_BasicAuth (Router Server)
 962 instance HTTP_Response (Router Server)
 963 instance HTTP_ResponseStream (Router Server)
 964
 965 -- ** Class 'HTTP_Routing'
 966 class HTTP_Routing repr where
 967         routing  :: Map.Map PathSegment (repr a k) -> repr a k
 968         captures :: Captures repr cs k -> repr (AltFromBinTree cs) k
 969         -- Trans defaults
 970         default routing ::
 971          Trans repr =>
 972          HTTP_Routing (UnTrans repr) =>
 973          Map.Map PathSegment (repr a k) -> repr a k
 974         routing = noTrans . routing . (unTrans <$>)
 975         default captures ::
 976          Trans repr =>
 977          HTTP_Routing (UnTrans repr) =>
 978          Captures repr cs k -> repr (AltFromBinTree cs) k
 979         captures = noTrans . captures . unTransCaptures
 980                 where
 981                 unTransCaptures :: Captures repr cs k -> Captures (UnTrans repr) cs k
 982                 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
 983                 unTransCaptures (Captures2 x y)   = Captures2 (unTransCaptures x) (unTransCaptures y)
 984
 985 instance HTTP_Routing Server where
 986         routing ms = Server $ do
 987                 st@ServerState
 988                  { serverState_request = req
 989                  } <- S.get
 990                 case Wai.pathInfo req of
 991                  []   -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
 992                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
 993                  curr:next ->
 994                         case Map.lookup curr ms of
 995                          Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]
 996                          Just x -> do
 997                                 S.put st
 998                                  { serverState_request = req{ Wai.pathInfo = next }
 999                                  }
1000                                 unServer x
1001
1002         captures :: Captures Server cs k -> Server (AltFromBinTree cs) k
1003         captures cs = Server $ do
1004                 st@ServerState
1005                  { serverState_request = req
1006                  } <- S.get
1007                 case Wai.pathInfo req of
1008                  []   -> MC.throw $ Fail st [ServerErrorPath "empty"]
1009                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1010                  currSeg:nextSeg ->
1011                         case go cs of
1012                          Left errs -> MC.throw $ Fail st
1013                                  [ServerErrorPath $ "captures: "<>
1014                                         fromString (List.intercalate "|" ((\(name,err) -> name) <$> errs))]
1015                          Right a -> unServer a
1016                         where
1017                         go :: forall cs k. Captures Server cs k -> Either [(Name,Text)] (Server (AltFromBinTree cs) k)
1018                         go (Captures0 (Proxy::Proxy a) name currRepr) =
1019                                 case Web.parseUrlPiece currSeg of
1020                                  Left err -> Left [(name,err)]
1021                                  Right (a::a) ->
1022                                         Right $ Server $ do
1023                                                 S.put st { serverState_request = req{ Wai.pathInfo = nextSeg } }
1024                                                 (\x2k a2x -> x2k (a2x a)) <$> unServer currRepr
1025                         go (Captures2 x y) =
1026                                 case go x of
1027                                  Left xe ->
1028                                         case go y of
1029                                          Left ye -> Left (xe<>ye)
1030                                          Right a -> Right $ Server $ (\r2k (_l:!:r) -> r2k r) <$> unServer a
1031                                  Right a   -> Right $ Server $ (\l2k (l:!:_r) -> l2k l) <$> unServer a
1032
1033 -- | Traverse a 'Router' to transform it:
1034 --
1035 --   * Associate 'Router_Cat' to the right.
1036 --   * Replace 'Router_Seg' with 'Router_Map'.
1037 --   * Replace 'Router_Cap' with 'Router_Caps'.
1038 --
1039 -- Used in 'server' on the 'Router' inferred from the given API.
1040 router :: Router repr a b -> Router repr a b
1041 router = {-debug1 "router" $-} \case
1042  x@Router_Any{} -> x
1043  x@Router_Seg{} -> x
1044  Router_Seg x `Router_Cat` y -> Router_Map $ Map.singleton x $ router y
1045  Router_Alt x y -> x`router_Alt`y
1046  Router_Map xs -> Router_Map $ router <$> xs
1047  Router_Cap xn `Router_Cat` x -> Router_Caps $ Captures0 Proxy xn x
1048  Router_Cap n -> Router_Cap n
1049  Router_Caps cs -> Router_Caps (go cs)
1050         where
1051         go :: Captures (Router repr) cs k -> Captures (Router repr) cs k
1052         go (Captures0 a n r) = Captures0 a n (router r)
1053         go (Captures2 x y)   = Captures2 (go x) (go 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_Union u x -> Router_Union u (router x)
1062
1063 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
1064 router_Alt ::
1065  Router repr a k ->
1066  Router repr b k ->
1067  Router repr (a:!:b) k
1068 router_Alt = {-debug2 "router_Alt"-} go
1069         where
1070         -- Merge alternative segments together.
1071         go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) =
1072                 Map.singleton x (router xt)
1073                 `router_Map`
1074                 Map.singleton y (router yt)
1075         go (Router_Seg x `Router_Cat` xt) (Router_Map ys) =
1076                 Map.singleton x (router xt)
1077                 `router_Map` ys
1078         go (Router_Map xs) (Router_Seg y `Router_Cat` yt) =
1079                 xs `router_Map`
1080                 Map.singleton y (router yt)
1081         go (Router_Map xs) (Router_Map ys) =
1082                 xs`router_Map`ys
1083
1084         -- Merge alternative 'segment's or alternative 'capture''s together.
1085         go (Router_Cap xn `Router_Cat` x) (Router_Cap yn `Router_Cat` y) =
1086                 Router_Caps $
1087                         Captures0 Proxy xn x
1088                         `Captures2`
1089                         Captures0 Proxy yn y
1090         go (Router_Caps xs) (Router_Caps ys) =
1091                 Router_Caps $ xs`Captures2`ys
1092         go (Router_Cap xn `Router_Cat` x) (Router_Caps ys) =
1093                 Router_Caps $ Captures0 Proxy xn x `Captures2` ys
1094         go (Router_Caps xs) (Router_Cap yn `Router_Cat` y) =
1095                 Router_Caps $ xs `Captures2` Captures0 Proxy yn y
1096
1097         -- Merge left first or right first, depending on which removes 'Router_Alt'.
1098         go x (y`Router_Alt`z) =
1099                 case x`router_Alt`y of
1100                  Router_Alt x' y' ->
1101                         case y'`router_Alt`z of
1102                          yz@(Router_Alt _y z') ->
1103                                 case x'`router_Alt`z' of
1104                                  Router_Alt{} -> router x'`Router_Alt`yz
1105                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
1106                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
1107                          yz -> x'`router_Alt`yz
1108                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
1109         go (x`Router_Alt`y) z =
1110                 case y`router_Alt`z of
1111                  Router_Alt y' z' ->
1112                         case x`router_Alt`y' of
1113                          xy@(Router_Alt x' _y) ->
1114                                 case x'`router_Alt`z' of
1115                                  Router_Alt{} -> xy`Router_Alt`router z'
1116                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
1117                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
1118                          xy -> xy`router_Alt`z'
1119                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
1120
1121         -- Merge through 'Router_Union'.
1122         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
1123         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
1124
1125         -- No merging, but apply 'router' on both alternatives.
1126         go x y = router x `Router_Alt` router y
1127
1128 router_Map ::
1129  Map.Map PathSegment (Router repr a k) ->
1130  Map.Map PathSegment (Router repr b k) ->
1131  Router repr (a:!:b) k
1132 router_Map xs ys =
1133         -- NOTE: a little bit more complex than required
1134         -- in order to merge 'Router_Union's instead of nesting them,
1135         -- such that 'unTrans' 'Router_Union' applies them all at once.
1136         Router_Map $
1137         Map.merge
1138          (Map.traverseMissing $ const $ \case
1139                  Router_Union u r ->
1140                         return $ Router_Union (\(x:!:_y) -> u x) r
1141                  r -> return $ Router_Union (\(x:!:_y) -> x) r)
1142          (Map.traverseMissing $ const $ \case
1143                  Router_Union u r ->
1144                         return $ Router_Union (\(_x:!:y) -> u y) r
1145                  r -> return $ Router_Union (\(_x:!:y) -> y) r)
1146          (Map.zipWithAMatched $ const $ \case
1147                  Router_Union xu xr -> \case
1148                          Router_Union yu yr ->
1149                                 return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
1150                          yr ->
1151                                 return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
1152                  xr -> \case
1153                          Router_Union yu yr ->
1154                                 return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
1155                          yr -> return $ xr`router_Alt`yr)
1156          xs ys
1157
1158 {-
1159 debug0 :: Show a => String -> a -> a
1160 debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a
1161 debug1 :: Show a => Show b => String -> (a->b) -> (a->b)
1162 debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b
1163         where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a
1164 debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)
1165 debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c
1166         where
1167         b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a
1168         c   = b2c   $ Debug.trace (n<>": b: "<>show b) b
1169 -}