diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Trasa/Core.hs b/src/Trasa/Core.hs new file mode 100644 --- /dev/null +++ b/src/Trasa/Core.hs @@ -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 diff --git a/src/Trasa/Tutorial.hs b/src/Trasa/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Trasa/Tutorial.hs @@ -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" +-- +-- diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/trasa.cabal b/trasa.cabal new file mode 100644 --- /dev/null +++ b/trasa.cabal @@ -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