packages feed

trasa (empty) → 0.1

raw patch · 6 files changed

+1332/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, doctest, http-types, tasty, tasty-hunit, tasty-quickcheck, text, trasa, unordered-containers, vinyl

Files

+ LICENSE view
@@ -0,0 +1,30 @@+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.++    * 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.++    * 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.++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Trasa/Core.hs view
@@ -0,0 +1,931 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -Wall -Werror -Wno-unticked-promoted-constructors #-}+module Trasa.Core+  (+  -- * Types+    Bodiedness(..)+  , Path(..)+  , ResponseBody(..)+  , RequestBody(..)+  , Param(..)+  , Query(..)+  , Parameter(..)+  , Rec(..)+  , BodyCodec(..)+  , BodyDecoding(..)+  , BodyEncoding(..)+  , Many(..)+  , CaptureCodec(..)+  , CaptureEncoding(..)+  , CaptureDecoding(..)+  , Content(..)+  , QueryString(..)+  , Url(..)+  , Payload(..)+  , TrasaErr(..)+  , Router+  -- ** Existential+  , Prepared(..)+  , Concealed(..)+  , Constructed(..)+  -- * Queries+  , encodeQuery+  , decodeQuery+  -- * Url+  , encodeUrl+  , decodeUrl+  -- * Using Routes+  , prepareWith+  , dispatchWith+  , parseWith+  , linkWith+  , payloadWith+  , requestWith+  , routerWith+  , handler+  -- * Defining Routes+  -- ** Path+  , match+  , capture+  , end+  , (./)+  , appendPath+  -- ** Request Body+  , body+  , bodyless+  -- ** Response Body+  , resp+  -- ** Query+  , demoteParameter+  , flag+  , optional+  , list+  , qend+  , (.&)+  , mapQuery+  -- * Converting Route Metadata+  , one+  , mapMany+  , mapPath+  , mapRequestBody+  , mapResponseBody+  , mapConstructed+  -- * Converting Codecs+  , bodyCodecToBodyEncoding+  , bodyCodecToBodyDecoding+  , captureCodecToCaptureEncoding+  , captureCodecToCaptureDecoding+  -- * Errors+  , status+  -- * Argument Currying+  , ParamBase+  , Arguments+  -- * Random Stuff+  , conceal+  , encodeRequestBody+  , decodeResponseBody+  , prettyRouter+  -- * Show/Read Codecs+  , showReadBodyCodec+  , showReadCaptureCodec+  ) where++import Data.Kind (Type)+import Data.Functor.Identity (Identity(..))+import Control.Exception (Exception(..))+import Control.Applicative (liftA2)+import Data.Maybe (mapMaybe,listToMaybe,isJust)+import Data.Semigroup (Semigroup(..))+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.Foldable (toList)+import Data.Bifunctor (first)+import Text.Read (readEither,readMaybe)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBC+import qualified Data.Binary.Builder as LBS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types.Status as N+import qualified Network.HTTP.Types.URI as N+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import Data.Vinyl (Rec(..),rmap)+import Data.Vinyl.TypeLevel (type (++))++-- $setup+-- >>> :set -XTypeInType++data Bodiedness = forall a. Body a | Bodyless++data RequestBody :: (Type -> Type) -> Bodiedness -> Type where+  RequestBodyPresent :: f a -> RequestBody f ('Body a)+  RequestBodyAbsent :: RequestBody f 'Bodyless++mapRequestBody :: (forall x. rqf x -> rqf' x) -> RequestBody rqf request -> RequestBody rqf' request+mapRequestBody _ RequestBodyAbsent = RequestBodyAbsent+mapRequestBody f (RequestBodyPresent reqBod) = RequestBodyPresent (f reqBod)++newtype ResponseBody rpf response = ResponseBody { getResponseBody :: rpf response }++mapResponseBody :: (forall x. rpf x -> rpf' x) -> ResponseBody rpf request -> ResponseBody rpf' request+mapResponseBody f (ResponseBody resBod) = ResponseBody (f resBod)++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++mapPath :: (forall x. cf x -> cf' x) -> Path cf ps -> Path cf' ps+mapPath _ PathNil = PathNil+mapPath f (PathConsMatch s pnext) = PathConsMatch s (mapPath f pnext)+mapPath f (PathConsCapture c pnext) = PathConsCapture (f c) (mapPath f pnext)++appendPath :: Path f as -> Path f bs -> Path f (as ++ bs)+appendPath PathNil bs = bs+appendPath (PathConsMatch a as) bs = PathConsMatch a (appendPath as bs)+appendPath (PathConsCapture cas as) bs = PathConsCapture cas (appendPath as bs)++newtype Many f a = Many { getMany :: NonEmpty (f a) }+  deriving (Functor)++instance Applicative f => Applicative (Many f) where+  pure = Many . pure . pure+  Many mf <*> Many mx = Many $ liftA2 (<*>) mf mx++one :: f a -> Many f a+one = Many . pure++mapMany :: (forall x. f x -> g x) -> Many f a -> Many g a+mapMany eta (Many m) = Many (fmap eta m)++data BodyDecoding a = BodyDecoding+  { bodyDecodingNames :: NonEmpty T.Text+  , bodyDecodingFunction :: LBS.ByteString -> Either T.Text a+  }++data BodyEncoding a = BodyEncoding+  { bodyEncodingNames :: NonEmpty T.Text+  , bodyEncodingFunction :: a -> LBS.ByteString+  }++-- Note to self, we maybe should change this to use list instead of+-- non-empty list. When encoding unit, we actually want+-- to omit the Content-Type header.+data BodyCodec a = BodyCodec+  { bodyCodecNames :: NonEmpty T.Text+  , bodyCodecEncode :: a -> LBS.ByteString+  , bodyCodecDecode :: LBS.ByteString -> Either T.Text a+  }++bodyCodecToBodyEncoding :: BodyCodec a -> BodyEncoding a+bodyCodecToBodyEncoding (BodyCodec names enc _) = BodyEncoding names enc++bodyCodecToBodyDecoding :: BodyCodec a -> BodyDecoding a+bodyCodecToBodyDecoding (BodyCodec names _ dec) = BodyDecoding names dec++data Param+  = Flag+  | forall a. Optional a+  | forall a. 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)++data Parameter :: Param -> Type where+  ParameterFlag :: Bool -> Parameter Flag+  ParameterOptional :: Maybe a -> Parameter (Optional a)+  ParameterList :: [a] -> Parameter (List a)++data QueryParam+  = QueryParamFlag+  | QueryParamSingle T.Text+  | QueryParamList [T.Text]+  deriving Eq++instance Semigroup QueryParam where+  QueryParamFlag <> q = q+  q <> QueryParamFlag = q+  QueryParamSingle q1 <> QueryParamSingle q2 = QueryParamList [q1,q2]+  QueryParamSingle q1 <> QueryParamList l1 = QueryParamList (q1:l1)+  QueryParamList l1 <> QueryParamSingle q1 = QueryParamList (l1 ++ [q1]) -- Change list to a set+  QueryParamList l1 <> QueryParamList l2 = QueryParamList (l1 ++ l2)++instance Monoid QueryParam where+  mempty = QueryParamFlag+  mappend = (<>)++newtype QueryString = QueryString+  { unQueryString :: HM.HashMap T.Text QueryParam+  } deriving Eq++infixr 7 ./++(./) :: (a -> b) -> a -> b+(./) f a = f a++match :: T.Text -> Path cpf caps -> Path cpf caps+match = PathConsMatch++capture :: cpf cap -> Path cpf caps -> Path cpf (cap ': caps)+capture = PathConsCapture++end :: Path cpf '[]+end = PathNil++body :: rqf req -> RequestBody rqf ('Body req)+body = RequestBodyPresent++bodyless :: RequestBody rqf 'Bodyless+bodyless = RequestBodyAbsent++resp :: rpf resp -> ResponseBody rpf resp+resp = ResponseBody++flag :: T.Text -> Query cpf Flag+flag = QueryFlag++optional :: T.Text -> cpf query -> Query cpf (Optional query)+optional = QueryOptional++list :: T.Text -> cpf query -> Query cpf (List query)+list = QueryList++qend :: Rec (Query qpf) '[]+qend = RNil++infixr 7 .&++(.&) :: Query qpf q -> Rec (Query qpf) qs -> Rec (Query qpf) (q ': qs)+(.&) = (:&)++mapQuery :: (forall x. f x -> g x) -> Rec (Query f) qs -> Rec (Query g) qs+mapQuery eta = rmap $ \case+  QueryFlag key -> QueryFlag key+  QueryOptional key query -> QueryOptional key (eta query)+  QueryList key query -> QueryList key (eta query)++data CaptureCodec a = CaptureCodec+  { captureCodecEncode :: a -> T.Text+  , captureCodecDecode :: T.Text -> Maybe a+  }++newtype CaptureEncoding a = CaptureEncoding { appCaptureEncoding :: a -> T.Text }+newtype CaptureDecoding a = CaptureDecoding { appCaptureDecoding :: T.Text -> Maybe a }++captureCodecToCaptureEncoding :: CaptureCodec a -> CaptureEncoding a+captureCodecToCaptureEncoding (CaptureCodec enc _) = CaptureEncoding enc++captureCodecToCaptureDecoding :: CaptureCodec a -> CaptureDecoding a+captureCodecToCaptureDecoding (CaptureCodec _ dec) = CaptureDecoding dec++data Url = Url+  { urlPath :: ![T.Text]+  , urlQueryString :: !QueryString+  } deriving Eq++instance Show Url where+  show = show . encodeUrl++encodeQuery :: QueryString -> N.Query+encodeQuery = HM.foldrWithKey (\key param items -> toQueryItem key param ++ items) [] . unQueryString+  where+    toQueryItem :: T.Text -> QueryParam -> N.Query+    toQueryItem key = \case+      QueryParamFlag -> [(T.encodeUtf8 key, Nothing)]+      QueryParamSingle value -> [(T.encodeUtf8 key, Just (T.encodeUtf8 value))]+      QueryParamList values ->+        flip fmap values $ \value -> (T.encodeUtf8 key, Just (T.encodeUtf8 value))++encodeUrl :: Url -> T.Text+encodeUrl (Url path querys) =+  ( T.decodeUtf8+  . LBS.toStrict+  . LBS.toLazyByteString+  . encode+  . encodeQuery ) querys+  where+    encode qs = case path of+      [] -> "/" <> N.encodePath path qs+      _  -> N.encodePath path qs++decodeQuery :: N.Query -> QueryString+decodeQuery = QueryString . HM.fromListWith (<>) . fmap decode+  where+    decode (key,mval) = case mval of+      Nothing  -> (tkey,QueryParamFlag)+      Just val -> (tkey,QueryParamSingle (T.decodeUtf8 val))+      where tkey = T.decodeUtf8 key++decodeUrl :: T.Text -> Url+decodeUrl txt = Url path (decodeQuery querys)+  where (path,querys) = N.decodePath (T.encodeUtf8 txt)++-- | 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+  -> Prepared route response+  -- ^ The route to encode+  -> Url+linkWith toCapEncs toQueries (Prepared route captures querys _) =+  encodePieces (toCapEncs route) (toQueries route) captures querys++data Payload = Payload+  { payloadUrl :: !Url+  , payloadContent :: !(Maybe Content)+  , payloadAccepts :: !(NonEmpty T.Text)+  }++-- | 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+  -> Prepared route response+  -- ^ The route to be payload encoded+  -> Payload+payloadWith toCapEncs toQueries toReqBody toRespBody p@(Prepared route _ _ reqBody) =+  Payload url content accepts+  where+    url = linkWith toCapEncs toQueries p+    content = encodeRequestBody (toReqBody route) reqBody+    ResponseBody (Many decodings) = toRespBody route+    accepts = bodyDecodingNames =<< decodings++-- Only useful to implement packages like 'trasa-client'+requestWith :: Functor m+  => (forall caps querys req resp. route caps querys req resp -> T.Text)+  -> (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)+  -> (T.Text -> Url -> Maybe Content -> [T.Text] -> 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+      accepts = toList (bodyDecodingNames =<< decodings)+      decode = note (TrasaErr N.status400 "Could not decode response") . decodeResponseBody respBodyDecs+   in fmap (\c -> c >>= decode) (run method url content accepts)++encodeRequestBody :: RequestBody (Many BodyEncoding) request -> RequestBody Identity request -> Maybe Content+encodeRequestBody RequestBodyAbsent RequestBodyAbsent = Nothing+encodeRequestBody (RequestBodyPresent (Many encodings)) (RequestBodyPresent (Identity rq)) =+  case NE.head encodings of+    BodyEncoding names encoding -> Just (Content (NE.head names) (encoding rq))++decodeResponseBody :: ResponseBody (Many BodyDecoding) response -> Content -> Maybe response+decodeResponseBody (ResponseBody (Many decodings)) (Content name content) =+  flip mapFind decodings $ \(BodyDecoding names decode) ->+    if elem name names then hush (decode content) else Nothing++encodePieces+  :: Path CaptureEncoding captures+  -> Rec (Query CaptureEncoding) querys+  -> Rec Identity captures+  -> Rec Parameter querys+  -> Url+encodePieces pathEncoding queryEncoding path querys =+  Url (encodePath pathEncoding path) (QueryString (encodeQueries queryEncoding querys))+  where+    encodePath+      :: forall caps+      .  Path CaptureEncoding caps+      -> Rec Identity caps+      -> [T.Text]+    encodePath PathNil RNil = []+    encodePath (PathConsMatch str ps) xs = str : encodePath ps xs+    encodePath (PathConsCapture (CaptureEncoding enc) ps) (Identity x :& 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) =+      if on then HM.insert key QueryParamFlag rest else rest+      where rest = encodeQueries encs qs+    encodeQueries (QueryOptional key (CaptureEncoding enc) :& encs) (ParameterOptional mval :& 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) =+       HM.insert key (QueryParamList (fmap enc vals)) (encodeQueries encs qs)++data TrasaErr = TrasaErr+  { trasaErrStatus :: N.Status+  , trasaErrBody :: LBS.ByteString+  } deriving (Eq,Ord)++instance Show TrasaErr where+  show (TrasaErr s b) = "Trasa Error with status: " ++ show s ++ " and body: " ++ LBC.unpack b++instance Exception TrasaErr where++status :: N.Status -> TrasaErr+status s = TrasaErr s ""++-- | 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)+  -> (forall caps qrys req resp. route caps qrys req resp -> Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity req -> m resp)+  -> Router route -- ^ Router+  -> T.Text -- ^ Method+  -> [T.Text] -- ^ Accept headers+  -> 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 =+  sequenceA $ do+    Concealed route decodedPathPieces decodedQueries decodedRequestBody <-+      parseWith toQueries toReqBody router method url mcontent+    let response = makeResponse route decodedPathPieces decodedQueries decodedRequestBody+        ResponseBody (Many encodings) = toRespBody route+    (encode,typ) <- mapFindE (status N.status406)+      (\(BodyEncoding names encode) -> case mapFind (\x -> if elem x accepts then Just x else Nothing) names of+        Just name -> Just (encode,name)+        Nothing -> Nothing+      )+      encodings+    Right (fmap (Content typ . encode) response)++-- | 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 -> T.Text)+  -- ^ 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+  -> [Constructed route]+  -> Router route+routerWith toMethod toCapDec enumeratedRoutes = Router $ foldMap+  (\(Constructed route) -> singletonIxedRouter route (toMethod route) (toCapDec route))+  enumeratedRoutes++-- | 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)+  -> Router route -- ^ Router+  -> T.Text -- ^ 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+  decodedRequestBody <- case toReqBody route of+    RequestBodyPresent (Many decodings) -> case mcontent of+      Just (Content typ encodedRequest) -> do+        decode <- mapFindE (status N.status415) (\(BodyDecoding names decode) -> if elem typ names then Just decode else Nothing) decodings+        reqVal <- badReq (decode encodedRequest)+        Right (RequestBodyPresent (Identity reqVal))+      Nothing -> Left (status N.status415)+    RequestBodyAbsent -> case mcontent of+      Just _ -> Left (status N.status415)+      Nothing -> Right RequestBodyAbsent+  return (Concealed route captures querys decodedRequestBody)+  where badReq :: Either T.Text b -> Either TrasaErr b+        badReq = first (TrasaErr N.status400 . LBS.fromStrict . T.encodeUtf8)++-- | Parses only the path.+parsePathWith :: forall route.+     Router route+  -> T.Text -- ^ Method+  -> [T.Text] -- ^ Path Pieces+  -> Maybe (Pathed route)+parsePathWith (Router r0) method pieces0 =+  listToMaybe (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]+  go captures ps (IxedRouter matches mcapture responders) = case ps of+    [] -> case HM.lookup 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)+          -- 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++parseQueryWith :: Rec (Query CaptureDecoding) querys -> QueryString -> Either TrasaErr (Rec Parameter querys)+parseQueryWith decoding (QueryString querys) = go 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))++decodeCaptureVector ::+     IxedRec CaptureDecoding n xs+  -> Vec n T.Text+  -> Maybe (Rec Identity xs)+decodeCaptureVector IxedRecNil VecNil = Just RNil+decodeCaptureVector (IxedRecCons (CaptureDecoding decode) rnext) (VecCons piece vnext) = do+  val <- decode piece+  vals <- decodeCaptureVector rnext vnext+  return (Identity val :& vals)++type family ParamBase (param :: Param) :: Type where+  ParamBase Flag = Bool+  ParamBase (Optional a) = Maybe a+  ParamBase (List a) = [a]++demoteParameter :: Parameter param -> ParamBase param+demoteParameter = \case+  ParameterFlag b -> b+  ParameterOptional m -> m+  ParameterList l -> l++-- | A closed, total type family provided as a convenience to end users.+--   Other function is this library take advantage of 'Arguments' to allow+--   end users use normal function application. Without this, users would+--   need to write out 'Record' and 'RequestBody' values by hand, which+--   is tedious.+--+--   >>> :kind! Arguments '[Int,Bool] '[Flag,Optional Double,List Int] 'Bodyless Double+--   Arguments '[Int,Bool] '[Flag,Optional Double,List Int] 'Bodyless Double :: *+--   = Int -> Bool -> Bool -> Maybe Double -> [Int] -> Double+type family Arguments (pieces :: [Type]) (querys :: [Param]) (body :: Bodiedness) (result :: Type) :: Type where+  Arguments '[] '[] ('Body b) r = b -> r+  Arguments '[] '[] 'Bodyless r = r+  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+  -> 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)++prepareExplicit :: forall route captures querys request response rqf pf qf.+     route captures querys request response+  -> Path pf captures+  -> Rec (Query qf) querys+  -> RequestBody rqf request+  -> Arguments captures querys 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/+  go :: forall caps qrys z.+        (Rec Identity caps -> Rec Parameter qrys -> RequestBody Identity request -> z)+     -> Path pf caps+     -> 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 (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+  parameter :: forall param. Query qf param -> ParamBase param -> Parameter param+  parameter (QueryFlag _) b = ParameterFlag b+  parameter (QueryOptional _ _) m = ParameterOptional m+  parameter (QueryList _ _) l = ParameterList l++-- | Uncurry the arguments type family+handler :: forall captures querys request x.+     Rec Identity captures+  -> Rec Parameter querys+  -> RequestBody Identity request+  -> Arguments captures querys request x+  -> x+handler = go+  where+  go :: forall caps qrys.+       Rec Identity caps+    -> Rec Parameter qrys+    -> 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)++-- | 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+-- 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)+  -> 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++-- | Includes the path and the request body (and the querystring+--   params after they get added to this library).+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+    -> Prepared route response++-- | Only needed to implement 'parseWith'. Most users do not need this.+--   If you need to create a route hierarchy to provide breadcrumbs,+--   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+    -> Concealed route++-- | Conceal the response type.+conceal :: Prepared route response -> Concealed route+conceal (Prepared route caps querys req) = Concealed route caps querys req++-- | The HTTP content type and body.+data Content = Content+  { contentType :: T.Text+  , contentData :: LBS.ByteString+  } deriving (Show,Eq,Ord)++hush :: Either e a -> Maybe a+hush (Left _)  = Nothing+hush (Right a) = Just a++note :: e -> Maybe a -> Either e a+note e Nothing  = Left e+note _ (Just a) = Right a++mapFind :: Foldable f => (a -> Maybe b) -> f a -> Maybe b+mapFind f = listToMaybe . mapMaybe f . toList++mapFindE :: Foldable f => e -> (a -> Maybe b) -> f a -> Either e b+mapFindE e f = listToEither . mapMaybe f . toList+  where listToEither [] = Left e+        listToEither (x:_) = Right x++showReadBodyCodec :: (Show a, Read a) => BodyCodec a+showReadBodyCodec = BodyCodec+  (pure "text/haskell")+  (LBC.pack . show)+  (first T.pack . readEither . LBC.unpack)++showReadCaptureCodec :: (Show a, Read a) => CaptureCodec a+showReadCaptureCodec = CaptureCodec (T.pack . show) (readMaybe . T.unpack)++-- | Only promoted version used.+data Nat = S !Nat | Z++newtype Router route = Router (IxedRouter route 'Z)++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+    -> IxedRouter route n++-- | This monoid instance is provided so that we can+--   conveniently use foldMap elsewhere. We do not+--   provide a Monoid instance for Router like we do+--   for IxedRouter. End users only have one way to create+--   a router, and if they combine a Router with itself+--   using mappend, it would result in Router in which all+--   routes were overlapped.+instance Monoid (IxedRouter route n) where+  mempty = IxedRouter HM.empty Nothing HM.empty+  mappend = unionIxedRouter++data IxedResponder :: ([Type] -> [Param] -> Bodiedness -> Type -> Type) -> Nat -> Type where+  IxedResponder ::+       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)++data Vec :: Nat -> Type -> Type where+  VecNil :: Vec 'Z 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++data LenPath :: Nat -> Type where+  LenPathNil :: LenPath 'Z+  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++-- toIxedRec :: Rec f xs -> HideIx (IxedRec f) xs+-- toIxedRec RNil = HideIx IxedRecNil+-- toIxedRec (r :& rs) = case toIxedRec rs of+--   HideIx x -> HideIx (IxedRecCons r x)++snocVec :: a -> Vec n a -> Vec ('S n) a+snocVec a VecNil = VecCons a VecNil+snocVec a (VecCons b vnext) =+  VecCons b (snocVec a vnext)++pathToIxedPath :: Path f xs -> HideIx (IxedPath f) xs+pathToIxedPath PathNil = HideIx IxedPathNil+pathToIxedPath (PathConsCapture c pnext) =+  case pathToIxedPath pnext of+    HideIx ixed -> HideIx (IxedPathCapture c ixed)+pathToIxedPath (PathConsMatch s pnext) =+  case pathToIxedPath pnext of+    HideIx ixed -> HideIx (IxedPathMatch s ixed)++-- | Discards the static parts+ixedPathToIxedRec :: IxedPath f n xs -> IxedRec f n xs+ixedPathToIxedRec IxedPathNil = IxedRecNil+ixedPathToIxedRec (IxedPathCapture c pnext) =+  IxedRecCons c (ixedPathToIxedRec pnext)+ixedPathToIxedRec (IxedPathMatch _ pnext) =+  ixedPathToIxedRec pnext++ixedPathToLenPath :: IxedPath f n xs -> LenPath n+ixedPathToLenPath IxedPathNil = LenPathNil+ixedPathToLenPath (IxedPathCapture _ pnext) =+  LenPathCapture (ixedPathToLenPath pnext)+ixedPathToLenPath (IxedPathMatch s pnext) =+  LenPathMatch s (ixedPathToLenPath pnext)++snocLenPathMatch :: T.Text -> LenPath n -> LenPath n+snocLenPathMatch s x = case x of+  LenPathNil -> LenPathMatch s LenPathNil+  LenPathMatch t pnext -> LenPathMatch t (snocLenPathMatch s pnext)+  LenPathCapture pnext -> LenPathCapture (snocLenPathMatch s pnext)++snocLenPathCapture :: LenPath n -> LenPath ('S n)+snocLenPathCapture x = case x of+  LenPathNil -> LenPathCapture LenPathNil+  LenPathMatch t pnext -> LenPathMatch t (snocLenPathCapture pnext)+  LenPathCapture pnext -> LenPathCapture (snocLenPathCapture pnext)++reverseLenPathMatch :: LenPath n -> LenPath n+reverseLenPathMatch = go+  where+  go :: forall n. LenPath n -> LenPath n+  go LenPathNil = LenPathNil+  go (LenPathMatch s pnext) = snocLenPathMatch s (go pnext)+  go (LenPathCapture pnext) = snocLenPathCapture (go pnext)++singletonIxedRouter ::+  route captures querys request response -> T.Text -> Path CaptureDecoding captures -> IxedRouter route 'Z+singletonIxedRouter route method capDecs = case pathToIxedPath capDecs of+  HideIx ixedCapDecs ->+    let ixedCapDecsRec = ixedPathToIxedRec ixedCapDecs+        responder = IxedResponder route ixedCapDecsRec+        lenPath = reverseLenPathMatch (ixedPathToLenPath ixedCapDecs)+     in singletonIxedRouterHelper responder method lenPath++singletonIxedRouterHelper ::+  IxedResponder route n -> T.Text -> LenPath n -> IxedRouter route 'Z+singletonIxedRouterHelper responder method path =+  let r = IxedRouter HM.empty Nothing (HM.singleton method [responder])+   in singletonIxedRouterGo r path++singletonIxedRouterGo ::+  IxedRouter route n -> LenPath n -> IxedRouter route 'Z+singletonIxedRouterGo r lp = case lp of+  LenPathNil -> r+  LenPathCapture lpNext -> singletonIxedRouterGo (IxedRouter HM.empty (Just r) HM.empty) lpNext+  LenPathMatch s lpNext -> singletonIxedRouterGo (IxedRouter (HM.singleton s r) Nothing HM.empty) lpNext++unionIxedRouter :: IxedRouter route n -> IxedRouter route n -> IxedRouter route n+unionIxedRouter = go+  where+  go :: forall route n. IxedRouter route n -> IxedRouter route n -> IxedRouter route n+  go (IxedRouter matchesA captureA respsA) (IxedRouter matchesB captureB respsB) =+    IxedRouter+      (HM.unionWith go matchesA matchesB)+      (unionMaybeWith go captureA captureB)+      (HM.unionWith (++) respsA respsB)++unionMaybeWith :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+unionMaybeWith f x y = case x of+  Nothing -> y+  Just xval -> case y of+    Nothing -> x+    Just yval -> Just (f xval yval)++-- | Pretty prints a router, using indentation to show nesting+--   of routes under a common prefix. This also shows the request+--   methods that each route accepts. If there are any trivially+--   overlapped routes, the appends are asterisk to the method name+--   for which the routes are overlapped.+prettyRouter :: Router route -> String+prettyRouter (Router r) = L.unlines (prettyIxedRouter 0 (Nothing,r))++prettyIxedRouter ::+     Int -- ^ Indentation+  -> (Maybe String, IxedRouter route n)+  -> [String]+prettyIxedRouter indent (mnode,IxedRouter matches cap responders) =+  let spaces = L.replicate indent ' '+      nextIndent = if isJust mnode then indent + 2 else indent+      children1 = map (first (Just . ('/' : ) . T.unpack)) (HM.toList matches)+      children2 = maybe [] (\x -> [(Just "/:capture",x)]) cap+   in concat+        [ case mnode of+            Nothing -> if length responders > 0+              then ["/ " ++ showRespondersList responders]+              else []+            Just _ -> []+        , maybe [] (\x -> [x]) $ flip fmap mnode $ \node -> spaces+            ++ node+            ++ (if length responders > 0 then " " ++ showRespondersList responders else "")+        , prettyIxedRouter nextIndent =<< children1+        , prettyIxedRouter nextIndent =<< children2+        ]++showRespondersList :: HashMap T.Text [a] -> String+showRespondersList = id+  . (\x -> "[" ++ x ++ "]")+  . L.intercalate ","+  . map (\(method,xs) -> T.unpack method ++ (if L.length xs > 1 then "*" else ""))+  . HM.toList
+ src/Trasa/Tutorial.hs view
@@ -0,0 +1,95 @@+{-# 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 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 :: Text+--   }+-- 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) "post"+--   IncrementR -> Meta+--     (match "increment" ./ capture counter ./ end)+--     qend+--     bodyless (resp bodyInt) "post"+--   QueryR -> Meta+--     (match "query" ./ capture counter ./ end)+--     qend+--     bodyless (resp bodyInt) "get"+--   TotalR -> Meta+--     (match "total" ./ end)+--     qend+--     bodyless (resp bodyInt) "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/Main.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++import Text.Read (readMaybe)+import Trasa.Core+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/Core.hs"+    , "src/Trasa/Tutorial.hs"+    ]+  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 :: T.Text+  }++meta :: Route ps qs rq rp -> Meta ps qs rq rp+meta x = case x of+  EmptyR -> Meta+    end+    qend+    bodyless (resp bodyInt) "get"+  HelloR -> Meta+    (match "hello" ./ end)+    qend+    bodyless (resp bodyInt) "get"+  AdditionR -> Meta+    (match "add" ./ capture int ./ capture int ./ end)+    (optional "more" int .& qend)+    bodyless (resp bodyInt) "get"+  IdentityR -> Meta+    (match "identity" ./ capture string ./ end)+    qend+    bodyless (resp bodyString) "get"+  LeftPadR -> Meta+    (match "pad" ./ match "left" ./ capture int ./ end)+    qend+    (body bodyString) (resp bodyString) "get"+  TrickyOneR -> Meta+    (match "tricky" ./ capture int ./ match "one" ./ end)+    qend+    bodyless (resp bodyString) "get"+  TrickyTwoR -> Meta+    (capture int ./ capture int ./ match "two" ./ end)+    qend+    bodyless (resp bodyString) "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
@@ -0,0 +1,55 @@+name: trasa+version: 0.1+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+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, +  universal quantification, and plain old haskell data types.++library+  hs-source-dirs:      src+  exposed-modules:+    Trasa.Core+    Trasa.Tutorial+  build-depends:+      base >= 4.7 && < 5+    , bytestring == 0.10.*+    , binary == 0.8.*+    , text == 1.2.*+    , vinyl == 0.5.*+    , http-types == 0.9.*+    , unordered-containers >= 0.2 && < 0.3+  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+    , doctest+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  default-language: Haskell2010++source-repository head+  type:     git+  location: https://github.com/haskell-trasa/trasa