trasa 0.2 → 0.3
raw patch · 6 files changed
+413/−229 lines, 6 filesdep ~http-mediadep ~http-typesdep ~vinylnew-uploader
Dependency ranges changed: http-media, http-types, vinyl
Files
- src/Trasa/Codec.hs +54/−0
- src/Trasa/Core.hs +219/−130
- src/Trasa/Core/Implicit.hs +67/−0
- src/Trasa/Tutorial.hs +4/−12
- test/Main.hs +57/−75
- trasa.cabal +12/−12
src/Trasa/Codec.hs view
@@ -3,14 +3,20 @@ ( -- * Capture Codecs CaptureEncoding(..)+ , HasCaptureEncoding(..) , CaptureDecoding(..)+ , HasCaptureDecoding(..) , CaptureCodec(..)+ , HasCaptureCodec(..) , captureCodecToCaptureEncoding , captureCodecToCaptureDecoding -- * Body Codecs , BodyEncoding(..)+ , HasBodyEncoding(..) , BodyDecoding(..)+ , HasBodyDecoding(..) , BodyCodec(..)+ , HasBodyCodec(..) , bodyCodecToBodyEncoding , bodyCodecToBodyDecoding -- * Type Class Based Codecs@@ -28,13 +34,37 @@ newtype CaptureEncoding a = CaptureEncoding { appCaptureEncoding :: a -> T.Text } +class HasCaptureEncoding capStrategy where+ captureEncoding :: capStrategy a -> CaptureEncoding a++instance HasCaptureEncoding CaptureEncoding where+ captureEncoding = id+ newtype CaptureDecoding a = CaptureDecoding { appCaptureDecoding :: T.Text -> Maybe a } +class HasCaptureDecoding capStrategy where+ captureDecoding :: capStrategy a -> CaptureDecoding a++instance HasCaptureDecoding CaptureDecoding where+ captureDecoding = id+ data CaptureCodec a = CaptureCodec { captureCodecEncode :: a -> T.Text , captureCodecDecode :: T.Text -> Maybe a } +class HasCaptureCodec capStrategy where+ captureCodec :: capStrategy a -> CaptureCodec a++instance HasCaptureEncoding CaptureCodec where+ captureEncoding = captureCodecToCaptureEncoding++instance HasCaptureDecoding CaptureCodec where+ captureDecoding = captureCodecToCaptureDecoding++instance HasCaptureCodec CaptureCodec where+ captureCodec = id+ captureCodecToCaptureEncoding :: CaptureCodec a -> CaptureEncoding a captureCodecToCaptureEncoding (CaptureCodec enc _) = CaptureEncoding enc @@ -49,16 +79,40 @@ , bodyEncodingFunction :: a -> LBS.ByteString } +class HasBodyEncoding bodyStrategy where+ bodyEncoding :: bodyStrategy a -> BodyEncoding a++instance HasBodyEncoding BodyEncoding where+ bodyEncoding = id+ data BodyDecoding a = BodyDecoding { bodyDecodingNames :: NonEmpty N.MediaType , bodyDecodingFunction :: LBS.ByteString -> Either T.Text a } +class HasBodyDecoding bodyStrategy where+ bodyDecoding :: bodyStrategy a -> BodyDecoding a++instance HasBodyDecoding BodyDecoding where+ bodyDecoding = id+ data BodyCodec a = BodyCodec { bodyCodecNames :: NonEmpty N.MediaType , bodyCodecEncode :: a -> LBS.ByteString , bodyCodecDecode :: LBS.ByteString -> Either T.Text a }++class HasBodyCodec bodyStrategy where+ bodyCodec :: bodyStrategy a -> BodyCodec a++instance HasBodyEncoding BodyCodec where+ bodyEncoding = bodyCodecToBodyEncoding++instance HasBodyDecoding BodyCodec where+ bodyDecoding = bodyCodecToBodyDecoding++instance HasBodyCodec BodyCodec where+ bodyCodec = id bodyCodecToBodyEncoding :: BodyCodec a -> BodyEncoding a bodyCodecToBodyEncoding (BodyCodec names enc _) = BodyEncoding names enc
src/Trasa/Core.hs view
@@ -23,6 +23,7 @@ , Concealed(..) , Constructed(..) , conceal+ , concealedToPrepared , mapConstructed -- * Request Types -- ** Method@@ -42,9 +43,9 @@ , status -- * Using Routes , prepareWith+ , linkWith , dispatchWith , parseWith- , linkWith , payloadWith , requestWith , routerWith@@ -86,13 +87,33 @@ , Many(..) , one , mapMany+ -- ** Meta+ , Meta(..)+ , MetaBuilder+ , metaBuilderToMetaCodec+ , MetaCodec+ , MetaClient+ , metaCodecToMetaClient+ , MetaServer+ , metaCodecToMetaServer+ , mapMetaPath+ , mapMetaQuery+ , mapMetaRequestBody+ , mapMetaResponseBody+ , mapMeta -- * Codecs , CaptureEncoding(..)+ , HasCaptureEncoding(..) , CaptureDecoding(..)+ , HasCaptureDecoding(..) , CaptureCodec(..)+ , HasCaptureCodec(..) , BodyEncoding(..)+ , HasBodyEncoding(..) , BodyDecoding(..)+ , HasBodyDecoding(..) , BodyCodec(..)+ , HasBodyCodec(..) -- ** Converting Codecs , captureCodecToCaptureEncoding , captureCodecToCaptureDecoding@@ -126,8 +147,9 @@ import qualified Network.HTTP.Media.MediaType as N import qualified Network.HTTP.Media.Accept as N import qualified Data.HashMap.Strict as HM+import qualified Data.Semigroup as SG import Data.HashMap.Strict (HashMap)-import Data.Vinyl (Rec(..),rmap)+import Data.Vinyl (Rec(..),rmap,rtraverse) import Data.Vinyl.TypeLevel (type (++)) import Trasa.Method@@ -154,7 +176,7 @@ data Bodiedness = forall a. Body a | Bodyless data RequestBody :: (Type -> Type) -> Bodiedness -> Type where- RequestBodyPresent :: f a -> RequestBody f ('Body a)+ RequestBodyPresent :: !(f a) -> RequestBody f ('Body a) RequestBodyAbsent :: RequestBody f 'Bodyless body :: rqf req -> RequestBody rqf ('Body req)@@ -177,8 +199,8 @@ data Path :: (Type -> Type) -> [Type] -> Type where PathNil :: Path cap '[]- PathConsCapture :: cap a -> Path cap as -> Path cap (a ': as)- PathConsMatch :: T.Text -> Path cap as -> Path cap as+ PathConsCapture :: !(cap a) -> !(Path cap as) -> Path cap (a ': as)+ PathConsMatch :: !T.Text -> !(Path cap as) -> Path cap as infixr 7 ./ @@ -210,14 +232,14 @@ | forall a. List a data Parameter :: Param -> Type where- ParameterFlag :: Bool -> Parameter Flag- ParameterOptional :: Maybe a -> Parameter (Optional a)- ParameterList :: [a] -> Parameter (List a)+ ParameterFlag :: !Bool -> Parameter Flag+ ParameterOptional :: !(Maybe a) -> Parameter (Optional a)+ ParameterList :: ![a] -> Parameter (List a) data Query :: (Type -> Type) -> Param -> Type where- QueryFlag :: T.Text -> Query cap Flag- QueryOptional :: T.Text -> cap a -> Query cap (Optional a)- QueryList :: T.Text -> cap a -> Query cap (List a)+ QueryFlag :: !T.Text -> Query cap Flag+ 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@@ -242,17 +264,90 @@ QueryOptional key query -> QueryOptional key (eta query) QueryList key query -> QueryList key (eta query) +data Meta capCodec qryCodec reqCodec respCodec caps qrys req resp = Meta+ { metaPath :: !(Path capCodec caps)+ , metaQuery :: !(Rec (Query qryCodec) qrys)+ , metaRequestBody :: !(RequestBody reqCodec req)+ , metaResponseBody :: !(ResponseBody respCodec resp)+ , metaMethod :: !Method+ }++mapMetaPath+ :: (forall x. cf x -> cg x)+ -> Meta cf qryCodec reqCodec respCodec caps qrys req resp+ -> Meta cg qryCodec reqCodec respCodec caps qrys req resp+mapMetaPath eta m = m { metaPath = mapPath eta (metaPath m) }++mapMetaQuery+ :: (forall x. qf x -> qg x)+ -> Meta capCodec qf reqCodec respCodec caps qrys req resp+ -> Meta capCodec qg reqCodec respCodec caps qrys req resp+mapMetaQuery eta m = m { metaQuery = mapQuery eta (metaQuery m) }++mapMetaRequestBody+ :: (forall x. rf x -> rg x)+ -> Meta capCodec qryCodec rf respCodec caps qrys req resp+ -> Meta capCodec qryCodec rg respCodec caps qrys req resp+mapMetaRequestBody eta m = m { metaRequestBody = mapRequestBody eta (metaRequestBody m) }++mapMetaResponseBody+ :: (forall x. rf x -> rg x)+ -> Meta capCodec qryCodec reqCodec rf caps qrys req resp+ -> Meta capCodec qryCodec reqCodec rg caps qrys req resp+mapMetaResponseBody eta m = m { metaResponseBody = mapResponseBody eta (metaResponseBody m)}++mapMeta+ :: (forall x. capCodec1 x -> capCodec2 x)+ -> (forall x. qryCodec1 x -> qryCodec2 x)+ -> (forall x. reqCodec1 x -> reqCodec2 x)+ -> (forall x. respCodec1 x -> respCodec2 x)+ -> Meta capCodec1 qryCodec1 reqCodec1 respCodec1 caps qrys req resp+ -> Meta capCodec2 qryCodec2 reqCodec2 respCodec2 caps qrys req resp+mapMeta mapCaps mapQrys mapReq mapResp (Meta caps qrys req res method) = Meta+ (mapPath mapCaps caps)+ (mapQuery mapQrys qrys)+ (mapRequestBody mapReq req)+ (mapResponseBody mapResp res)+ method++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.+metaBuilderToMetaCodec+ :: Meta capCodec qryCodec reqCodec respCodec caps qrys req resp+ -> Meta capCodec qryCodec (Many reqCodec) (Many respCodec) caps qrys req resp+metaBuilderToMetaCodec (Meta path query reqBody respBody method) = Meta+ path+ query+ (mapRequestBody one reqBody)+ (mapResponseBody one respBody)+ method++type MetaCodec = Meta CaptureCodec CaptureCodec (Many BodyCodec) (Many BodyCodec)++type MetaClient = Meta CaptureEncoding CaptureEncoding (Many BodyEncoding) (Many BodyDecoding)++metaCodecToMetaClient :: MetaCodec caps qrys req resp -> MetaClient caps qrys req resp+metaCodecToMetaClient = mapMeta captureEncoding captureEncoding (mapMany bodyEncoding) (mapMany bodyDecoding)++type MetaServer = Meta CaptureDecoding CaptureDecoding (Many BodyDecoding) (Many BodyEncoding)++metaCodecToMetaServer :: MetaCodec caps qrys req resp -> MetaServer caps qrys req resp+metaCodecToMetaServer = mapMeta captureDecoding captureDecoding (mapMany bodyDecoding) (mapMany bodyEncoding)+ -- | Generate a @Url@ for use in hyperlinks.-linkWith :: forall route response.- (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)- -- ^ How to encode the path pieces of a route- -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)- -- ^ How to encode the query parameters of a route+linkWith+ :: forall route response reqCodec respCodec+ . (forall caps qrys req resp. route caps qrys req resp -> Meta CaptureEncoding CaptureEncoding reqCodec respCodec caps qrys req resp) -> Prepared route response -- ^ The route to encode -> Url-linkWith toCapEncs toQueries (Prepared route captures querys _) =- encodePieces (toCapEncs route) (toQueries route) captures querys+linkWith toMeta (Prepared route captures querys _) =+ encodePieces (metaPath m) (metaQuery m) captures querys+ where m = toMeta route data Payload = Payload { payloadUrl :: !Url@@ -261,43 +356,35 @@ } -- | Only useful for library authors-payloadWith :: forall route response.- (forall caps qrys req resp. route caps qrys req resp -> Path CaptureEncoding caps)- -- ^ How to encode the path pieces of a route- -> (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureEncoding) qrys)- -- ^ How to encode the query parameters of a route- -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyEncoding) req)- -- ^ How to encode the request body of a route- -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyDecoding) resp)- -- ^ How to decode the response body from a route+payloadWith+ :: forall route response+ . (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) -> Prepared route response -- ^ The route to be payload encoded -> Payload-payloadWith toCapEncs toQueries toReqBody toRespBody p@(Prepared route _ _ reqBody) =+payloadWith toMeta p@(Prepared route _ _ reqBody) = Payload url content accepts where- url = linkWith toCapEncs toQueries p- content = encodeRequestBody (toReqBody route) reqBody- ResponseBody (Many decodings) = toRespBody route+ url = linkWith toMeta p+ m = toMeta route+ content = encodeRequestBody (metaRequestBody m) reqBody+ ResponseBody (Many decodings) = metaResponseBody m accepts = bodyDecodingNames =<< decodings -- Only useful to implement packages like 'trasa-client'-requestWith :: Functor m- => (forall caps querys req resp. route caps querys req resp -> Method)- -> (forall caps querys req resp. route caps querys req resp -> Path CaptureEncoding caps)- -> (forall caps querys req resp. route caps querys req resp -> Rec (Query CaptureEncoding) querys)- -> (forall caps querys req resp. route caps querys req resp -> RequestBody (Many BodyEncoding) req)- -> (forall caps querys req resp. route caps querys req resp -> ResponseBody (Many BodyDecoding) resp)+requestWith+ :: Functor m+ => (forall caps qrys req resp. route caps qrys req resp -> MetaClient caps qrys req resp) -> (Method -> Url -> Maybe Content -> NonEmpty N.MediaType -> m (Either TrasaErr Content)) -- ^ method, url, content, accepts -> response -> Prepared route response -> m (Either TrasaErr response)-requestWith toMethod toCapEncs toQueries toReqBody toRespBody run (Prepared route captures querys reqBody) =- let method = toMethod route- url = encodePieces (toCapEncs route) (toQueries route) captures querys- content = encodeRequestBody (toReqBody route) reqBody- respBodyDecs = toRespBody route- ResponseBody (Many decodings) = respBodyDecs+requestWith toMeta run (Prepared route captures querys reqBody) =+ let m = toMeta route+ method = metaMethod m+ url = encodePieces (metaPath m) (metaQuery m) captures querys+ content = encodeRequestBody (metaRequestBody m) reqBody+ respBodyDecs@(ResponseBody (Many decodings)) = metaResponseBody m accepts = bodyDecodingNames =<< decodings in fmap (\c -> c >>= decodeResponseBody respBodyDecs) (run method url content accepts) @@ -321,7 +408,7 @@ where wrongBody = Left (status N.status415) go :: [BodyDecoding a] -> N.MediaType -> LBS.ByteString -> Either TrasaErr (RequestBody Identity (Body a))- go [] _ _ = Left (status N.status400)+ go [] _ _ = Left (status N.status415) go (BodyDecoding medias dec:decs) media bod = case any (flip N.matches media) medias of True -> bimap (TrasaErr N.status415 . LBS.fromStrict . T.encodeUtf8) (RequestBodyPresent . Identity)@@ -389,11 +476,10 @@ HM.insert key (QueryParamList (fmap enc vals)) (encodeQueries encs qs) -- | Only useful to implement packages like 'trasa-server'-dispatchWith :: forall route m.- Applicative m- => (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureDecoding) qrys)- -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyDecoding) req)- -> (forall caps qrys req resp. route caps qrys req resp -> ResponseBody (Many BodyEncoding) resp)+dispatchWith+ :: forall route m+ . Applicative m+ => (forall caps qrys req resp. route caps qrys req resp -> MetaServer caps qrys req resp) -> (forall caps qrys req resp. route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> m resp) -> Router route -- ^ Router -> Method -- ^ Method@@ -401,38 +487,41 @@ -> Url -- ^ Everything after the authority -> Maybe Content -- ^ Content type and request body -> m (Either TrasaErr Content) -- ^ Encoded response-dispatchWith toQueries toReqBody toRespBody makeResponse router method accepts url mcontent =- case parseWith toQueries toReqBody router method url mcontent of+dispatchWith toMeta makeResponse madeRouter method accepts url mcontent =+ case parseWith toMeta madeRouter method url mcontent of Left err -> pure (Left err) Right (Concealed route path querys reqBody) ->- encodeResponseBody accepts (toRespBody route) <$> makeResponse route path querys reqBody+ encodeResponseBody accepts (metaResponseBody (toMeta route)) <$>+ makeResponse route path querys reqBody -- | Build a router from all the possible routes, and methods to turn routes into needed metadata-routerWith ::- (forall caps querys req resp. route caps querys req resp -> Method)- -- ^ Get the method from a route- -> (forall caps querys req resp. route caps querys req resp -> Path CaptureDecoding caps)- -- ^ How to decode path pieces of a route+routerWith+ :: forall route qryCodec reqCodec respCodec+ . (forall caps qrys req resp. route caps qrys req resp -> Meta CaptureDecoding qryCodec reqCodec respCodec caps qrys req resp) -> [Constructed route] -> Router route-routerWith toMethod toCapDec enumeratedRoutes = Router $ foldMap- (\(Constructed route) -> singletonIxedRouter route (toMethod route) (toCapDec route))- enumeratedRoutes+routerWith toMeta = Router . foldMap buildRouter+ where+ buildRouter :: Constructed route -> IxedRouter route Z+ buildRouter (Constructed route) = singletonIxedRouter route (metaMethod m) (metaPath m)+ where m = toMeta route + -- | Parses the path, the querystring, and the request body.-parseWith :: forall route.- (forall caps qrys req resp. route caps qrys req resp -> Rec (Query CaptureDecoding) qrys)- -> (forall caps qrys req resp. route caps qrys req resp -> RequestBody (Many BodyDecoding) req)+parseWith+ :: forall route capCodec respCodec+ . (forall caps qrys req resp. route caps qrys req resp -> Meta capCodec CaptureDecoding (Many BodyDecoding) respCodec caps qrys req resp) -> Router route -- ^ Router -> Method -- ^ Request Method -> Url -- ^ Everything after the authority -> Maybe Content -- ^ Request content type and body -> Either TrasaErr (Concealed route)-parseWith toQueries toReqBody router method (Url encodedPath encodedQuery) mcontent = do+parseWith toMeta madeRouter method (Url encodedPath encodedQuery) mcontent = do Pathed route captures <- maybe (Left (status N.status404)) Right- $ parsePathWith router method encodedPath- querys <- parseQueryWith (toQueries route) encodedQuery- reqBody <- decodeRequestBody (toReqBody route) mcontent+ $ parsePathWith madeRouter method encodedPath+ let m = toMeta route+ querys <- parseQueryWith (metaQuery m) encodedQuery+ reqBody <- decodeRequestBody (metaRequestBody m) mcontent return (Concealed route captures querys reqBody) -- | Parses only the path.@@ -468,26 +557,23 @@ in res1 ++ res2 parseQueryWith :: Rec (Query CaptureDecoding) querys -> QueryString -> Either TrasaErr (Rec Parameter querys)-parseQueryWith decoding (QueryString querys) = go decoding+parseQueryWith decoding (QueryString querys) = rtraverse param decoding where- go :: Rec (Query CaptureDecoding) qrys -> Either TrasaErr (Rec Parameter qrys)- go RNil = Right RNil- go (q :& qs) = (:&) <$> param <*> go qs- where- param = case q of- QueryFlag key -> Right (ParameterFlag (HM.member key querys))- QueryOptional key (CaptureDecoding dec) -> case HM.lookup key querys of- Nothing -> Right (ParameterOptional Nothing)- Just query -> case query of- QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected")- QueryParamSingle txt -> Right (ParameterOptional (dec txt))- QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected")- QueryList key (CaptureDecoding dec) -> case HM.lookup key querys of- Nothing -> Right (ParameterList [])- Just query -> case query of- QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when list expected")- QueryParamSingle txt -> Right (ParameterList (maybe [] (:[]) (dec txt)))- QueryParamList txts -> Right (ParameterList (mapMaybe dec txts))+ param :: forall qry. Query CaptureDecoding qry -> Either TrasaErr (Parameter qry)+ param = \case+ QueryFlag key -> Right (ParameterFlag (HM.member key querys))+ QueryOptional key (CaptureDecoding dec) -> case HM.lookup key querys of+ Nothing -> Right (ParameterOptional Nothing)+ Just query -> case query of+ QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when key-value expected")+ QueryParamSingle txt -> Right (ParameterOptional (dec txt))+ QueryParamList _ -> Left (TrasaErr N.status400 "query param list given when key-value expected")+ QueryList key (CaptureDecoding dec) -> case HM.lookup key querys of+ Nothing -> Right (ParameterList [])+ Just query -> case query of+ QueryParamFlag -> Left (TrasaErr N.status400 "query flag given when list expected")+ QueryParamSingle txt -> Right (ParameterList (maybe [] (:[]) (dec txt)))+ QueryParamList txts -> Right (ParameterList (mapMaybe dec txts)) decodeCaptureVector :: IxedRec CaptureDecoding n xs@@ -525,26 +611,23 @@ Arguments '[] (q ': qs) r b = ParamBase q -> Arguments '[] qs r b Arguments (c ': cs) qs b r = c -> Arguments cs qs b r + -- | Used my users to define a function called prepare, see tutorial-prepareWith ::- (forall caps qry req resp. route caps qry req resp -> Path pf caps)- -- ^ Extract the path codec from a route- -> (forall caps qry req resp. route caps qry req resp -> Rec (Query qf) qry)- -- ^ Extract the query parameter codec from a route- -> (forall caps qry req resp. route caps qry req resp -> RequestBody rqf req)- -- ^ Extract the request body codec from a route+prepareWith+ :: (forall caps qrys req resp. route caps qrys req resp -> Meta capCodec qryCodec reqCodec respCodec caps qrys req resp) -> route captures query request response -- ^ The route to prepare -> Arguments captures query request (Prepared route response)-prepareWith toPath toQuery toReqBody route =- prepareExplicit route (toPath route) (toQuery route) (toReqBody route)+prepareWith toMeta route =+ prepareExplicit route (metaPath m) (metaQuery m) (metaRequestBody m)+ where m = toMeta route -prepareExplicit :: forall route captures querys request response rqf pf qf.- route captures querys request response+prepareExplicit :: forall route captures queries request response rqf pf qf.+ route captures queries request response -> Path pf captures- -> Rec (Query qf) querys+ -> Rec (Query qf) queries -> RequestBody rqf request- -> Arguments captures querys request (Prepared route response)+ -> Arguments captures queries request (Prepared route response) prepareExplicit route = go (Prepared route) where -- Adopted from: https://www.reddit.com/r/haskell/comments/67l9so/currying_a_typelevel_list/dgrghxz/@@ -593,31 +676,27 @@ -- and the response body. This is needed so that users can -- enumerate over all the routes. data Constructed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where- Constructed :: route captures querys request response -> Constructed route+ Constructed :: !(route captures querys request response) -> Constructed route -- I dont really like the name Constructed, but I don't want to call it -- Some or Any since these get used a lot and a conflict would be likely. -- Think, think, think. mapConstructed ::- (forall caps qrys req resp. sub caps qrys req resp -> route cap qrys req resp)+ (forall caps qrys req resp. sub caps qrys req resp -> route caps qrys req resp) -> Constructed sub -> Constructed route mapConstructed f (Constructed sub) = Constructed (f sub) --- | Only includes the path. Once querystring params get added--- to this library, this data type should not have them. This--- type is only used internally and should not be exported. data Pathed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where- Pathed :: route captures querys request response -> Rec Identity captures -> Pathed route+ Pathed :: !(route captures querys request response) -> !(Rec Identity captures) -> Pathed route --- | Includes the path and the request body (and the querystring--- params after they get added to this library).+-- | Includes the route, path, query parameters, and request body. data Prepared :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type -> Type where Prepared ::- route captures querys request response- -> Rec Identity captures- -> Rec Parameter querys- -> RequestBody Identity request+ !(route captures querys request response)+ -> !(Rec Identity captures)+ -> !(Rec Parameter querys)+ -> !(RequestBody Identity request) -> Prepared route response -- | Only needed to implement 'parseWith'. Most users do not need this.@@ -625,20 +704,27 @@ -- then you will need this. data Concealed :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Type where Concealed ::- route captures querys request response- -> Rec Identity captures- -> Rec Parameter querys- -> RequestBody Identity request+ !(route captures querys request response)+ -> !(Rec Identity captures)+ -> !(Rec Parameter querys)+ -> !(RequestBody Identity request) -> Concealed route -- | Conceal the response type. conceal :: Prepared route response -> Concealed route conceal (Prepared route caps querys req) = Concealed route caps querys req +concealedToPrepared+ :: forall route a+ . Concealed route+ -> (forall resp. Prepared route resp -> a)+ -> a+concealedToPrepared (Concealed route caps qrys req) f = f (Prepared route caps qrys req)+ -- | The HTTP content type and body. data Content = Content- { contentType :: N.MediaType- , contentData :: LBS.ByteString+ { contentType :: !N.MediaType+ , contentData :: !LBS.ByteString } deriving (Show,Eq,Ord) -- | Only promoted version used.@@ -648,9 +734,9 @@ data IxedRouter :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where IxedRouter ::- HashMap T.Text (IxedRouter route n)- -> Maybe (IxedRouter route ('S n))- -> HashMap T.Text [IxedResponder route n] -- Should be either zero or one, more than one means that there are trivially overlapped routes+ !(HashMap T.Text (IxedRouter route n))+ -> !(Maybe (IxedRouter route ('S n)))+ -> !(HashMap T.Text [IxedResponder route n]) -- Should be either zero or one, more than one means that there are trivially overlapped routes -> IxedRouter route n -- | This monoid instance is provided so that we can@@ -662,35 +748,38 @@ -- routes were overlapped. instance Monoid (IxedRouter route n) where mempty = IxedRouter HM.empty Nothing HM.empty- mappend = unionIxedRouter+ mappend = (SG.<>) +instance SG.Semigroup (IxedRouter route n) where+ (<>) = unionIxedRouter+ data IxedResponder :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where IxedResponder ::- route captures query request response- -> IxedRec CaptureDecoding n captures+ !(route captures query request response)+ -> !(IxedRec CaptureDecoding n captures) -> IxedResponder route n data IxedRec :: (k -> Type) -> Nat -> [k] -> Type where IxedRecNil :: IxedRec f 'Z '[]- IxedRecCons :: !(f r) -> IxedRec f n rs -> IxedRec f ('S n) (r ': rs)+ IxedRecCons :: !(f r) -> !(IxedRec f n rs) -> IxedRec f ('S n) (r ': rs) data Vec :: Nat -> Type -> Type where VecNil :: Vec 'Z a- VecCons :: !a -> Vec n a -> Vec ('S n) a+ VecCons :: !a -> !(Vec n a) -> Vec ('S n) a data IxedPath :: (Type -> Type) -> Nat -> [Type] -> Type where IxedPathNil :: IxedPath f 'Z '[]- IxedPathCapture :: f a -> IxedPath f n as -> IxedPath f ('S n) (a ': as)- IxedPathMatch :: T.Text -> IxedPath f n a -> IxedPath f n a+ IxedPathCapture :: !(f a) -> !(IxedPath f n as) -> IxedPath f ('S n) (a ': as)+ IxedPathMatch :: !T.Text -> !(IxedPath f n a) -> IxedPath f n a data LenPath :: Nat -> Type where LenPathNil :: LenPath 'Z- LenPathCapture :: LenPath n -> LenPath ('S n)- LenPathMatch :: T.Text -> LenPath n -> LenPath n+ LenPathCapture :: !(LenPath n) -> LenPath ('S n)+ LenPathMatch :: !T.Text -> !(LenPath n) -> LenPath n -- Assumes length is in penultimate position. data HideIx :: (Nat -> k -> Type) -> k -> Type where- HideIx :: f n a -> HideIx f a+ HideIx :: !(f n a) -> HideIx f a -- toIxedRec :: Rec f xs -> HideIx (IxedRec f) xs -- toIxedRec RNil = HideIx IxedRecNil
+ src/Trasa/Core/Implicit.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Trasa.Core.Implicit+ (+ HasMeta(..)+ , prepare+ , link+ , parse+ , EnumerableRoute(..)+ , router+ ) where++import Data.Kind (Type)++import Trasa.Core++class HasMeta route where+ type CaptureStrategy route :: Type -> Type+ type CaptureStrategy route = CaptureCodec+ type QueryStrategy route :: Type -> Type+ type QueryStrategy route = CaptureCodec+ type RequestBodyStrategy route :: Type -> Type+ type RequestBodyStrategy route = Many BodyCodec+ type ResponseBodyStrategy route :: Type -> Type+ type ResponseBodyStrategy route = Many BodyCodec+ meta+ :: route caps qrys req resp+ -> Meta (CaptureStrategy route) (QueryStrategy route) (RequestBodyStrategy route) (ResponseBodyStrategy route) caps qrys req resp++prepare+ :: HasMeta route+ => route captures queries request response+ -> Arguments captures queries request (Prepared route response)+prepare = prepareWith meta++link+ :: (HasMeta route, HasCaptureEncoding (CaptureStrategy route), HasCaptureEncoding (QueryStrategy route))+ => Prepared route response+ -> Url+link = linkWith toMeta+ where+ toMeta route = m+ { metaPath = mapPath captureEncoding (metaPath m)+ , metaQuery = mapQuery captureEncoding (metaQuery m)+ }+ where m = meta route++parse+ :: ( HasMeta route+ , HasCaptureDecoding (CaptureStrategy route)+ , HasCaptureDecoding (QueryStrategy route)+ , RequestBodyStrategy route ~ Many strat+ , HasBodyDecoding strat+ , EnumerableRoute route )+ => Method -- ^ Request Method+ -> Url -- ^ Everything after the authority+ -> Maybe Content -- ^ Request content type and body+ -> Either TrasaErr (Concealed route)+parse = parseWith (mapMetaQuery captureDecoding . mapMetaRequestBody (mapMany bodyDecoding) . meta) router++class EnumerableRoute route where+ enumerateRoutes :: [Constructed route]++router+ :: (HasMeta route, HasCaptureDecoding (CaptureStrategy route), EnumerableRoute route)+ => Router route+router = routerWith (mapMetaPath captureDecoding . meta) enumerateRoutes
src/Trasa/Tutorial.hs view
@@ -36,13 +36,6 @@ -- IncrementR :: Route '[Counter] '[] 'Bodyless Int -- QueryR :: Route '[Counter] '[]Bodyless Int -- TotalR :: Route '[] '[] 'Bodyless Int--- data Meta captures querys request response = Meta--- { metaPath :: Path CaptureCodec captures--- , metaQuery :: Rec (Query CaptureCodec) querys--- , metaRequestBody :: RequestBody BodyCodec request--- , metaResponseBody :: ResponseBody BodyCodec response--- , metaMethod :: Method--- } -- int :: CaptureCodec Int -- int = showReadCaptureCodec -- counter :: CaptureCodec Counter@@ -51,8 +44,8 @@ -- bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ())) -- bodyInt :: BodyCodec Int -- bodyInt = showReadBodyCodec--- meta :: Route captures querys request response -> Meta captures querys request response--- meta x = case x of+-- meta :: Route captures querys request response -> MetaCodec captures querys request response+-- meta x = metaBuilderToMetaCodec $ case x of -- AssignR -> Meta -- (match "assign" ./ capture counter ./ match "to" ./ capture int ./ end) -- qend@@ -75,14 +68,13 @@ -- @trasa@ exports and partially apply them to the route metadata that -- we have created. We can start with prepare and link: ----- >>> prepare = prepareWith (metaPath . meta) (metaQuery . meta) (metaRequestBody . meta)+-- >>> prepare = prepareWith meta -- >>> :t prepare -- prepare -- :: Route captures query request response -- -> Arguments captures query request (Prepared Route response) -- >>> :{--- link = linkWith (mapPath captureCodecToCaptureEncoding . metaPath . meta)--- (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)+-- link = linkWith (metaCodecToMetaClient . meta) -- :} -- -- >>> :t link
test/Main.hs view
@@ -1,13 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} import Text.Read (readMaybe) import Trasa.Core+import Trasa.Core.Implicit import qualified Trasa.Method as M import Data.Vinyl import Data.Kind (Type)@@ -27,10 +31,10 @@ main = do putStrLn "\nRUNNING DOCTESTS" doctest- [ "src/Trasa"+ [ "src" ] putStrLn "\nPRETTY ROUTER"- putStrLn (prettyRouter router)+ putStrLn (prettyRouter (router @Route)) putStrLn "\nRUNNING OTHER TESTS" defaultMain tests @@ -51,11 +55,14 @@ , testCase "link left pad route" $ link (prepare LeftPadR 5 "foo") @?= decodeUrl "/pad/left/5" , testCase "parse hello route"- $ parse "/hello" Nothing @?= Right (conceal (prepare HelloR))+ $ parseUrl "/hello" @?= Right (conceal (prepare HelloR)) , testCase "parse addition route"- $ parse "/add/6/3" Nothing @?= Right (conceal (prepare AdditionR 6 3 Nothing))+ $ parseUrl "/add/6/3" @?= Right (conceal (prepare AdditionR 6 3 Nothing)) ] +parseUrl :: T.Text -> Either TrasaErr (Concealed Route)+parseUrl url = parse "GET" (decodeUrl url) Nothing+ data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where EmptyR :: Route '[] '[] Bodyless Int HelloR :: Route '[] '[] Bodyless Int@@ -65,77 +72,52 @@ TrickyOneR :: Route '[Int] '[] Bodyless String TrickyTwoR :: Route '[Int,Int] '[] Bodyless String -prepare :: Route cs qs rq rp -> Arguments cs qs rq (Prepared Route rp)-prepare = prepareWith (metaPath . meta) (metaQuery . meta) (metaRequestBody . meta)--link :: Prepared Route rp -> Url-link = linkWith- (mapPath (CaptureEncoding . captureCodecEncode) . metaPath . meta)- (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)--parse :: T.Text -> Maybe Content -> Either TrasaErr (Concealed Route)-parse url = parseWith- (mapQuery captureCodecToCaptureDecoding . metaQuery . meta)- (mapRequestBody (Many . pure . bodyCodecToBodyDecoding) . metaRequestBody . meta)- router- "get"- (decodeUrl url)--allRoutes :: [Constructed Route]-allRoutes =- [ Constructed HelloR- , Constructed AdditionR- , Constructed IdentityR- , Constructed LeftPadR- , Constructed TrickyOneR- , Constructed TrickyTwoR- , Constructed EmptyR- ]--router :: Router Route-router = routerWith- (metaMethod . meta)- (mapPath (CaptureDecoding . captureCodecDecode) . metaPath . meta)- allRoutes--data Meta ps qs rq rp = Meta- { metaPath :: Path CaptureCodec ps- , metaQuery :: Rec (Query CaptureCodec) qs- , metaRequestBody :: RequestBody BodyCodec rq- , metaResponseBody :: ResponseBody BodyCodec rp- , metaMethod :: Method- }+instance EnumerableRoute Route where+ enumerateRoutes =+ [ Constructed HelloR+ , Constructed AdditionR+ , Constructed IdentityR+ , Constructed LeftPadR+ , Constructed TrickyOneR+ , Constructed TrickyTwoR+ , Constructed EmptyR+ ] -meta :: Route ps qs rq rp -> Meta ps qs rq rp-meta x = case x of- EmptyR -> Meta- end- qend- bodyless (resp bodyInt) M.get- HelloR -> Meta- (match "hello" ./ end)- qend- bodyless (resp bodyInt) M.get- AdditionR -> Meta- (match "add" ./ capture int ./ capture int ./ end)- (optional "more" int .& qend)- bodyless (resp bodyInt) M.get- IdentityR -> Meta- (match "identity" ./ capture string ./ end)- qend- bodyless (resp bodyString) M.get- LeftPadR -> Meta- (match "pad" ./ match "left" ./ capture int ./ end)- qend- (body bodyString) (resp bodyString) M.get- TrickyOneR -> Meta- (match "tricky" ./ capture int ./ match "one" ./ end)- qend- bodyless (resp bodyString) M.get- TrickyTwoR -> Meta- (capture int ./ capture int ./ match "two" ./ end)- qend- bodyless (resp bodyString) M.get+instance HasMeta Route where+ type CaptureStrategy Route = CaptureCodec+ type QueryStrategy Route = CaptureCodec+ type RequestBodyStrategy Route = Many BodyCodec+ type ResponseBodyStrategy Route = Many BodyCodec+ meta :: Route ps qs rq rp -> MetaCodec ps qs rq rp+ meta x = metaBuilderToMetaCodec $ case x of+ EmptyR -> Meta+ end+ qend+ bodyless (resp bodyInt) M.get+ HelloR -> Meta+ (match "hello" ./ end)+ qend+ bodyless (resp bodyInt) M.get+ AdditionR -> Meta+ (match "add" ./ capture int ./ capture int ./ end)+ (optional "more" int .& qend)+ bodyless (resp bodyInt) M.get+ IdentityR -> Meta+ (match "identity" ./ capture string ./ end)+ qend+ bodyless (resp bodyString) M.get+ LeftPadR -> Meta+ (match "pad" ./ match "left" ./ capture int ./ end)+ qend+ (body bodyString) (resp bodyString) M.get+ TrickyOneR -> Meta+ (match "tricky" ./ capture int ./ match "one" ./ end)+ qend+ bodyless (resp bodyString) M.get+ TrickyTwoR -> Meta+ (capture int ./ capture int ./ match "two" ./ end)+ qend+ bodyless (resp bodyString) M.get int :: CaptureCodec Int int = CaptureCodec (T.pack . show) (readMaybe . T.unpack)@@ -164,7 +146,7 @@ RequestBodyAbsent -> True ) ==>- Right c == parse (encodeUrl (link (Prepared route captures querys reqBody))) Nothing+ Right c == parseUrl (encodeUrl (link (Prepared route captures querys reqBody))) -- This instance is defined only so that the test suite can do -- its job. It not not neccessary or recommended to write this
trasa.cabal view
@@ -1,21 +1,20 @@ name: trasa-version: 0.2+version: 0.3 synopsis: Type Safe Web Routing homepage: https://github.com/haskell-trasa/trasa#readme license: BSD3 license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2017 Andrew Martin+author: Kyle McKean+maintainer: mckean.kylej@gmail.com+copyright: 2017 Kyle McKean category: Web build-type: Simple cabal-version: >=1.10 description:- This library is a solution for http-based routing and dispatch. It's- goals are similar to the goals of `servant`. However, `trasa` relies- on very different mechanisms to accomplish this. There are no typeclasses- in this library, and there is a single closed type family that is provided- as a convenience. All of the real work is accomplish with GADTs, + This library is a solution for http-based routing and dispatch. Its+ goals are similar to the goals of `servant`, however, `trasa` relies+ on very different mechanisms to accomplish those goals. All typeclasses+ in this library are optional. All of the real work is accomplished with GADTs, universal quantification, and plain old haskell data types. library@@ -26,16 +25,17 @@ Trasa.Codec Trasa.Error Trasa.Core+ Trasa.Core.Implicit Trasa.Tutorial build-depends: base >= 4.7 && < 5 , bytestring == 0.10.* , binary == 0.8.* , text == 1.2.*- , vinyl == 0.5.*+ , vinyl >= 0.5 && < 0.9 , hashable == 1.2.*- , http-types == 0.9.*- , http-media == 0.6.*+ , http-types >= 0.9+ , http-media >= 0.6 && < 0.8 , unordered-containers >= 0.2 && < 0.3 default-language: Haskell2010