trasa 0.4 → 0.4.1
raw patch · 2 files changed
+51/−22 lines, 2 filesnew-uploader
Files
- src/Trasa/Core.hs +50/−21
- trasa.cabal +1/−1
src/Trasa/Core.hs view
@@ -65,6 +65,7 @@ , Rec(..) , demoteParameter , flag+ , required , optional , list , qend@@ -133,7 +134,7 @@ import Data.Kind (Type) import Data.Functor.Identity (Identity(..)) import Control.Applicative (liftA2)-import Data.Maybe (mapMaybe,listToMaybe,isJust)+import Data.Maybe (mapMaybe,listToMaybe,isJust,fromMaybe) import Data.List.NonEmpty (NonEmpty) import qualified Data.List as L import qualified Data.List.NonEmpty as NE@@ -230,22 +231,28 @@ data Param = Flag+ | forall a. Required a | forall a. Optional a | forall a. List a data Parameter :: Param -> Type where ParameterFlag :: !Bool -> Parameter Flag+ ParameterRequired :: !a -> Parameter (Required a) ParameterOptional :: !(Maybe a) -> Parameter (Optional a) ParameterList :: ![a] -> Parameter (List a) data Query :: (Type -> Type) -> Param -> Type where QueryFlag :: !T.Text -> Query cap Flag+ QueryRequired :: !T.Text -> !(cap a) -> Query cap (Required a) QueryOptional :: !T.Text -> !(cap a) -> Query cap (Optional a) QueryList :: !T.Text -> !(cap a) -> Query cap (List a) flag :: T.Text -> Query cpf Flag flag = QueryFlag +required :: T.Text -> cpf query -> Query cpf (Required query)+required = QueryRequired+ optional :: T.Text -> cpf query -> Query cpf (Optional query) optional = QueryOptional @@ -263,6 +270,7 @@ mapQuery :: (forall x. f x -> g x) -> Rec (Query f) qs -> Rec (Query g) qs mapQuery eta = Topaz.map $ \case QueryFlag key -> QueryFlag key+ QueryRequired key query -> QueryRequired key (eta query) QueryOptional key query -> QueryOptional key (eta query) QueryList key query -> QueryList key (eta query) @@ -314,7 +322,6 @@ type MetaBuilder = Meta CaptureCodec CaptureCodec BodyCodec BodyCodec - -- | This function is a more general way to transform 'MetaBuilder' into 'MetaCodec'. -- -- It wraps the req and resp codecs in Many.@@ -406,17 +413,24 @@ Just (Content media bod) -> go (toList (getMany decs)) media bod RequestBodyAbsent -> case mcontent of Nothing -> Right RequestBodyAbsent- Just _ -> wrongBody+ Just (Content _ bod) -> if LBS.null bod+ then Right RequestBodyAbsent+ else wrongBody where wrongBody = Left (status N.status415) go :: [BodyDecoding a] -> N.MediaType -> LBS.ByteString -> Either TrasaErr (RequestBody Identity (Body a)) go [] _ _ = Left (status N.status415)- go (BodyDecoding medias dec:decs) media bod = case any (flip N.matches media) medias of+ go (BodyDecoding medias dec:decs) media bod = case any (flip mediaMatches media) medias of True -> bimap (TrasaErr N.status415 . LBS.fromStrict . T.encodeUtf8) (RequestBodyPresent . Identity) (dec bod) False -> go decs media bod +mediaMatches :: N.MediaType -> N.MediaType -> Bool+mediaMatches _ "*/*" = True+mediaMatches "*/*" _ = True+mediaMatches x y = N.matches x y+ encodeResponseBody :: forall response . [N.MediaType]@@ -471,6 +485,9 @@ encodeQueries (QueryFlag key `RecCons` encs) (ParameterFlag on `RecCons` qs) = if on then HM.insert key QueryParamFlag rest else rest where rest = encodeQueries encs qs+ encodeQueries (QueryRequired key (CaptureEncoding enc) `RecCons` encs) (ParameterRequired val `RecCons` qs) =+ HM.insert key (QueryParamSingle (enc val)) rest+ where rest = encodeQueries encs qs encodeQueries (QueryOptional key (CaptureEncoding enc) `RecCons` encs) (ParameterOptional mval `RecCons` qs) = maybe rest (\val -> HM.insert key (QueryParamSingle (enc val)) rest) mval where rest = encodeQueries encs qs@@ -519,44 +536,45 @@ -> Maybe Content -- ^ Request content type and body -> Either TrasaErr (Concealed route) parseWith toMeta madeRouter method (Url encodedPath encodedQuery) mcontent = do- Pathed route captures <- maybe (Left (status N.status404)) Right- $ parsePathWith madeRouter method encodedPath+ Pathed route captures <- parsePathWith madeRouter method encodedPath let m = toMeta route querys <- parseQueryWith (metaQuery m) encodedQuery reqBody <- decodeRequestBody (metaRequestBody m) mcontent- return (Concealed route captures querys reqBody)+ pure (Concealed route captures querys reqBody) -- | Parses only the path. parsePathWith :: forall route. Router route -> Method -- ^ Method -> [T.Text] -- ^ Path Pieces- -> Maybe (Pathed route)-parsePathWith (Router r0) method pieces0 =- listToMaybe (go VecNil pieces0 r0)+ -> Either TrasaErr (Pathed route)+parsePathWith (Router r0) method pieces0 = go VecNil pieces0 r0 where go :: forall n. Vec n T.Text -- captures being accumulated -> [T.Text] -- remaining pieces -> IxedRouter route n -- router fragment- -> [Pathed route]+ -> Either TrasaErr (Pathed route) go captures ps (IxedRouter matches mcapture responders) = case ps of [] -> case HM.lookup (encodeMethod method) responders of- Nothing -> []- Just respondersAtMethod ->- mapMaybe (\(IxedResponder route capDecs) ->- fmap (\x -> (Pathed route x)) (decodeCaptureVector capDecs captures)- ) respondersAtMethod- p : psNext ->- let res1 = maybe [] id $ fmap (go captures psNext) (HM.lookup p matches)+ Nothing -> Left (status N.status405)+ Just respondersAtMethod -> fromMaybe (Left (status N.status400)) . listToMaybe $+ ( mapMaybe+ (\(IxedResponder route capDecs) ->+ fmap (\x -> (Right (Pathed route x))) (decodeCaptureVector capDecs captures)+ )+ respondersAtMethod+ )+ (p:psNext) ->+ let res1 = maybe [] (:[]) $ fmap (go captures psNext) (HM.lookup p matches) -- Since this uses snocVec to build up the captures, -- this algorithm's complexity includes a term that is -- O(n^2) in the number of captures. However, most routes -- that I deal with have one or two captures. Occassionally, -- I'll get one with four or five, but this happens -- so infrequently that I'm not concerned about this.- res2 = maybe [] id $ fmap (go (snocVec p captures) psNext) mcapture- in res1 ++ res2+ res2 = maybe [] (:[]) $ fmap (go (snocVec p captures) psNext) mcapture+ in fromMaybe (Left (status N.status400)) . listToMaybe $ res1 ++ res2 parseQueryWith :: Rec (Query CaptureDecoding) querys -> QueryString -> Either TrasaErr (Rec Parameter querys) parseQueryWith decoding (QueryString querys) = Topaz.traverse param decoding@@ -564,6 +582,14 @@ param :: forall qry. Query CaptureDecoding qry -> Either TrasaErr (Parameter qry) param = \case QueryFlag key -> Right (ParameterFlag (HM.member key querys))+ QueryRequired key (CaptureDecoding dec) -> case HM.lookup key querys of+ Nothing -> Left (TrasaErr N.status400 "required query param is absent")+ Just query -> case query of+ QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected")+ QueryParamSingle txt -> case dec txt of + Just dtxt -> Right (ParameterRequired dtxt)+ Nothing -> Left (TrasaErr N.status400 "failed to decode required query parameter")+ QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected") QueryOptional key (CaptureDecoding dec) -> case HM.lookup key querys of Nothing -> Right (ParameterOptional Nothing) Just query -> case query of@@ -585,16 +611,18 @@ decodeCaptureVector (IxedRecCons (CaptureDecoding decode) rnext) (VecCons piece vnext) = do val <- decode piece vals <- decodeCaptureVector rnext vnext- return (Identity val `RecCons` vals)+ pure (Identity val `RecCons` vals) type family ParamBase (param :: Param) :: Type where ParamBase Flag = Bool+ ParamBase (Required a) = a ParamBase (Optional a) = Maybe a ParamBase (List a) = [a] demoteParameter :: Parameter param -> ParamBase param demoteParameter = \case ParameterFlag b -> b+ ParameterRequired v -> v ParameterOptional m -> m ParameterList l -> l @@ -651,6 +679,7 @@ \c -> go (\caps querys reqBod -> k (Identity c `RecCons` caps) querys reqBod) pnext qs b parameter :: forall param. Query qf param -> ParamBase param -> Parameter param parameter (QueryFlag _) b = ParameterFlag b+ parameter (QueryRequired _ _) v = ParameterRequired v parameter (QueryOptional _ _) m = ParameterOptional m parameter (QueryList _ _) l = ParameterList l
trasa.cabal view
@@ -2,7 +2,7 @@ name: trasa version:- 0.4+ 0.4.1 synopsis: Type Safe Web Routing description: