trasa 0.2 → 0.4.1
raw patch · 8 files changed
Files
- LICENSE +5/−27
- src/Trasa/Codec.hs +54/−0
- src/Trasa/Core.hs +294/−174
- src/Trasa/Core/Implicit.hs +67/−0
- src/Trasa/Tutorial.hs +0/−96
- test/Doctest.hs +10/−0
- test/Main.hs +0/−219
- trasa.cabal +76/−41
LICENSE view
@@ -1,30 +1,8 @@-Copyright Andrew Martin (c) 2017--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Copyright 2017-2019 Andrew Martin+Copyright 2017-2019 Kyle McKean - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - * Neither the name of Andrew Martin nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
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@@ -64,6 +65,7 @@ , Rec(..) , demoteParameter , flag+ , required , optional , list , qend@@ -86,13 +88,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@@ -112,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@@ -126,9 +148,10 @@ 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.TypeLevel (type (++))+import qualified Topaz.Rec as Topaz+import Topaz.Types (Rec(..), type (++)) import Trasa.Method import Trasa.Url@@ -151,10 +174,11 @@ mapMany :: (forall x. f x -> g x) -> Many f a -> Many g a mapMany eta (Many m) = Many (fmap eta m) +-- | the type of the HTTP message body (json, text, etc) <https://en.wikipedia.org/wiki/HTTP_message_body> 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,11 +201,12 @@ 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 +-- | flipped ($), useful for constructing routes. e.g.+-- > match "add" ./ capture int ./ capture int ./ end infixr 7 ./- (./) :: (a -> b) -> a -> b (./) f a = f a @@ -206,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- ParameterOptional :: Maybe a -> Parameter (Optional a)- ParameterList :: [a] -> Parameter (List a)+ 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- QueryOptional :: T.Text -> cap a -> Query cap (Optional a)- QueryList :: T.Text -> cap a -> Query cap (List a)+ 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 @@ -229,30 +260,103 @@ list = QueryList qend :: Rec (Query qpf) '[]-qend = RNil+qend = RecNil infixr 7 .& (.&) :: Query qpf q -> Rec (Query qpf) qs -> Rec (Query qpf) (q ': qs)-(.&) = (:&)+(.&) = RecCons mapQuery :: (forall x. f x -> g x) -> Rec (Query f) qs -> Rec (Query g) qs-mapQuery eta = rmap $ \case+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) +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 +365,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) @@ -317,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.status400)- go (BodyDecoding medias dec:decs) media bod = case any (flip N.matches media) medias of+ go [] _ _ = Left (status N.status415)+ 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]@@ -370,30 +473,32 @@ . Path CaptureEncoding caps -> Rec Identity caps -> [T.Text]- encodePath PathNil RNil = []+ encodePath PathNil RecNil = [] encodePath (PathConsMatch str ps) xs = str : encodePath ps xs- encodePath (PathConsCapture (CaptureEncoding enc) ps) (Identity x :& xs) = enc x : encodePath ps xs+ encodePath (PathConsCapture (CaptureEncoding enc) ps) (Identity x `RecCons` xs) = enc x : encodePath ps xs encodeQueries :: forall qrys . Rec (Query CaptureEncoding) qrys -> Rec Parameter qrys -> HM.HashMap T.Text QueryParam- encodeQueries RNil RNil = HM.empty- encodeQueries (QueryFlag key :& encs) (ParameterFlag on :& qs) =+ encodeQueries RecNil RecNil = HM.empty+ 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 (QueryOptional key (CaptureEncoding enc) :& encs) (ParameterOptional mval :& 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- encodeQueries (QueryList key (CaptureEncoding enc) :& encs) (ParameterList vals :& qs) =+ encodeQueries (QueryList key (CaptureEncoding enc) `RecCons` encs) (ParameterList vals `RecCons` qs) = 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,112 +506,123 @@ -> 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- Pathed route captures <- maybe (Left (status N.status404)) Right- $ parsePathWith router method encodedPath- querys <- parseQueryWith (toQueries route) encodedQuery- reqBody <- decodeRequestBody (toReqBody route) mcontent- return (Concealed route captures querys reqBody)+parseWith toMeta madeRouter method (Url encodedPath encodedQuery) mcontent = do+ Pathed route captures <- parsePathWith madeRouter method encodedPath+ let m = toMeta route+ querys <- parseQueryWith (metaQuery m) encodedQuery+ reqBody <- decodeRequestBody (metaRequestBody m) mcontent+ 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) = go decoding+parseQueryWith decoding (QueryString querys) = Topaz.traverse 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))+ 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+ 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 -> Vec n T.Text -> Maybe (Rec Identity xs)-decodeCaptureVector IxedRecNil VecNil = Just RNil+decodeCaptureVector IxedRecNil VecNil = Just RecNil decodeCaptureVector (IxedRecCons (CaptureDecoding decode) rnext) (VecCons piece vnext) = do val <- decode piece vals <- decodeCaptureVector rnext vnext- return (Identity val :& 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 @@ -525,26 +641,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/@@ -554,18 +667,19 @@ -> Rec (Query qf) qrys -> RequestBody rqf request -> Arguments caps qrys request z- go k PathNil RNil RequestBodyAbsent =- k RNil RNil RequestBodyAbsent- go k PathNil RNil (RequestBodyPresent _) =- \reqBod -> k RNil RNil (RequestBodyPresent (Identity reqBod))- go k PathNil (q :& qs) b =- \qt -> go (\caps querys reqBody -> k caps (parameter q qt :& querys) reqBody) PathNil qs b+ go k PathNil RecNil RequestBodyAbsent =+ k RecNil RecNil RequestBodyAbsent+ go k PathNil RecNil (RequestBodyPresent _) =+ \reqBod -> k RecNil RecNil (RequestBodyPresent (Identity reqBod))+ go k PathNil (q `RecCons` qs) b =+ \qt -> go (\caps querys reqBody -> k caps (parameter q qt `RecCons` querys) reqBody) PathNil qs b go k (PathConsMatch _ pnext) qs b = go k pnext qs b go k (PathConsCapture _ pnext) qs b =- \c -> go (\caps querys reqBod -> k (Identity c :& caps) querys reqBod) pnext qs b+ \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 @@ -584,40 +698,36 @@ -> RequestBody Identity request -> Arguments caps qrys request x -> x- go RNil RNil RequestBodyAbsent f = f- go RNil RNil (RequestBodyPresent (Identity b)) f = f b- go RNil (q :& qs) b f = go RNil qs b (f (demoteParameter q))- go (Identity c :& cs) qs b f = go cs qs b (f c)+ go RecNil RecNil RequestBodyAbsent f = f+ go RecNil RecNil (RequestBodyPresent (Identity b)) f = f b+ go RecNil (q `RecCons` qs) b f = go RecNil qs b (f (demoteParameter q))+ go (Identity c `RecCons` cs) qs b f = go cs qs b (f c) -- | A route with all types hidden: the captures, the request body, -- 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 +735,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 +765,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,39 +779,42 @@ -- 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--- toIxedRec (r :& rs) = case toIxedRec rs of+-- toIxedRec RecNil = HideIx IxedRecNil+-- toIxedRec (r `RecCons` rs) = case toIxedRec rs of -- HideIx x -> HideIx (IxedRecCons r x) snocVec :: a -> Vec n a -> Vec ('S n) a
+ 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
@@ -1,96 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--{-| Users of this library should a data type representing all possible- routes available in a web application. It is recommended that- this type be named @Route@, but this is not required.--}--module Trasa.Tutorial- ( -- * Dispatch and Routing- -- $dispatchandrouting- ) where--import Trasa.Core-import qualified Trasa.Method as M-import Data.Vinyl (Rec)-import Data.Kind (Type)-import Data.Text (Text)---- $setup--- >>> :set -XDataKinds--- >>> :set -XKindSignatures--- >>> :set -XGADTs--- >>> :set -XOverloadedStrings---- $dispatchandrouting--- In this example, we will write web application that maintains three--- counters. The end user will be able to perform various operations--- that manipulate the values of these counters and ask for their--- current value. We begin by defining our route type:------ >>> :{--- data Counter = Red | Green | Blue--- deriving (Show,Read)--- data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where--- AssignR :: Route '[Counter,Int] '[] 'Bodyless ()--- 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--- counter = showReadCaptureCodec--- bodyUnit :: BodyCodec ()--- 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--- AssignR -> Meta--- (match "assign" ./ capture counter ./ match "to" ./ capture int ./ end)--- qend--- bodyless (resp bodyUnit) M.post--- IncrementR -> Meta--- (match "increment" ./ capture counter ./ end)--- qend--- bodyless (resp bodyInt) M.post--- QueryR -> Meta--- (match "query" ./ capture counter ./ end)--- qend--- bodyless (resp bodyInt) M.get--- TotalR -> Meta--- (match "total" ./ end)--- qend--- bodyless (resp bodyInt) M.get--- :}------ Now, we can start using our routes. To do this, we take functions that--- @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)--- >>> :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)--- :}------ >>> :t link--- link :: Prepared Route response -> Url------ Now we can use link to encode our routes:------ >>> link (prepare AssignR Green 5)--- "/assign/Green/to/5"------
+ test/Doctest.hs view
@@ -0,0 +1,10 @@+module Main (main) where++import Test.DocTest (doctest)++main :: IO ()+main = do+ putStrLn "\nRUNNING DOCTESTS"+ doctest+ [ "src"+ ]
− test/Main.hs
@@ -1,219 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--import Text.Read (readMaybe)-import Trasa.Core-import qualified Trasa.Method as M-import Data.Vinyl-import Data.Kind (Type)--import qualified Data.ByteString.Lazy.Char8 as LBSC-import qualified Data.Text as T--import Test.Tasty-import Test.Tasty.QuickCheck as QC-import Test.Tasty.HUnit-import Data.Functor.Identity-import Data.Monoid--import Test.DocTest (doctest)--main :: IO ()-main = do- putStrLn "\nRUNNING DOCTESTS"- doctest- [ "src/Trasa"- ]- putStrLn "\nPRETTY ROUTER"- putStrLn (prettyRouter router)- putStrLn "\nRUNNING OTHER TESTS"- defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [properties, unitTests]---- todo: add a property test to show that parse and link--- form a partial isomorphism.-properties :: TestTree-properties = testGroup "Properties"- [ QC.testProperty "roundtrip link parse" roundtripLinkParse- ]--unitTests :: TestTree-unitTests = testGroup "Unit Tests"- [ testCase "link addition route"- $ link (prepare AdditionR 12 5 (Just 3)) @?= decodeUrl "/add/12/5?more=3"- , 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))- , testCase "parse addition route"- $ parse "/add/6/3" Nothing @?= Right (conceal (prepare AdditionR 6 3 Nothing))- ]--data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where- EmptyR :: Route '[] '[] Bodyless Int- HelloR :: Route '[] '[] Bodyless Int- AdditionR :: Route '[Int,Int] '[Optional Int] Bodyless Int- IdentityR :: Route '[String] '[] Bodyless String- LeftPadR :: Route '[Int] '[] (Body String) String- 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- }--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--int :: CaptureCodec Int-int = CaptureCodec (T.pack . show) (readMaybe . T.unpack)--string :: CaptureCodec String-string = CaptureCodec T.pack (Just . T.unpack)--bodyString :: BodyCodec String-bodyString = BodyCodec (pure "text/plain") LBSC.pack (Right . LBSC.unpack)--bodyUnit :: BodyCodec ()-bodyUnit = BodyCodec (pure "text/plain") (const "") (const (Right ()))--note :: e -> Maybe a -> Either e a-note e Nothing = Left e-note _ (Just x) = Right x--bodyInt :: BodyCodec Int-bodyInt = BodyCodec (pure "text/plain") (LBSC.pack . show)- (note "Could not decode int" . readMaybe . LBSC.unpack)--roundtripLinkParse :: Concealed Route -> Property-roundtripLinkParse c@(Concealed route captures querys reqBody) =- (case reqBody of- RequestBodyPresent _ -> False- RequestBodyAbsent -> True- )- ==>- Right c == parse (encodeUrl (link (Prepared route captures querys reqBody))) Nothing---- This instance is defined only so that the test suite can do--- its job. It not not neccessary or recommended to write this--- instance in production code.-instance Eq (Concealed Route) where- Concealed rt1 ps1 qs1 rq1 == Concealed rt2 ps2 qs2 rq2 = case (rt1,rt2) of- (AdditionR,AdditionR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2- (IdentityR,IdentityR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2- (LeftPadR,LeftPadR) -> case (rq1,rq2) of- (RequestBodyPresent a, RequestBodyPresent b) -> ps1 == ps2 && qs1 == qs2 && a == b- (TrickyOneR,TrickyOneR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2- (TrickyTwoR,TrickyTwoR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2- (HelloR,HelloR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2- (EmptyR,EmptyR) -> ps1 == ps2 && qs1 == qs2 && rq1 == rq2--instance Arbitrary (Concealed Route) where- arbitrary = oneof- [ Concealed AdditionR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed IdentityR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed LeftPadR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed TrickyOneR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed TrickyTwoR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed HelloR <$> arbitrary <*> arbitrary <*> arbitrary- , Concealed EmptyR <$> arbitrary <*> arbitrary <*> arbitrary- ]--instance Show (Concealed Route) where- show (Concealed r a q b) = show (link (Prepared r a q b))--instance Eq a => Eq (Parameter (Optional a)) where- ParameterOptional m1 == ParameterOptional m2 = m1 == m2--instance Arbitrary (Rec Identity '[]) where- arbitrary = pure RNil--instance (Arbitrary r, Arbitrary (Rec Identity rs)) => Arbitrary (Rec Identity (r ': rs)) where- arbitrary = (:&) <$> (Identity <$> arbitrary) <*> arbitrary--instance Arbitrary (Rec Parameter '[]) where- arbitrary = pure RNil--instance (Arbitrary r, Arbitrary (Rec Parameter rs)) => Arbitrary (Rec Parameter (Optional r ': rs)) where- arbitrary = (:&) <$> (ParameterOptional <$> arbitrary) <*> arbitrary--instance Arbitrary (RequestBody f 'Bodyless) where- arbitrary = pure RequestBodyAbsent--instance Arbitrary a => Arbitrary (RequestBody Identity (Body a)) where- arbitrary = RequestBodyPresent . Identity <$> arbitrary--instance Eq (RequestBody f 'Bodyless) where- RequestBodyAbsent == RequestBodyAbsent = True
trasa.cabal view
@@ -1,60 +1,95 @@-name: trasa-version: 0.2-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-category: Web-build-type: Simple-cabal-version: >=1.10+cabal-version: 2.2+name:+ trasa+version:+ 0.4.1+synopsis:+ Type Safe Web Routing 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.+homepage:+ https://github.com/haskell-trasa/trasa+author:+ Andrew Martin+ Kyle McKean+maintainer:+ Andrew Martin <andrew.thaddeus@gmail.com>+ Kyle McKean <mckean.kylej@gmail.com>+ chessai <chessai1996@gmail.com>+license:+ MIT+license-file:+ LICENSE+copyright:+ © 2017-2019 Andrew Martin+ © 2017-2019 Kyle McKean+category:+ Web+build-type:+ Simple library- hs-source-dirs: src+ hs-source-dirs:+ src exposed-modules: Trasa.Method Trasa.Url Trasa.Codec Trasa.Error Trasa.Core- Trasa.Tutorial+ Trasa.Core.Implicit+-- Trasa.Tutorial build-depends:- base >= 4.7 && < 5- , bytestring == 0.10.*+ , base >= 4.9 && < 5 , binary == 0.8.*- , text == 1.2.*- , vinyl == 0.5.*+ , bytestring == 0.10.* , hashable == 1.2.*- , http-types == 0.9.*- , http-media == 0.6.*+ , http-media >= 0.6 && < 0.8+ , http-types >= 0.9+ , quantification == 0.5.0+ , text == 1.2.* , unordered-containers >= 0.2 && < 0.3- default-language: Haskell2010+ default-language:+ Haskell2010 -test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs- build-depends: - base- , trasa- , tasty- , tasty-quickcheck- , tasty-hunit- , bytestring- , text- , vinyl+test-suite doctest+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ test+ main-is:+ Doctest.hs+ build-depends:+ , base , doctest- ghc-options: -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ default-language:+ Haskell2010++--test-suite test+-- type:+-- exitcode-stdio-1.0+-- hs-source-dirs:+-- test+-- main-is:+-- Main.hs+-- build-depends:+-- base+-- , trasa+-- , tasty+-- , tasty-quickcheck+-- , tasty-hunit+-- , bytestring+-- , text+-- , quantification+-- ghc-options:+-- -threaded+-- -rtsopts -with-rtsopts=-N+-- default-language:+-- Haskell2010 source-repository head type: git