Symantic/HTTP/Router.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE InstanceSigs #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE StrictData #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Symantic.HTTP.Router where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..))
  11 import Control.Monad (Monad(..), (>=>), forM)
  12 import Data.Bool
  13 import Data.Either (Either(..))
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (toList)
  16 import Data.Function (($), (.), id, const)
  17 import Data.Functor (Functor, (<$>), (<$))
  18 import Data.List.NonEmpty (NonEmpty(..))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Proxy (Proxy(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.String (IsString(..))
  24 import Data.Tuple (fst, snd)
  25 import Prelude (Num(..), max, undefined)
  26 import System.IO (IO)
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.Reader as R
  29 import qualified Data.ByteString as BS
  30 import qualified Data.List as List
  31 import qualified Data.Set as Set
  32 import qualified Data.Text as Text
  33 import qualified Data.Text.Encoding as Text
  34 import qualified Network.HTTP.Media as Media
  35 import qualified Network.HTTP.Types as HTTP
  36 import qualified Network.Wai as Wai
  37 import qualified Text.Megaparsec as P
  38 import qualified Web.HttpApiData as Web
  39
  40 import Symantic.HTTP.Media
  41 import Symantic.HTTP.Mime
  42 import Symantic.HTTP.API
  43
  44 -- import Debug.Trace
  45
  46 -- * Type 'Router'
  47 -- | @Router f k@ is a recipe to produce an 'Wai.Application'
  48 -- from handlers 'f' (one per number of alternative routes).
  49 --
  50 -- 'Router' is analogous to a scanf using a format customized for HTTP routing.
  51 newtype Router f k = Router { unRouter ::
  52  f -> R.ReaderT Wai.Request
  53                (P.Parsec RouteError RouteTokens)
  54                k }
  55  deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
  56 instance Applicative (Router f) where
  57         pure a = Router $ const $ return a
  58         Router ma2b <*> Router mb = Router $ \f -> ma2b f <*> mb f
  59 instance Monad (Router f) where
  60         return = pure
  61         Router ma >>= a2mb = Router $ \f ->
  62                 ma f >>= ($ f) . unRouter . a2mb
  63
  64
  65 -- | Useful to constrain 'repr' to be 'Router'.
  66 router :: Router f k -> Router f k
  67 router = id
  68
  69 -- | Special case where the handler 'f' is 'id'.
  70 -- Useful within a 'Router' to get the return value of another 'Router'.
  71 inRouter ::
  72  Router (a -> a) k ->
  73  R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens) k
  74 inRouter = (`unRouter` id)
  75
  76 -- | @'runRouter' rt api@ returns a 'Wai.Application'
  77 -- ready to be given to @Warp.run 80@.
  78 runRouter :: Router api RouterResponse -> api -> Wai.Application
  79 runRouter (Router rt) api rq re =
  80         let p = R.runReaderT (rt api) rq in
  81         let r = RouteToken_Segment <$> Wai.pathInfo rq in
  82         case P.runParser (p <* P.eof) "<Request>" r of
  83          Right (RouterResponse app) -> app rq re
  84          Left errs ->
  85                 -- trace (show rq) $
  86                 case P.bundleErrors errs of
  87                  err:|_ ->
  88                         re $ Wai.responseLBS
  89                          (case err of
  90                           P.FancyError _o es | P.ErrorCustom e:_ <- toList es ->
  91                                 case e of
  92                                  RouteError_Query_param{} -> status405
  93                                  RouteError_Accept_unsupported{} -> status406
  94                                  _ -> status404
  95                           _ -> status404)
  96                          [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
  97                          (fromString $ P.errorBundlePretty errs)
  98
  99 -- ** Type 'RouteError'
 100 data RouteError
 101  =   RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
 102  |   RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
 103  |   RouteError_Query_param QueryName (Maybe BS.ByteString)
 104  |   RouteError_HttpApiData Text.Text
 105  deriving (Eq, Ord, Show)
 106 instance P.ShowErrorComponent RouteError where
 107         showErrorComponent = show
 108
 109 -- ** Type 'RoutingResult'
 110 type RoutingResult = Either RoutingError
 111 type RoutingError = P.ParseErrorBundle RouteTokens RouteError
 112
 113 -- ** Type 'RouterResponse'
 114 newtype RouterResponse = RouterResponse
 115  ( -- the request made to the router
 116    Wai.Request ->
 117    -- the continuation for the router to respond
 118    (Wai.Response -> IO Wai.ResponseReceived) ->
 119    IO Wai.ResponseReceived
 120  )
 121
 122 -- * Type 'RouteTokens'
 123 type RouteTokens = [RouteToken]
 124 instance P.Stream RouteTokens where
 125         type Token  RouteTokens = RouteToken
 126         type Tokens RouteTokens = RouteTokens
 127         take1_ = List.uncons
 128         takeN_ n s | n <= 0 = Just ([], s)
 129                    | List.null s = Nothing
 130                    | otherwise = Just (List.splitAt n s)
 131         takeWhile_ = List.span
 132         tokenToChunk _ps = pure
 133         tokensToChunk _ps = id
 134         chunkToTokens _ps = id
 135         chunkLength _ps = List.length
 136         chunkEmpty _ps = List.null
 137         showTokens _s toks = List.intercalate ", " $ toList $ show <$> toks
 138         reachOffset o pos@P.PosState{..} =
 139                 ( spos
 140                 , List.head $ (show <$> inp)<>["End"]
 141                 , pos
 142                  { P.pstateInput     = inp
 143                  , P.pstateOffset    = max o pstateOffset
 144                  , P.pstateSourcePos = spos
 145                  })
 146                 where
 147                 d    = o - pstateOffset
 148                 inp  = List.drop d pstateInput
 149                 line | d == 0    = P.sourceLine pstateSourcePos
 150                      | otherwise = P.sourceLine pstateSourcePos <> P.mkPos d
 151                 spos = pstateSourcePos{P.sourceLine = line}
 152 instance P.Stream Path where
 153         type Token  Path = Segment
 154         type Tokens Path = [Segment]
 155         take1_ = List.uncons
 156         takeN_ n s | n <= 0 = Just ([], s)
 157                    | List.null s = Nothing
 158                    | otherwise = Just (List.splitAt n s)
 159         takeWhile_ = List.span
 160         tokenToChunk _ps = pure
 161         tokensToChunk _ps = id
 162         chunkToTokens _ps = id
 163         chunkLength _ps = List.length
 164         chunkEmpty _ps = List.null
 165         showTokens _s toks = List.intercalate ", " $ toList $ Text.unpack <$> toks
 166         reachOffset o pos@P.PosState{..} =
 167                 ( spos
 168                 , List.head $ (show <$> inp)<>["End"]
 169                 , pos
 170                  { P.pstateInput     = inp
 171                  , P.pstateOffset    = max o pstateOffset
 172                  , P.pstateSourcePos = spos
 173                  }
 174                 )
 175                 where
 176                 d    = o - pstateOffset
 177                 inp  = List.drop d pstateInput
 178                 spos = pstateSourcePos{P.sourceLine = P.sourceLine pstateSourcePos <> P.mkPos d}
 179
 180 -- ** Type 'RouteToken'
 181 data RouteToken
 182  =   RouteToken_Segment     Segment
 183  |   RouteToken_Header      HTTP.HeaderName
 184  |   RouteToken_Headers     HTTP.RequestHeaders
 185  |   RouteToken_Query       QueryName
 186  |   RouteToken_QueryString HTTP.Query
 187  |   RouteToken_Method      HTTP.Method
 188  |   RouteToken_Version     HTTP.HttpVersion
 189  deriving (Eq, Ord, Show)
 190
 191 unRouteToken_Segment :: RouteToken -> Segment
 192 unRouteToken_Segment (RouteToken_Segment x) = x
 193 unRouteToken_Segment _ = undefined
 194
 195 instance Cat Router where
 196         Router x <.> Router y = Router $ x >=> y
 197 instance Alt Router where
 198         Router x <!> Router y = Router $ \(b:!:c) ->
 199                 P.try (x b) <|> y c
 200         {-
 201         type AltMerge Router = Either
 202         Router x <!> Router y = Router $ \(b:!:c) ->
 203                 P.try (Left <$> x b)
 204                 <|> (Right <$> y c)
 205         -}
 206         try (Router r) = Router (P.try <$> r)
 207 instance HTTP_Path Router where
 208         segment s  = Router $ \f -> f <$ P.single (RouteToken_Segment s)
 209         capture' _n = Router $ \f -> do
 210                 ret <- unRouteToken_Segment <$> P.anySingle
 211                 case Web.parseUrlPiece ret of
 212                  Right ok -> return (f ok)
 213                  Left err -> P.fancyFailure $ Set.singleton $
 214                         P.ErrorCustom $ RouteError_HttpApiData err
 215         captureAll = Router $ \f -> f <$> P.many (unRouteToken_Segment <$> P.anySingle)
 216 instance HTTP_Method Router where
 217         method exp = Router $ \f -> do
 218                 got <- R.asks Wai.requestMethod
 219                 inp <- P.getInput
 220                 P.setInput [RouteToken_Method got]
 221                 (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
 222                         if got == exp
 223                          then Just ()
 224                          else Nothing
 225                 P.setInput inp
 226                 return f
 227 instance HTTP_Header Router where
 228         header exp = Router $ \f -> do
 229                 got <- R.asks Wai.requestHeaders
 230                 inp <- P.getInput
 231                 P.setInput [RouteToken_Headers got]
 232                 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Header exp)) $ \_tok ->
 233                         List.lookup exp got
 234                 P.setInput inp
 235                 return (f ret)
 236 instance HTTP_Accept Router where
 237         accept exp = Router $ \f -> do
 238                 hdr <- inRouter $ header HTTP.hAccept
 239                 case Media.parseAccept hdr of
 240                  Just got | mediaType exp`Media.matches`got -> return f
 241                  _ -> P.fancyFailure $ Set.singleton $
 242                         P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) hdr
 243 instance HTTP_Query Router where
 244         query' name = Router $ \f -> do
 245                 got <- R.asks Wai.queryString
 246                 inp <- P.getInput
 247                 P.setInput [RouteToken_QueryString got]
 248                 vals <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query name)) $ \_tok ->
 249                         case List.filter ((== name) . fst) got of
 250                          [] -> Nothing
 251                          hs -> Just $ snd <$> hs
 252                 P.setInput inp
 253                 ret <- forM vals $ \mayVal ->
 254                         case mayVal of
 255                          Nothing -> return Nothing
 256                          Just val ->
 257                                 case Web.parseQueryParam $ Text.decodeUtf8 val of
 258                                  Right ret -> return (Just ret)
 259                                  Left err -> P.fancyFailure $ Set.singleton $
 260                                         P.ErrorCustom $ RouteError_Query_param name mayVal
 261                 return (f ret)
 262         {-
 263         queryFlag n = Router $ \f -> do
 264                 vs <- inRouter $ query' n
 265                 f <$> case vs of
 266                  [] -> return True
 267                  [Nothing] -> return True
 268                  [Just "0"] -> return False
 269                  [Just "false"] -> return False
 270                  [Just "1"] -> return True
 271                  [Just "true"] -> return True
 272                  _ -> P.fancyFailure $ Set.singleton $
 273                         P.ErrorCustom $ RouteError_Query_param_not_a_boolean n vs
 274         -}
 275 instance HTTP_Version Router where
 276         version exp = Router $ \f -> do
 277                 got <- R.asks Wai.httpVersion
 278                 inp <- P.getInput
 279                 P.setInput [RouteToken_Version got]
 280                 (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
 281                         if got == exp
 282                          then Just ()
 283                          else Nothing
 284                 P.setInput inp
 285                 return f
 286 -- ** Type 'RouterEndpointArg'
 287 newtype RouterEndpointArg mt a = RouterEndpointArg
 288  (HTTP.Status ->
 289   HTTP.ResponseHeaders ->
 290   a -> Wai.Response)
 291 instance HTTP_Endpoint Router where
 292         type Endpoint Router = RouterResponse
 293         type EndpointArg Router = RouterEndpointArg
 294         endpoint' ::
 295          forall repr k mt a.
 296          MimeSerialize mt a =>
 297          MimeUnserialize mt a =>
 298          k ~ Endpoint repr =>
 299          repr ~ Router =>
 300          HTTP.Method ->
 301          repr (EndpointArg repr mt a -> k) k
 302         endpoint' expMethod = Router $ \f -> do
 303                 meth <-
 304                         if expMethod == HTTP.methodGet
 305                         then
 306                                 -- (unEither <$>) $
 307                                 (`unRouter` (HTTP.methodHead:!:HTTP.methodGet)) $
 308                                 method HTTP.methodHead <!> method HTTP.methodGet
 309                         else (`unRouter` expMethod) $ method expMethod
 310                 hAccept <- (`unRouter` (id:!:id)) $ header HTTP.hAccept <!> pure "*/*"
 311                 let mt = mediaType (Proxy::Proxy mt)
 312                 case Media.parseAccept hAccept of
 313                  Just reqAccept | mt`Media.matches`reqAccept ->
 314                         return $ f $ RouterEndpointArg $ \st hs a ->
 315                                 Wai.responseLBS st
 316                                  ((HTTP.hContentType, Media.renderHeader mt):hs)
 317                                  (if meth == HTTP.methodHead then "" else mimeSerialize (Proxy::Proxy mt) a)
 318                  _ -> P.fancyFailure $ Set.singleton $
 319                         P.ErrorCustom $ RouteError_Accept_unsupported mt hAccept
 320 instance HTTP_API Router
 321
 322 {-
 323 unEither :: Either a a -> a
 324 unEither (Left a) = a
 325 unEither (Right a) = a
 326 -}