packages feed

trasa 0.1 → 0.2

raw patch · 8 files changed

+449/−291 lines, 8 filesdep +hashabledep +http-media

Dependencies added: hashable, http-media

Files

+ src/Trasa/Codec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}+module Trasa.Codec+  (+  -- * Capture Codecs+    CaptureEncoding(..)+  , CaptureDecoding(..)+  , CaptureCodec(..)+  , captureCodecToCaptureEncoding+  , captureCodecToCaptureDecoding+  -- * Body Codecs+  , BodyEncoding(..)+  , BodyDecoding(..)+  , BodyCodec(..)+  , bodyCodecToBodyEncoding+  , bodyCodecToBodyDecoding+  -- * Type Class Based Codecs+  , showReadCaptureCodec+  , showReadBodyCodec+  ) where++import Text.Read (readMaybe,readEither)+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBC+import qualified Data.Text as T+import Data.List.NonEmpty (NonEmpty)+import qualified Network.HTTP.Media.MediaType as N++newtype CaptureEncoding a = CaptureEncoding { appCaptureEncoding :: a -> T.Text }++newtype CaptureDecoding a = CaptureDecoding { appCaptureDecoding :: T.Text -> Maybe a }++data CaptureCodec a = CaptureCodec+  { captureCodecEncode :: a -> T.Text+  , captureCodecDecode :: T.Text -> Maybe a+  }++captureCodecToCaptureEncoding :: CaptureCodec a -> CaptureEncoding a+captureCodecToCaptureEncoding (CaptureCodec enc _) = CaptureEncoding enc++captureCodecToCaptureDecoding :: CaptureCodec a -> CaptureDecoding a+captureCodecToCaptureDecoding (CaptureCodec _ dec) = CaptureDecoding dec++showReadCaptureCodec :: (Show a, Read a) => CaptureCodec a+showReadCaptureCodec = CaptureCodec (T.pack . show) (readMaybe . T.unpack)++data BodyEncoding a = BodyEncoding+  { bodyEncodingNames :: NonEmpty N.MediaType+  , bodyEncodingFunction :: a -> LBS.ByteString+  }++data BodyDecoding a = BodyDecoding+  { bodyDecodingNames :: NonEmpty N.MediaType+  , bodyDecodingFunction :: LBS.ByteString -> Either T.Text a+  }++data BodyCodec a = BodyCodec+  { bodyCodecNames :: NonEmpty N.MediaType+  , 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++showReadBodyCodec :: (Show a, Read a) => BodyCodec a+showReadBodyCodec = BodyCodec+  (pure "text/haskell")+  (LBC.pack . show)+  (first T.pack . readEither . LBC.unpack)+
src/Trasa/Core.hs view
@@ -15,36 +15,31 @@   (   -- * 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+  , conceal+  , mapConstructed+  -- * Request Types+  -- ** Method+  , Method+  , encodeMethod+  , decodeMethod+  -- ** Queries+  , QueryString(..)   , encodeQuery   , decodeQuery-  -- * Url+  -- ** Url+  , Url(..)   , encodeUrl   , decodeUrl+  -- ** Errors+  , TrasaErr(..)+  , status   -- * Using Routes   , prepareWith   , dispatchWith@@ -53,20 +48,20 @@   , payloadWith   , requestWith   , routerWith-  , handler   -- * Defining Routes   -- ** Path+  , Path(..)   , match   , capture   , end   , (./)+  , mapPath   , appendPath-  -- ** Request Body-  , body-  , bodyless-  -- ** Response Body-  , resp   -- ** Query+  , Param(..)+  , Query(..)+  , Parameter(..)+  , Rec(..)   , demoteParameter   , flag   , optional@@ -74,73 +69,109 @@   , qend   , (.&)   , mapQuery-  -- * Converting Route Metadata-  , one-  , mapMany-  , mapPath+  -- ** Request Body+  , RequestBody(..)+  , body+  , bodyless+  , encodeRequestBody+  , decodeRequestBody   , mapRequestBody+  -- ** Response Body+  , ResponseBody(..)+  , resp+  , encodeResponseBody+  , decodeResponseBody   , mapResponseBody-  , mapConstructed-  -- * Converting Codecs-  , bodyCodecToBodyEncoding-  , bodyCodecToBodyDecoding+  -- ** Many+  , Many(..)+  , one+  , mapMany+  -- * Codecs+  , CaptureEncoding(..)+  , CaptureDecoding(..)+  , CaptureCodec(..)+  , BodyEncoding(..)+  , BodyDecoding(..)+  , BodyCodec(..)+    -- ** Converting Codecs   , captureCodecToCaptureEncoding   , captureCodecToCaptureDecoding-  -- * Errors-  , status+  , bodyCodecToBodyEncoding+  , bodyCodecToBodyDecoding+  -- ** Type Class based Codecs+  , showReadCaptureCodec+  , showReadBodyCodec   -- * Argument Currying   , ParamBase   , Arguments-  -- * Random Stuff-  , conceal-  , encodeRequestBody-  , decodeResponseBody+  , handler+  -- * Helpers   , 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 Data.Bifunctor (first,bimap)  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 Network.HTTP.Media.MediaType as N+import qualified Network.HTTP.Media.Accept as N import qualified Data.HashMap.Strict as HM import Data.HashMap.Strict (HashMap) import Data.Vinyl (Rec(..),rmap) import Data.Vinyl.TypeLevel (type (++)) +import Trasa.Method+import Trasa.Url+import Trasa.Error+import Trasa.Codec+ -- $setup -- >>> :set -XTypeInType +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 Bodiedness = forall a. Body a | Bodyless  data RequestBody :: (Type -> Type) -> Bodiedness -> Type where   RequestBodyPresent :: f a -> RequestBody f ('Body a)   RequestBodyAbsent :: RequestBody f 'Bodyless +body :: rqf req -> RequestBody rqf ('Body req)+body = RequestBodyPresent++bodyless :: RequestBody rqf 'Bodyless+bodyless = RequestBodyAbsent+ 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 } +resp :: rpf resp -> ResponseBody rpf resp+resp = ResponseBody+ mapResponseBody :: (forall x. rpf x -> rpf' x) -> ResponseBody rpf request -> ResponseBody rpf' request mapResponseBody f (ResponseBody resBod) = ResponseBody (f resBod) @@ -149,6 +180,20 @@   PathConsCapture :: cap a -> Path cap as -> Path cap (a ': as)   PathConsMatch :: T.Text -> Path cap as -> Path cap as +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+ 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)@@ -159,103 +204,20 @@ 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+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)  flag :: T.Text -> Query cpf Flag flag = QueryFlag@@ -280,62 +242,6 @@   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)@@ -351,7 +257,7 @@ data Payload = Payload   { payloadUrl :: !Url   , payloadContent :: !(Maybe Content)-  , payloadAccepts :: !(NonEmpty T.Text)+  , payloadAccepts :: !(NonEmpty N.MediaType)   }  -- | Only useful for library authors@@ -377,12 +283,12 @@  -- 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 -> Method)   -> (forall caps querys req resp. route caps querys req resp -> Path CaptureEncoding caps)   -> (forall caps querys req resp. route caps querys req resp -> Rec (Query CaptureEncoding) querys)   -> (forall caps querys req resp. route caps querys req resp -> RequestBody (Many BodyEncoding) req)   -> (forall caps querys req resp. route caps querys req resp -> ResponseBody (Many BodyDecoding) resp)-  -> (T.Text -> Url -> Maybe Content -> [T.Text] -> m (Either TrasaErr Content))+  -> (Method -> Url -> Maybe Content -> NonEmpty N.MediaType -> m (Either TrasaErr Content))   -- ^ method, url, content, accepts -> response   -> Prepared route response   -> m (Either TrasaErr response)@@ -392,9 +298,8 @@       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)+      accepts = bodyDecodingNames =<< decodings+   in fmap (\c -> c >>= decodeResponseBody respBodyDecs) (run method url content accepts)  encodeRequestBody :: RequestBody (Many BodyEncoding) request -> RequestBody Identity request -> Maybe Content encodeRequestBody RequestBodyAbsent RequestBodyAbsent = Nothing@@ -402,11 +307,55 @@   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+decodeRequestBody+  :: RequestBody (Many BodyDecoding) req+  -> Maybe Content+  -> Either TrasaErr (RequestBody Identity req)+decodeRequestBody reqDec mcontent = case reqDec of+  RequestBodyPresent decs -> case mcontent of+    Nothing -> wrongBody+    Just (Content media bod) -> go (toList (getMany decs)) media bod+  RequestBodyAbsent -> case mcontent of+    Nothing -> Right RequestBodyAbsent+    Just _  -> wrongBody+  where+    wrongBody = Left (status N.status415)+    go :: [BodyDecoding a] -> N.MediaType -> LBS.ByteString -> Either TrasaErr (RequestBody Identity (Body a))+    go [] _ _ = Left (status N.status400)+    go (BodyDecoding medias dec:decs) media bod = case any (flip N.matches media) medias of+      True -> bimap (TrasaErr N.status415 . LBS.fromStrict . T.encodeUtf8)+                    (RequestBodyPresent . Identity)+                    (dec bod)+      False -> go decs media bod +encodeResponseBody+  :: forall response+  .  [N.MediaType]+  -> ResponseBody (Many BodyEncoding) response+  -> response+  -> Either TrasaErr Content+encodeResponseBody medias (ResponseBody encs) res = go (toList (getMany encs))+  where+    go :: [BodyEncoding response] -> Either TrasaErr Content+    go [] = Left (status N.status406)+    go (BodyEncoding accepts e:es) = case acceptable (toList accepts) medias of+      Just typ -> Right (Content typ (e res))+      Nothing  -> go es+    acceptable :: [N.MediaType] -> [N.MediaType] -> Maybe N.MediaType+    acceptable [] _ = Nothing+    acceptable (a:as) ms = case any (N.matches a) ms of+      True  -> Just a+      False -> acceptable as ms++decodeResponseBody :: ResponseBody (Many BodyDecoding) response -> Content -> Either TrasaErr response+decodeResponseBody (ResponseBody (Many decodings)) (Content name content) = go (toList decodings)+  where+    go :: [BodyDecoding response] -> Either TrasaErr response+    go [] = Left (status N.status415)+    go (BodyDecoding names dec:decs) = case any (N.matches name) names of+      True -> first (TrasaErr N.status400 . LBS.fromStrict . T.encodeUtf8) (dec content)+      False -> go decs+ encodePieces   :: Path CaptureEncoding captures   -> Rec (Query CaptureEncoding) querys@@ -439,19 +388,6 @@     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@@ -460,28 +396,20 @@   -> (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+  -> Method -- ^ Method+  -> [N.MediaType] -- ^ 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)+  case parseWith toQueries toReqBody router method url mcontent of+    Left err -> pure (Left err)+    Right (Concealed route path querys reqBody) ->+      encodeResponseBody accepts (toRespBody route) <$> makeResponse route path querys reqBody  -- | Build a router from all the possible routes, and methods to turn routes into needed metadata routerWith ::-     (forall caps querys req resp. route caps querys req resp -> T.Text)+     (forall caps querys req resp. route caps querys req resp -> Method)   -- ^ Get the method from a route   -> (forall caps querys req resp. route caps querys req resp -> Path CaptureDecoding caps)   -- ^ How to decode path pieces of a route@@ -496,7 +424,7 @@      (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+  -> Method -- ^ Request Method   -> Url -- ^ Everything after the authority   -> Maybe Content -- ^ Request content type and body   -> Either TrasaErr (Concealed route)@@ -504,24 +432,13 @@   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)+  reqBody <- decodeRequestBody (toReqBody route) mcontent+  return (Concealed route captures querys reqBody)  -- | Parses only the path. parsePathWith :: forall route.      Router route-  -> T.Text -- ^ Method+  -> Method -- ^ Method   -> [T.Text] -- ^ Path Pieces   -> Maybe (Pathed route) parsePathWith (Router r0) method pieces0 =@@ -533,7 +450,7 @@      -> IxedRouter route n -- router fragment      -> [Pathed route]   go captures ps (IxedRouter matches mcapture responders) = case ps of-    [] -> case HM.lookup method responders of+    [] -> case HM.lookup (encodeMethod method) responders of       Nothing -> []       Just respondersAtMethod ->         mapMaybe (\(IxedResponder route capDecs) ->@@ -720,35 +637,10 @@  -- | The HTTP content type and body. data Content = Content-  { contentType :: T.Text+  { contentType :: N.MediaType   , 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 @@ -855,7 +747,7 @@   go (LenPathCapture pnext) = snocLenPathCapture (go pnext)  singletonIxedRouter ::-  route captures querys request response -> T.Text -> Path CaptureDecoding captures -> IxedRouter route 'Z+  route captures querys request response -> Method -> Path CaptureDecoding captures -> IxedRouter route 'Z singletonIxedRouter route method capDecs = case pathToIxedPath capDecs of   HideIx ixedCapDecs ->     let ixedCapDecsRec = ixedPathToIxedRec ixedCapDecs@@ -864,9 +756,9 @@      in singletonIxedRouterHelper responder method lenPath  singletonIxedRouterHelper ::-  IxedResponder route n -> T.Text -> LenPath n -> IxedRouter route 'Z+  IxedResponder route n -> Method -> LenPath n -> IxedRouter route 'Z singletonIxedRouterHelper responder method path =-  let r = IxedRouter HM.empty Nothing (HM.singleton method [responder])+  let r = IxedRouter HM.empty Nothing (HM.singleton (encodeMethod method) [responder])    in singletonIxedRouterGo r path  singletonIxedRouterGo ::
+ src/Trasa/Error.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Trasa.Error+  (+  -- * Types+    TrasaErr(..)+  -- * Simple Errors+  , status+  ) where++import Control.Exception (Exception(..))+import qualified Data.ByteString.Lazy.Char8 as LBC+import qualified Network.HTTP.Types as N++data TrasaErr = TrasaErr+  { trasaErrStatus :: N.Status+  , trasaErrBody :: LBC.ByteString+  } deriving (Eq,Ord)++instance Show TrasaErr where+  show (TrasaErr s b) =+    "Trasa Error with status: " +++    show s +++    if LBC.null b then "" else " and body: " ++ LBC.unpack b++instance Exception TrasaErr where++status :: N.Status -> TrasaErr+status s = TrasaErr s ""+
+ src/Trasa/Method.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | This module exports symbols that will conflict with the standard prelude.+-- It is recommended to be import qualified or just import 'Method' and use its 'IsString' instance.+module Trasa.Method+  (+  -- * Method+    Method+  , encodeMethod+  , decodeMethod+  -- * Convenience pre defined methods+  , get+  , post+  , head+  , put+  , delete+  , trace+  , connect+  , options+  , patch+  ) where++import Prelude hiding (head)+import Data.Hashable(Hashable(..))+import Data.String (IsString(..))+import qualified Data.Text as T++newtype Method = Method T.Text+  deriving (Hashable,Eq,Ord)++instance Show Method where+  show = show . encodeMethod++instance IsString Method where+  fromString = decodeMethod . T.pack++encodeMethod :: Method -> T.Text+encodeMethod (Method txt) = txt++decodeMethod :: T.Text -> Method+decodeMethod = Method . T.toUpper++get :: Method+get = "GET"++post :: Method+post = "POST"++head :: Method+head = "HEAD"++put :: Method+put = "PUT"++delete :: Method+delete = "DELETE"++trace :: Method+trace = "TRACE"++connect :: Method+connect = "CONNECT"++options :: Method+options = "OPTIONS"++patch :: Method+patch = "PATCH"+
src/Trasa/Tutorial.hs view
@@ -11,6 +11,7 @@   ) where  import Trasa.Core+import qualified Trasa.Method as M import Data.Vinyl (Rec) import Data.Kind (Type) import Data.Text (Text)@@ -40,7 +41,7 @@ --   , metaQuery :: Rec (Query CaptureCodec) querys --   , metaRequestBody :: RequestBody BodyCodec request --   , metaResponseBody :: ResponseBody BodyCodec response---   , metaMethod :: Text+--   , metaMethod :: Method --   } -- int :: CaptureCodec Int -- int = showReadCaptureCodec@@ -55,19 +56,19 @@ --   AssignR -> Meta --     (match "assign" ./ capture counter ./ match "to" ./ capture int ./ end) --     qend---     bodyless (resp bodyUnit) "post"+--     bodyless (resp bodyUnit) M.post --   IncrementR -> Meta --     (match "increment" ./ capture counter ./ end) --     qend---     bodyless (resp bodyInt) "post"+--     bodyless (resp bodyInt) M.post --   QueryR -> Meta --     (match "query" ./ capture counter ./ end) --     qend---     bodyless (resp bodyInt) "get"+--     bodyless (resp bodyInt) M.get --   TotalR -> Meta --     (match "total" ./ end) --     qend---     bodyless (resp bodyInt) "get"+--     bodyless (resp bodyInt) M.get -- :} -- -- Now, we can start using our routes. To do this, we take functions that
+ src/Trasa/Url.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wall -Werror #-}+module Trasa.Url+  (+  -- * Untyped Query Parameters+    QueryParam(..)+  , QueryString(..)+  , encodeQuery+  , decodeQuery+  -- * Urls (path + query string)+  , Url(..)+  , encodeUrl+  , decodeUrl+  ) where++import Data.Semigroup (Semigroup(..))+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Builder as LBS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.HashMap.Strict as HM+import qualified Network.HTTP.Types as N++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]) -- O(n^2)...+  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++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))++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++data Url = Url+  { urlPath :: ![T.Text]+  , urlQueryString :: !QueryString+  } deriving Eq++instance Show Url where+  show = show . encodeUrl++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++decodeUrl :: T.Text -> Url+decodeUrl txt = Url path (decodeQuery querys)+  where (path,querys) = N.decodePath (T.encodeUtf8 txt)
test/Main.hs view
@@ -8,6 +8,7 @@  import Text.Read (readMaybe) import Trasa.Core+import qualified Trasa.Method as M import Data.Vinyl import Data.Kind (Type) @@ -26,8 +27,7 @@ main = do   putStrLn "\nRUNNING DOCTESTS"   doctest-    [ "src/Trasa/Core.hs"-    , "src/Trasa/Tutorial.hs"+    [ "src/Trasa"     ]   putStrLn "\nPRETTY ROUTER"   putStrLn (prettyRouter router)@@ -103,7 +103,7 @@   , metaQuery :: Rec (Query CaptureCodec) qs   , metaRequestBody :: RequestBody BodyCodec rq   , metaResponseBody :: ResponseBody BodyCodec rp-  , metaMethod :: T.Text+  , metaMethod :: Method   }  meta :: Route ps qs rq rp -> Meta ps qs rq rp@@ -111,31 +111,31 @@   EmptyR -> Meta     end     qend-    bodyless (resp bodyInt) "get"+    bodyless (resp bodyInt) M.get   HelloR -> Meta     (match "hello" ./ end)     qend-    bodyless (resp bodyInt) "get"+    bodyless (resp bodyInt) M.get   AdditionR -> Meta     (match "add" ./ capture int ./ capture int ./ end)     (optional "more" int .& qend)-    bodyless (resp bodyInt) "get"+    bodyless (resp bodyInt) M.get   IdentityR -> Meta     (match "identity" ./ capture string ./ end)     qend-    bodyless (resp bodyString) "get"+    bodyless (resp bodyString) M.get   LeftPadR -> Meta     (match "pad" ./ match "left" ./ capture int ./ end)     qend-    (body bodyString) (resp bodyString) "get"+    (body bodyString) (resp bodyString) M.get   TrickyOneR -> Meta     (match "tricky" ./ capture int ./ match "one" ./ end)     qend-    bodyless (resp bodyString) "get"+    bodyless (resp bodyString) M.get   TrickyTwoR -> Meta     (capture int ./ capture int ./ match "two" ./ end)     qend-    bodyless (resp bodyString) "get"+    bodyless (resp bodyString) M.get  int :: CaptureCodec Int int = CaptureCodec (T.pack . show) (readMaybe . T.unpack)
trasa.cabal view
@@ -1,5 +1,5 @@ name: trasa-version: 0.1+version: 0.2 synopsis: Type Safe Web Routing homepage: https://github.com/haskell-trasa/trasa#readme license: BSD3@@ -21,6 +21,10 @@ library   hs-source-dirs:      src   exposed-modules:+    Trasa.Method+    Trasa.Url+    Trasa.Codec+    Trasa.Error     Trasa.Core     Trasa.Tutorial   build-depends:@@ -29,7 +33,9 @@     , binary == 0.8.*     , text == 1.2.*     , vinyl == 0.5.*+    , hashable == 1.2.*     , http-types == 0.9.*+    , http-media == 0.6.*     , unordered-containers >= 0.2 && < 0.3   default-language:    Haskell2010