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

   1 {-# LANGUAGE GADTs #-} -- for 'Router'
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-} -- for 'Tree'
   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
 877 -- * Type 'Router'
 878 -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.
 879 data Router repr a b where
 880  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 881  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 882  Router_Any :: repr a b -> Router repr a b
 883  -- | Represent 'segment'.
 884  Router_Seg :: PathSegment -> Router repr a a
 885  -- | Represent ('<.>').
 886  Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
 887  -- | Represent 'routing'.
 888  Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
 889  -- | Represent ('<!>').
 890  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 891  -- | Used to transform 'Router_Alt' into 'Router_Map',
 892  -- while following the way ('<!>') combinators are associated in the API.
 893  -- Use 'router_AltL' to insert it correctly.
 894  Router_AltL :: Router repr a k -> Router repr (a:!:b) k
 895  -- | Used to transform 'Router_Alt' into 'Router_Map'
 896  -- while following the way ('<!>') combinators are associated in the API.
 897  -- Use 'router_AltR' to insert it correctly.
 898  Router_AltR :: Router repr b k -> Router repr (a:!:b) k
 899  -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k
 900  -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k
 901  Router_Cap :: PathConstraint repr a => Name -> Router repr (a->k) k
 902
 903  Router_Caps :: Alts2Caps xs =>
 904                 Captures (Router repr) xs k ->
 905                 Router repr (Caps2Alts xs) k
 906 -- ** Type 'Tree'
 907 -- | Use @DataKinds@ to define a 'Tree' of 'Type's.
 908 -- Useful for factorizing 'capture's of different 'Type's.
 909 data Tree a
 910  =   Tree0 a
 911  |   Tree2 (Tree a) (Tree a)
 912
 913 -- ** Type 'Captures'
 914 data Captures repr (cs::Tree Type) k where
 915  Captures0 :: PathConstraint repr a =>
 916               Proxy a -> Name -> repr x k ->
 917               Captures repr ('Tree0 (a->x)) k
 918  Captures2 :: Captures repr x k ->
 919               Captures repr y k ->
 920               Captures repr ('Tree2 x y) k
 921
 922 -- ** Type 'Capture'
 923 data Capture (cs::Tree Type) where
 924  Capture0 :: (a->x) -> Capture ('Tree0 (a->x))
 925  Capture2 :: Capture x -> Capture y -> Capture ('Tree2 x y)
 926
 927 -- ** Type family 'Caps2Alts'
 928 type family Caps2Alts (cs::Tree Type) :: Type where
 929  Caps2Alts ('Tree0 x)   = x
 930  Caps2Alts ('Tree2 x y) = Caps2Alts x :!: Caps2Alts y
 931
 932 -- ** Class 'Alts2Caps'
 933 class Alts2Caps cs where
 934         alts2caps :: Caps2Alts cs -> Capture cs
 935 instance Alts2Caps ('Tree0 (a->x)) where
 936         alts2caps a = Capture0 a
 937 instance (Alts2Caps x, Alts2Caps y) => Alts2Caps ('Tree2 x y) where
 938         alts2caps (a:!:b) = Capture2 (alts2caps a) (alts2caps b)
 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_AltL x)  = Server $ (\a2k (a:!:_b) -> a2k a) <$> unServer (unTrans x)
 948         unTrans (Router_AltR x)  = Server $ (\b2k (_a:!:b) -> b2k b) <$> unServer (unTrans x)
 949         unTrans (Router_Map ms)  = routing (unTrans <$> ms)
 950         unTrans (Router_Cap n)   = capture' n
 951         unTrans (Router_Caps xs) =
 952                 Server $ (\c2k -> c2k . alts2caps) <$> unServer
 953                  (captures (unTransCaptures xs))
 954                 where
 955                 unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k
 956                 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
 957                 unTransCaptures (Captures2 x y)   = unTransCaptures x `Captures2` unTransCaptures y
 958
 959 instance Cat (Router Server) where
 960         (<.>) = Router_Cat
 961 instance Alt (Router Server) where
 962         (<!>) = Router_Alt
 963 instance repr ~ Server => HTTP_Path (Router repr) where
 964         type PathConstraint (Router repr) a = PathConstraint repr a
 965         segment  = Router_Seg
 966         capture' = Router_Cap
 967 instance HTTP_Routing (Router Server) where
 968         routing  = Router_Map
 969         captures = Router_Any . captures . unTransCaptures
 970                 where
 971                 unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k
 972                 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
 973                 unTransCaptures (Captures2 x y)   = unTransCaptures x `Captures2` unTransCaptures y
 974 instance Pro (Router Server)
 975 instance HTTP_Query (Router Server)
 976 instance HTTP_Header (Router Server)
 977 instance HTTP_Body (Router Server)
 978 instance HTTP_BodyStream (Router Server)
 979 instance HTTP_BasicAuth (Router Server)
 980 instance HTTP_Response (Router Server)
 981 instance HTTP_ResponseStream (Router Server)
 982
 983 -- ** Class 'HTTP_Routing'
 984 class HTTP_Routing repr where
 985         routing  :: Map.Map PathSegment (repr a k) -> repr a k
 986         captures :: Captures repr cs k -> repr (Capture cs) k
 987         -- Trans defaults
 988         default routing ::
 989          Trans repr =>
 990          HTTP_Routing (UnTrans repr) =>
 991          Map.Map PathSegment (repr a k) -> repr a k
 992         routing = noTrans . routing . (unTrans <$>)
 993         {- NOTE: cannot define this default simply,
 994          - due to the need for: forall a. PathConstraint (Router repr) a ~ PathConstraint repr a
 995          - so let's just define it in (HTTP_Routing (Router Server))
 996         default captures ::
 997          Trans repr =>
 998          HTTP_Routing (UnTrans repr) =>
 999          Captures repr cs k -> repr (Capture cs) k
1000         captures = noTrans . captures . unTransCaptures
1001                 where
1002                 unTransCaptures :: Captures repr cs k -> Captures (UnTrans repr) cs k
1003                 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
1004                 unTransCaptures (Captures2 x y) = Captures2 (unTransCaptures x) (unTransCaptures y)
1005         -}
1006
1007 instance HTTP_Routing Server where
1008         routing ms = Server $ do
1009                 st@ServerState
1010                  { serverState_request = req
1011                  } <- S.get
1012                 case Wai.pathInfo req of
1013                  []   -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
1014                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1015                  curr:next ->
1016                         case Map.lookup curr ms of
1017                          Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]
1018                          Just x -> do
1019                                 S.put st
1020                                  { serverState_request = req{ Wai.pathInfo = next }
1021                                  }
1022                                 unServer x
1023
1024         captures :: Captures Server cs k -> Server (Capture cs) k
1025         captures cs = Server $ do
1026                 st@ServerState
1027                  { serverState_request = req
1028                  } <- S.get
1029                 case Wai.pathInfo req of
1030                  []   -> MC.throw $ Fail st [ServerErrorPath "empty"]
1031                  [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1032                  currSeg:nextSeg ->
1033                         case go cs of
1034                          Left errs -> MC.throw $ Fail st
1035                                  [ServerErrorPath $ "capture: "<>fromString (List.intercalate "|" ((\(name,err) -> name) <$> errs))]
1036                          Right a -> unServer a
1037                         where
1038                         go :: forall cs k. Captures Server cs k -> Either [(Name,Text)] (Server (Capture cs) k)
1039                         go (Captures0 (Proxy::Proxy cap) name currRepr) =
1040                                 case Web.parseUrlPiece currSeg of
1041                                  Left err -> Left [(name,err)]
1042                                  Right (a::cap) -> Right $ Server $ do
1043                                         S.put st { serverState_request = req{ Wai.pathInfo = nextSeg } }
1044                                         (\x2k (Capture0 a2x) -> x2k (a2x a)) <$> unServer currRepr
1045                         go (Captures2 x y) =
1046                                 case go x of
1047                                  Left xe ->
1048                                         case go y of
1049                                          Left ye -> Left (xe<>ye)
1050                                          Right a -> Right $ Server $ (\c2k (Capture2 _x' y') -> c2k y') <$> unServer a
1051                                  Right a -> Right $ Server $ (\c2k (Capture2 x' _y') -> c2k x') <$> unServer a
1052
1053 -- | Traverse a 'Router' to transform 'Router_Alt'
1054 -- into 'Router_Map' when possible.
1055 -- Used in 'server' on the 'Router' inferred from the given API.
1056 -- router :: Router repr a b -> Router repr a b
1057 router :: Router repr a b -> Router repr a b
1058 router i = case {-Dbg.trace ("router: " <> show i)-} i of
1059  x@Router_Any{} -> x
1060  x@Router_Seg{} -> x
1061 {-
1062  Router_Cat (Router_Seg s) (l`Router_Alt`r) ->
1063         (Router_Cat (Router_Seg s) l) `Router_Alt`
1064         (Router_Cat (Router_Seg s) r)
1065 -}
1066  Router_Cat x y -> router x `Router_Cat` router y
1067  Router_Alt x y -> router_Alt x y
1068  Router_AltL x  -> Router_AltL (router x)
1069  Router_AltR x  -> Router_AltR (router x)
1070  Router_Map xs  -> Router_Map (router <$> xs)
1071  Router_Cap n   -> Router_Cap n
1072  Router_Caps cs -> Router_Caps (go cs)
1073         where
1074         go :: Captures (Router repr) cs k -> Captures (Router repr) cs k
1075         go (Captures0 a n r) = Captures0 a n (router r)
1076         go (Captures2 x y)   = Captures2 (go x) (go y)
1077
1078 router_Cat :: repr ~ Server => Router repr a b -> Router repr b c -> Router repr a c
1079 router_Cat x0 y0 =
1080         let r = go
1081                  ({-Dbg.trace ("cat: x: " <> show x0)-} x0)
1082                  ({-Dbg.trace ("cat: y: " <> show y0)-} y0) in
1083         {-Dbg.trace ("cat: r: " <> show r)-} r
1084         where
1085         go x y = Router_Cat x y
1086         {-
1087         go (Router_Seg x `Router_Cat` xt)
1088            (Router_Seg y `Router_Cat` yt) =
1089         -}
1090
1091 -- | Insert a 'Router_Alt' or a 'Router_Map' if possible.
1092 router_Alt ::
1093  {-
1094  PathConstraint (Router repr) a ~ PathConstraint repr a =>
1095  PathConstraint (Router repr) b ~ PathConstraint repr b =>
1096  -}
1097  -- repr ~ Server =>
1098  Router repr a k -> Router repr b k -> Router repr (a:!:b) k
1099 router_Alt x0 y0 =
1100         let r = go
1101                  ({-Dbg.trace ("alt: x: " <> show x0)-} x0)
1102                  ({-Dbg.trace ("alt: y: " <> show y0)-} y0) in
1103         {-Dbg.trace ("alt: r: " <> show r)-} r
1104         where
1105         go :: forall a b k repr.
1106          -- repr ~ Server =>
1107          {-
1108          PathConstraint (Router repr) a ~ PathConstraint repr a =>
1109          PathConstraint (Router repr) b ~ PathConstraint repr b =>
1110          -}
1111          Router repr a k -> Router repr b k -> Router repr (a:!:b) k
1112         go (Router_Seg x `Router_Cat` xt)
1113            (Router_Seg y `Router_Cat` yt)
1114            | x == y =  Router_Seg y `Router_Cat` (xt `router_Alt` yt)
1115            | otherwise =
1116                 Router_Map $ Map.fromListWith
1117                  (\_xt _yt -> xt `router_Alt` yt)
1118                  [ (x, router_AltL xt)
1119                  , (y, router_AltR yt)
1120                  ]
1121         go (Router_Seg x `Router_Cat` xt) (Router_Map ys) =
1122                 Router_Map $
1123                         Map.merge
1124                          (Map.traverseMissing $ const $ return . router_AltL)
1125                          (Map.traverseMissing $ const $ return . router_AltR)
1126                          (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
1127                          (Map.singleton x xt) ys
1128         go (Router_Map xs) (Router_Seg y `Router_Cat` yt) =
1129                 Router_Map $
1130                         Map.merge
1131                          (Map.traverseMissing $ const $ return . router_AltL)
1132                          (Map.traverseMissing $ const $ return . router_AltR)
1133                          (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
1134                          xs (Map.singleton y yt)
1135         go (Router_Map xs) (Router_Map ys) =
1136                 Router_Map $
1137                         Map.merge
1138                          (Map.traverseMissing $ const $ return . router_AltL)
1139                          (Map.traverseMissing $ const $ return . router_AltR)
1140                          (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
1141                          xs ys
1142         go (Router_Cat (Router_Cat x y) z) w =
1143                 router_Alt (Router_Cat x (Router_Cat y z)) w
1144         go w (Router_Cat (Router_Cat x y) z) =
1145                 router_Alt w (Router_Cat x (Router_Cat y z))
1146
1147         go (Router_Cat (Router_Cap xn) x) (Router_Cat (Router_Cap yn) y) =
1148                 Router_Caps $ Captures2 (Captures0 Proxy xn x) (Captures0 Proxy yn y)
1149         go (Router_Cat (Router_Cap xn) x) (Router_Caps ys) =
1150                 Router_Caps $ Captures2 (Captures0 Proxy xn x) ys
1151         go (Router_Caps xs) (Router_Cat (Router_Cap yn) y) =
1152                 Router_Caps $ Captures2 xs (Captures0 Proxy yn y)
1153         go (Router_Caps xs) (Router_Caps ys) =
1154                 Router_Caps $ Captures2 xs ys
1155
1156         go x (Router_Alt y z) =
1157                 case router_Alt y z of
1158                  yz@Router_Alt{} -> Router_Alt x yz
1159                  yz -> router_Alt x yz
1160         go (Router_Alt x y) z =
1161                 case router_Alt x y of
1162                  xy@Router_Alt{} -> Router_Alt xy z
1163                  xy -> router_Alt xy z
1164         go x y = Router_Alt (router x) (router y)
1165
1166 -- | Insert a 'Router_AltL' as deep as possible
1167 -- in order to not prevent the transformation
1168 -- of 'Router_Alt' into 'Router_Map' in 'router_Alt'.
1169 router_AltL :: Router repr a k -> Router repr (a:!:b) k
1170 router_AltL = \case
1171  Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltL y)
1172  Router_Cat x y -> Router_Cat (router_AltL x) y
1173  Router_Alt x y -> router_AltL (Router_Alt x y)
1174  Router_Map xs -> Router_Map (router_AltL <$> xs)
1175  {-
1176  Router_Caps (Captures0 a n r) ->
1177         let () = Router_Caps (Captures0 a n (router_AltL r)) in
1178         _e
1179  Router_Caps xs -> Router_Caps (mapCaptures xs)
1180                 where
1181                 -- mapCaptures :: Captures (Router repr) a k -> Captures (Router repr) (a:!:b) k
1182                 mapCaptures (Captures0 a n r) = Captures0 a n (router_AltL r)
1183                 -- mapCaptures (Captures2 x y) = Captures2 (mapCaptures x) (mapCaptures y)
1184  -}
1185  d -> Router_AltL d
1186
1187 -- | Like 'router_AltL' but for 'Router_AltR'.
1188 router_AltR :: Router repr b k -> Router repr (a:!:b) k
1189 router_AltR = \case
1190  Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltR y)
1191  Router_Cat x y -> Router_Cat (router_AltR x) y
1192  Router_Alt x y -> router_AltR (Router_Alt x y)
1193  Router_Map xs -> Router_Map (router_AltR <$> xs)
1194  d -> Router_AltR d