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