1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE StrictData #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Language.Symantic.HTTP.Router where
10 import Control.Applicative (Applicative(..), Alternative(..))
11 import Control.Monad (Monad(..), void)
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Foldable (toList)
16 import Data.Function (($), (.), id)
17 import Data.Maybe (Maybe(..))
18 import Data.Ord (Ord(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.String (IsString(..))
21 import Data.Tuple (fst, snd)
22 import Prelude (Num(..), max, undefined)
24 import Text.Show (Show(..))
25 import qualified Control.Monad.Trans.Reader as R
26 import qualified Data.ByteString as BS
27 import qualified Data.List as List
28 import qualified Data.Set as Set
29 import qualified Data.Text as Text
30 import qualified Network.HTTP.Media as Media
31 import qualified Network.HTTP.Types as HTTP
32 import qualified Network.Wai as Wai
33 import qualified Text.Megaparsec as P
35 import Language.Symantic.HTTP.Media
36 import Language.Symantic.HTTP.API
39 type Router = R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens)
41 -- ** Type 'RouteError'
43 = RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
44 | RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
45 deriving (Eq, Ord, Show)
46 instance P.ShowErrorComponent RouteError where
47 showErrorComponent = show
49 -- ** Type 'RoutingResult'
50 type RoutingResult = Either RoutingError
51 type RoutingError = P.ParseErrorBundle RouteTokens RouteError
53 runRouter :: Router a -> Wai.Request -> RoutingResult a
55 let p = R.runReaderT rt rq in
56 P.runParser (p <* P.eof) "<Request>" $
57 RouteToken_Segment <$> Wai.pathInfo rq
59 runRouterApp :: Router Application -> Wai.Application
60 runRouterApp rt rq re =
61 case runRouter rt rq of
62 Right app -> runApplication app rq re
63 Left err -> re $ Wai.responseLBS
64 (HTTP.mkStatus 404 "Not Found")
65 [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
66 (fromString $ P.errorBundlePretty err)
69 runRouterIO :: Show a => Router (IO a) -> Wai.Request -> IO ()
71 case runRouter rt rq of
72 Left err -> putStrLn $ P.parseErrorPretty err
73 Right a -> print =<< a
76 -- * Type 'Application'
79 (RoutingResult Wai.Response -> IO Wai.ResponseReceived) ->
80 IO Wai.ResponseReceived
82 runApplication :: Application -> Wai.Application
83 runApplication ra rq re = ra rq routingRespond
85 routingRespond :: RoutingResult Wai.Response -> IO Wai.ResponseReceived
86 routingRespond = \case
88 Left err -> re $ Wai.responseLBS
89 (HTTP.mkStatus 404 "Not Found")
90 [(HTTP.hContentType, Media.renderHeader $ mediaType plainText)]
91 (fromString $ P.errorBundlePretty err)
93 -- * Type 'RouteTokens'
94 type RouteTokens = [RouteToken]
95 instance P.Stream RouteTokens where
96 type Token RouteTokens = RouteToken
97 type Tokens RouteTokens = RouteTokens
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{..} =
111 , List.head $ (show <$> inp)<>["End"]
113 { P.pstateInput = inp
114 , P.pstateOffset = max o pstateOffset
115 , P.pstateSourcePos = spos
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]
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{..} =
139 , List.head $ (show <$> inp)<>["End"]
141 { P.pstateInput = inp
142 , P.pstateOffset = max o pstateOffset
143 , P.pstateSourcePos = spos
148 inp = List.drop d pstateInput
149 spos = pstateSourcePos{P.sourceLine = P.sourceLine pstateSourcePos <> P.mkPos d}
151 -- ** Type '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)
162 unRouteToken_Segment :: RouteToken -> Segment
163 unRouteToken_Segment (RouteToken_Segment x) = x
164 unRouteToken_Segment _ = undefined
166 instance Altern Router where
168 x <+> y = P.try x <|> y
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
176 got <- R.asks Wai.requestMethod
178 P.setInput [RouteToken_Method got]
179 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
185 instance HTTP_Header Router where
187 got <- R.asks Wai.requestHeaders
189 P.setInput [RouteToken_Headers got]
190 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Header exp)) $ \_tok ->
194 instance HTTP_Accept Router where
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
203 got <- R.asks Wai.queryString
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
209 hs -> Just $ snd <$> hs
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
225 got <- R.asks Wai.httpVersion
227 P.setInput [RouteToken_Version got]
228 ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
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 m <- if expMethod == HTTP.methodGet
241 then method HTTP.methodHead <+> method HTTP.methodGet
242 else method expMethod
243 h <- header HTTP.hAccept
244 let mt = mediaType expAccept
245 case Media.parseAccept h of
246 Just got | mediaType expAccept`Media.matches`got ->
247 return $ RouterEndpoint $ \st hs a -> Wai.responseLBS st
248 ((HTTP.hContentType, Media.renderHeader mt):hs)
249 (if m == HTTP.methodHead then "" else toMediaType expAccept a)
250 _ -> P.fancyFailure $ Set.singleton $
251 P.ErrorCustom $ RouteError_Accept_unsupported mt h
252 instance HTTP_API Router