Language/Symantic/HTTP/Router.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Language.Symantic.HTTP.Router where
   7
   8 import Control.Applicative (Applicative(..), Alternative(..))
   9 import Control.Monad (Monad(..), MonadPlus(..), void)
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (toList)
  14 import Data.Function (($), (.), id)
  15 import Data.Functor (Functor)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Ord (Ord(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (IsString(..))
  20 import Data.Tuple (fst, snd)
  21 import Prelude (Num(..), max, undefined)
  22 import System.IO (IO)
  23 import Text.Show (Show(..))
  24 import qualified Control.Monad.Trans.Reader as R
  25 import qualified Data.ByteString as BS
  26 import qualified Data.List as List
  27 import qualified Data.Set as Set
  28 import qualified Data.Text as Text
  29 import qualified Network.HTTP.Media as Media
  30 import qualified Network.HTTP.Types as HTTP
  31 import qualified Network.Wai as Wai
  32 import qualified Text.Megaparsec as P
  33
  34 import Language.Symantic.HTTP.Media
  35 import Language.Symantic.HTTP.API
  36
  37 -- * Type 'Router'
  38 newtype Router a = Router { unRouter :: R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens) a }
  39  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens)
  40
  41 runRouter :: Router a -> Wai.Request -> RoutingResult a
  42 runRouter (Router rt) rq =
  43         let p = R.runReaderT rt rq in
  44         P.runParser (p <* P.eof) "<Request>" $
  45                 RouteToken_Segment <$> Wai.pathInfo rq
  46
  47 runRouterApp :: Router Application -> Wai.Application
  48 runRouterApp rt rq re =
  49         case runRouter rt rq of
  50          Right app -> runApplication app rq re
  51          Left err -> re $ Wai.responseLBS
  52                  (HTTP.mkStatus 404 "Not Found")
  53                  [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
  54                  (fromString $ P.errorBundlePretty err)
  55
  56 {-
  57 runRouterIO :: Show a => Router (IO a) -> Wai.Request -> IO ()
  58 runRouterIO rt rq =
  59         case runRouter rt rq of
  60          Left err -> putStrLn $ P.parseErrorPretty err
  61          Right a -> print =<< a
  62 -}
  63
  64 -- ** Type 'RouteError'
  65 data RouteError
  66  =   RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
  67  |   RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
  68  deriving (Eq, Ord, Show)
  69 instance P.ShowErrorComponent RouteError where
  70         showErrorComponent = show
  71
  72 -- ** Type 'RoutingResult'
  73 type RoutingResult = Either RoutingError
  74 type RoutingError = P.ParseErrorBundle RouteTokens RouteError
  75
  76 -- * Type 'Application'
  77 newtype Application = Application
  78  (Wai.Request ->
  79  (RoutingResult Wai.Response -> IO Wai.ResponseReceived) ->
  80  IO Wai.ResponseReceived)
  81
  82 runApplication :: Application -> Wai.Application
  83 runApplication (Application app) rq re = app rq routingRespond
  84         where
  85         routingRespond :: RoutingResult Wai.Response -> IO Wai.ResponseReceived
  86         routingRespond = \case
  87          Right res -> re res
  88          Left err -> re $ Wai.responseLBS
  89                  (HTTP.mkStatus 404 "Not Found")
  90                  [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
  91                  (fromString $ P.errorBundlePretty err)
  92
  93 -- * Type 'RouteTokens'
  94 type RouteTokens = [RouteToken]
  95 instance P.Stream RouteTokens where
  96         type Token  RouteTokens = RouteToken
  97         type Tokens RouteTokens = RouteTokens
  98         take1_ = List.uncons
  99         takeN_ n s | n <= 0 = Just ([], s)
 100                    | List.null s = Nothing
 101                    | otherwise = Just (List.splitAt n s)
 102         takeWhile_ = List.span
 103         tokenToChunk _ps = pure
 104         tokensToChunk _ps = id
 105         chunkToTokens _ps = id
 106         chunkLength _ps = List.length
 107         chunkEmpty _ps = List.null
 108         showTokens _s toks = List.intercalate ", " $ toList $ show <$> toks
 109         reachOffset o pos@P.PosState{..} =
 110                 ( spos
 111                 , List.head $ (show <$> inp)<>["End"]
 112                 , pos
 113                  { P.pstateInput     = inp
 114                  , P.pstateOffset    = max o pstateOffset
 115                  , P.pstateSourcePos = spos
 116                  })
 117                 where
 118                 d    = o - pstateOffset
 119                 inp  = List.drop d pstateInput
 120                 line | d == 0    = P.sourceLine pstateSourcePos
 121                      | otherwise = P.sourceLine pstateSourcePos <> P.mkPos d
 122                 spos = pstateSourcePos{P.sourceLine = line}
 123 instance P.Stream Path where
 124         type Token  Path = Segment
 125         type Tokens Path = [Segment]
 126         take1_ = List.uncons
 127         takeN_ n s | n <= 0 = Just ([], s)
 128                    | List.null s = Nothing
 129                    | otherwise = Just (List.splitAt n s)
 130         takeWhile_ = List.span
 131         tokenToChunk _ps = pure
 132         tokensToChunk _ps = id
 133         chunkToTokens _ps = id
 134         chunkLength _ps = List.length
 135         chunkEmpty _ps = List.null
 136         showTokens _s toks = List.intercalate ", " $ toList $ Text.unpack <$> toks
 137         reachOffset o pos@P.PosState{..} =
 138                 ( spos
 139                 , List.head $ (show <$> inp)<>["End"]
 140                 , pos
 141                  { P.pstateInput     = inp
 142                  , P.pstateOffset    = max o pstateOffset
 143                  , P.pstateSourcePos = spos
 144                  }
 145                 )
 146                 where
 147                 d    = o - pstateOffset
 148                 inp  = List.drop d pstateInput
 149                 spos = pstateSourcePos{P.sourceLine = P.sourceLine pstateSourcePos <> P.mkPos d}
 150
 151 -- ** Type 'RouteToken'
 152 data RouteToken
 153  =   RouteToken_Segment     Segment
 154  |   RouteToken_Header      HTTP.HeaderName
 155  |   RouteToken_Headers     HTTP.RequestHeaders
 156  |   RouteToken_Query       QueryName
 157  |   RouteToken_QueryString HTTP.Query
 158  |   RouteToken_Method      HTTP.Method
 159  |   RouteToken_Version     HTTP.HttpVersion
 160  deriving (Eq, Ord, Show)
 161
 162 unRouteToken_Segment :: RouteToken -> Segment
 163 unRouteToken_Segment (RouteToken_Segment x) = x
 164 unRouteToken_Segment _ = undefined
 165
 166 instance Altern Router where
 167         tina    = empty
 168         x <+> y = P.try x <|> y
 169         try     = P.try
 170 instance HTTP_Path Router where
 171         segment = void . P.single . RouteToken_Segment
 172         capture _n = unRouteToken_Segment <$> P.anySingle
 173         captureAll = P.many $ unRouteToken_Segment <$> P.anySingle
 174 instance HTTP_Method Router where
 175         method exp = do
 176                 got <- Router $ R.asks Wai.requestMethod
 177                 inp <- P.getInput
 178                 P.setInput [RouteToken_Method got]
 179                 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
 180                         if got == exp
 181                          then Just got
 182                          else Nothing
 183                 P.setInput inp
 184                 return ret
 185 instance HTTP_Header Router where
 186         header exp = do
 187                 got <- Router $ R.asks Wai.requestHeaders
 188                 inp <- P.getInput
 189                 P.setInput [RouteToken_Headers got]
 190                 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Header exp)) $ \_tok ->
 191                         List.lookup exp got
 192                 P.setInput inp
 193                 return ret
 194 instance HTTP_Accept Router where
 195         accept exp = do
 196                 h <- header HTTP.hAccept
 197                 case Media.parseAccept h of
 198                  Just got | mediaType exp`Media.matches`got -> return $ toMediaType exp
 199                  _ -> P.fancyFailure $ Set.singleton $
 200                         P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) h
 201 instance HTTP_Query Router where
 202         query exp = do
 203                 got <- Router $ R.asks Wai.queryString
 204                 inp <- P.getInput
 205                 P.setInput [RouteToken_QueryString got]
 206                 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query exp)) $ \_tok ->
 207                         case List.filter ((== exp) . fst) got of
 208                          [] -> Nothing
 209                          hs -> Just $ snd <$> hs
 210                 P.setInput inp
 211                 return ret
 212         queryFlag n = do
 213                 vs <- query n
 214                 case vs of
 215                  [] -> return True
 216                  [Nothing] -> return True
 217                  [Just "0"] -> return False
 218                  [Just "false"] -> return False
 219                  [Just "1"] -> return True
 220                  [Just "true"] -> return True
 221                  _ -> P.fancyFailure $ Set.singleton $
 222                         P.ErrorCustom $ RouteError_Query_param_not_a_boolean n vs
 223 instance HTTP_Version Router where
 224         version exp = do
 225                 got <- Router $ R.asks Wai.httpVersion
 226                 inp <- P.getInput
 227                 P.setInput [RouteToken_Version got]
 228                 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
 229                         if got == exp
 230                          then Just got
 231                          else Nothing
 232                 P.setInput inp
 233                 return ret
 234 -- ** Type 'RouterEndpoint'
 235 newtype RouterEndpoint a
 236  =      RouterEndpoint (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
 237 instance HTTP_Endpoint Router where
 238         type Endpoint Router = RouterEndpoint
 239         endpoint expMethod expAccept = do
 240                 meth <- if expMethod == HTTP.methodGet
 241                         then method HTTP.methodHead <+> method HTTP.methodGet
 242                         else method expMethod
 243                 hAccept <- header HTTP.hAccept
 244                 let mt = mediaType expAccept
 245                 case Media.parseAccept hAccept of
 246                  Just gotAccept | mediaType expAccept`Media.matches`gotAccept ->
 247                         return $ RouterEndpoint $ \st hs a ->
 248                                 Wai.responseLBS st
 249                                  ((HTTP.hContentType, Media.renderHeader mt):hs)
 250                                  (if meth == HTTP.methodHead then "" else toMediaType expAccept a)
 251                  _ -> P.fancyFailure $ Set.singleton $
 252                         P.ErrorCustom $ RouteError_Accept_unsupported mt hAccept
 253 instance HTTP_API Router