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