diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,7 @@ # 0.15.0 +* enhance performance(especially parsing parameter). + +# 0.15.0 * enhance performance(new router). * add anyPath function. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.15.0 +version: 0.15.1 synopsis: Simple and type safe web framework that can be automatically generate API documentation. description: Simple and type safe web framework that can be automatically generate API documentation. @@ -31,15 +31,15 @@ 404 Page Notfound. @ . - * high performance(benchmark: ). + * high performance(benchmark: ). . * Nestable route handling(Apiary Monad; capture, method and more.). . * type safe route filter. . - * auto generate API documentation(example: , ). + * auto generate API documentation(example: , ). . - more examples: + more examples: license: MIT license-file: LICENSE @@ -86,14 +86,6 @@ Control.Monad.Apiary.Filter.Internal.Capture Control.Monad.Apiary.Filter.Internal.Capture.TH Web.Apiary.TH - other-extensions: KindSignatures - , DataKinds - , TypeOperators - , GADTs - , TypeFamilies - - , Rank2Types - build-depends: base >=4.6 && <4.8 , template-haskell >=2.8 && <2.10 , mtl >=2.1 && <2.3 @@ -114,6 +106,7 @@ , case-insensitive >=1.1 && <1.3 , unordered-containers >=0.2 && <0.3 , hashable >=1.1 && <1.3 + , bytestring-lexing >=0.4 && <0.5 if impl(ghc < 7.8) build-depends: tagged >=0.7 && <0.8 @@ -129,6 +122,7 @@ hs-source-dirs: src ghc-options: -O2 -Wall + ghc-prof-options: -O2 -Wall -auto-all default-language: Haskell2010 test-suite test-framework diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -9,8 +9,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE BangPatterns #-} module Control.Monad.Apiary.Action.Internal where @@ -78,7 +79,7 @@ , defaultHeaders = [] , failStatus = internalServerError500 , failHeaders = [] - , rootPattern = ["", "/", "index.html", "index.htm"] + , rootPattern = ["index.html", "index.htm"] , mimeType = defaultMimeLookup . T.pack } @@ -114,17 +115,34 @@ = Continue ActionState a | Pass | Stop Response - deriving (Functor) -newtype ActionT m a = ActionT { runActionT :: +newtype ActionT m a = ActionT { unActionT :: forall b. ActionEnv -> ActionState - -> m (Action a) + -> (a -> ActionState -> m (Action b)) + -> m (Action b) } +runActionT :: Monad m => ActionT m a + -> ActionEnv -> ActionState + -> m (Action a) +runActionT m env st = unActionT m env st $ \a !st' -> + return (Continue st' a) +{-# INLINE runActionT #-} + +actionT :: Monad m + => (ActionEnv -> ActionState -> m (Action a)) + -> ActionT m a +actionT f = ActionT $ \env !st cont -> f env st >>= \case + Pass -> return Pass + Stop s -> return $ Stop s + Continue !st' a -> cont a st' +{-# INLINE actionT #-} + -- | n must be Monad, so cant be MFunctor. -hoistActionT :: (forall b. m b -> n b) -> ActionT m a -> ActionT n a -hoistActionT run m = ActionT $ \e s -> run (runActionT m e s) +hoistActionT :: (Monad m, Monad n) + => (forall b. m b -> n b) -> ActionT m a -> ActionT n a +hoistActionT run m = actionT $ \e s -> run (runActionT m e s) {-# INLINE hoistActionT #-} execActionT :: ApiaryConfig -> Documents -> ActionT IO () -> Application @@ -135,69 +153,60 @@ #endif runActionT m (ActionEnv config request doc) (initialState config) >>= \case #ifdef WAI3 - Pass -> notFound config request send + Pass -> notFound config request send #else - Pass -> notFound config request + Pass -> notFound config request #endif - Stop s -> send s - Continue r _ -> send $ actionResponse r + Stop s -> send s + Continue r _ -> send $ actionResponse r -------------------------------------------------------------------------------- -instance Functor m => Functor (ActionT m) where - fmap f m = ActionT $ \env st -> - fmap f <$> runActionT m env st +instance Functor (ActionT m) where + fmap f m = ActionT $ \env st cont -> + unActionT m env st (\a !s' -> cont (f a) s') -instance (Functor m, Monad m) => Applicative (ActionT m) where - pure x = ActionT $ \_ s -> return $ Continue s x - mf <*> ma = ActionT $ \env st -> - runActionT mf env st >>= \case - Pass -> return Pass - Stop r -> return $ Stop r - Continue st' f -> runActionT ma env st' >>= \case - Continue st'' a -> return $ Continue st'' (f a) - Pass -> return Pass - Stop r -> return $ Stop r - +instance Applicative (ActionT m) where + pure x = ActionT $ \_ !st cont -> cont x st + mf <*> ma = ActionT $ \env st cont -> + unActionT mf env st $ \f !st' -> + unActionT ma env st' $ \a !st'' -> + cont (f a) st'' + instance Monad m => Monad (ActionT m) where - return x = ActionT $ \_ st -> return $ Continue st x - m >>= k = ActionT $ \env st -> - runActionT m env st >>= \case - Pass -> return Pass - Stop r -> return $ Stop r - Continue st' a -> runActionT (k a) env st' >>= \case - Pass -> return Pass - Stop r -> return $ Stop r - Continue st'' b -> return $ Continue st'' b - fail s = ActionT $ \ActionEnv{actionConfig = c} _ -> - return $ Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) + return x = ActionT $ \_ !st cont -> cont x st + m >>= k = ActionT $ \env !st cont -> + unActionT m env st $ \a !st' -> + unActionT (k a) env st' cont + fail s = ActionT $ \(ActionEnv{actionConfig = c}) _ _ -> return $ + Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) instance MonadIO m => MonadIO (ActionT m) where - liftIO m = ActionT $ \_ st -> - Continue st `liftM` liftIO m + liftIO m = ActionT $ \_ !st cont -> + liftIO m >>= \a -> cont a st instance MonadTrans ActionT where - lift m = ActionT $ \_ st -> - Continue st `liftM` m + lift m = ActionT $ \_ !st cont -> + m >>= \a -> cont a st instance MonadThrow m => MonadThrow (ActionT m) where - throwM e = ActionT $ \_ st -> - Continue st `liftM` throwM e + throwM e = ActionT $ \_ !st cont -> + throwM e >>= \a -> cont a st instance MonadCatch m => MonadCatch (ActionT m) where - catch m h = ActionT $ \env st -> - catch (runActionT m env st) (\e -> runActionT (h e) env st) + catch m h = ActionT $ \env !st cont -> + catch (unActionT m env st cont) (\e -> unActionT (h e) env st cont) {-# INLINE catch #-} instance MonadMask m => MonadMask (ActionT m) where - mask a = ActionT $ \env st -> - mask $ \u -> runActionT (a $ q u) env st + mask a = ActionT $ \env !st cont -> + mask $ \u -> unActionT (a $ q u) env st cont where - q u m = ActionT $ \env st -> u (runActionT m env st) - uninterruptibleMask a = ActionT $ \env st -> - uninterruptibleMask $ \u -> runActionT (a $ q u) env st + q u m = actionT $ \env !st -> u (runActionT m env st) + uninterruptibleMask a = ActionT $ \env !st cont -> + uninterruptibleMask $ \u -> unActionT (a $ q u) env st cont where - q u m = ActionT $ \env st -> u (runActionT m env st) + q u m = actionT $ \env !st -> u (runActionT m env st) {-# INLINE mask #-} {-# INLINE uninterruptibleMask #-} @@ -208,11 +217,11 @@ {-# INLINE (<|>) #-} instance Monad m => MonadPlus (ActionT m) where - mzero = ActionT $ \_ _ -> return Pass - mplus m n = ActionT $ \e s -> runActionT m e s >>= \case - Continue st a -> return $ Continue st a - Stop stp -> return $ Stop stp - Pass -> runActionT n e s + mzero = ActionT $ \_ _ _ -> return Pass + mplus m n = ActionT $ \e !s cont -> unActionT m e s cont >>= \case + Continue !st a -> return $ Continue st a + Stop stp -> return $ Stop stp + Pass -> unActionT n e s cont {-# INLINE mzero #-} {-# INLINE mplus #-} @@ -221,9 +230,9 @@ instance MonadTransControl ActionT where newtype StT ActionT a = StActionT { unStActionT :: Action a } - liftWith f = ActionT $ \e s -> + liftWith f = actionT $ \e !s -> liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t e s) - restoreT m = ActionT $ \_ _ -> liftM unStActionT m + restoreT m = actionT $ \_ _ -> liftM unStActionT m instance MonadBaseControl b m => MonadBaseControl b (ActionT m) where newtype StM (ActionT m) a = StMT { unStMT :: ComposeSt ActionT m a } @@ -237,7 +246,7 @@ -------------------------------------------------------------------------------- getEnv :: Monad m => ActionT m ActionEnv -getEnv = ActionT $ \e st -> return $ Continue st e +getEnv = ActionT $ \e s c -> c e s -- | get raw request. since 0.1.0.0. getRequest :: Monad m => ActionT m Request @@ -250,30 +259,30 @@ getDocuments = liftM actionDocuments getEnv getRequestBody :: MonadIO m => ActionT m ([Param], [File]) -getRequestBody = ActionT $ \e s -> case actionReqBody s of - Just b -> return $ Continue s b +getRequestBody = ActionT $ \e s c -> case actionReqBody s of + Just b -> c b s Nothing -> do (p,f) <- liftIO $ P.parseRequestBody P.lbsBackEnd (actionRequest e) let b = (p, map convFile f) - return $ Continue s { actionReqBody = Just b } b + c b s { actionReqBody = Just b } where convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent -- | parse request body and return params. since 0.9.0.0. getReqParams :: MonadIO m => ActionT m [Param] -getReqParams = fst `liftM` getRequestBody +getReqParams = fst <$> getRequestBody -- | parse request body and return files. since 0.9.0.0. getReqFiles :: MonadIO m => ActionT m [File] -getReqFiles = snd `liftM` getRequestBody +getReqFiles = snd <$> getRequestBody -------------------------------------------------------------------------------- modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m () -modifyState f = ActionT $ \_ s -> return $ Continue (f s) () +modifyState f = ActionT $ \_ s c -> c () (f s) -getState :: Monad m => ActionT m ActionState -getState = ActionT $ \_ s -> return $ Continue s s +getState :: ActionT m ActionState +getState = ActionT $ \_ s c -> c s s -- | set status code. since 0.1.0.0. status :: Monad m => Status -> ActionT m () @@ -307,11 +316,11 @@ -- | stop handler and send current state. since 0.3.3.0. stop :: Monad m => ActionT m a -stop = ActionT $ \_ s -> return $ Stop (actionResponse s) +stop = ActionT $ \_ s _ -> return $ Stop (actionResponse s) -- | stop with response. since 0.4.2.0. stopWith :: Monad m => Response -> ActionT m a -stopWith a = ActionT $ \_ _ -> return $ Stop a +stopWith a = ActionT $ \_ _ _ -> return $ Stop a -- | redirect handler -- @@ -347,7 +356,7 @@ -- since 0.6.2.0. redirect :: Monad m => S.ByteString -> ActionT m () redirect to = do - v <- httpVersion `liftM` getRequest + v <- httpVersion <$> getRequest if v == http11 then redirectWith seeOther303 to else redirectWith status302 to @@ -360,7 +369,7 @@ -- since 0.3.3.0. redirectTemporary :: Monad m => S.ByteString -> ActionT m () redirectTemporary to = do - v <- httpVersion `liftM` getRequest + v <- httpVersion <$> getRequest if v == http11 then redirectWith temporaryRedirect307 to else redirectWith status302 to @@ -384,7 +393,7 @@ -- | set response body file content and detect Content-Type by extension. since 0.1.0.0. file :: Monad m => FilePath -> Maybe FilePart -> ActionT m () file f p = do - mime <- mimeType `liftM` getConfig + mime <- mimeType <$> getConfig contentType (mime f) file' f p diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture.hs @@ -38,5 +38,5 @@ fetch p h = focus' (DocFetch (pathRep p) h) Nothing (FetchPath:) $ \l -> liftM actionFetches getState >>= \case [] -> mzero f:fs -> case readPathAs p f of - Nothing -> mzero Just r -> sSnoc l r <$ modifyState (\s -> s {actionFetches = fs}) + Nothing -> mzero diff --git a/src/Control/Monad/Apiary/Internal.hs b/src/Control/Monad/Apiary/Internal.hs --- a/src/Control/Monad/Apiary/Internal.hs +++ b/src/Control/Monad/Apiary/Internal.hs @@ -5,8 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} @@ -103,10 +103,15 @@ ApiaryWriter ra da `mappend` ApiaryWriter rb db = ApiaryWriter (ra . rb) (da . db) -- | most generic Apiary monad. since 0.8.0.0. -newtype ApiaryT c n m a = ApiaryT { unApiaryT :: +newtype ApiaryT c n m a = ApiaryT { unApiaryT :: forall b. ApiaryEnv n c - -> m (ApiaryWriter n, a) + -> (a -> ApiaryWriter n -> m b) + -> m b } +apiaryT :: Monad m + => (ApiaryEnv n c -> m (a, ApiaryWriter n)) + -> ApiaryT c n m a +apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w -- | no transformer. (ActionT IO, ApiaryT Identity) type Apiary c = ApiaryT c IO Identity @@ -118,67 +123,70 @@ where method = requestMethod req - pmAction (PathMethod mm am) = - maybe mzero id (H.lookup method mm) `mplus` maybe mzero id am + pmAction nxt (PathMethod mm am) = + let a = maybe nxt id am + in maybe a (`mplus` a) $ H.lookup method mm loop fch (Router _ _ anp pm) [] = do modifyState (\s -> s { actionFetches = fch [] } ) - pmAction pm `mplus` maybe mzero pmAction anp + pmAction (maybe mzero (pmAction mzero) anp) pm loop fch (Router c mbcp anp _) (p:ps) = case mbcp of - Nothing -> cld `mplus` maybe mzero pmAction anp - Just cp -> cld `mplus` loop (fch . (p:)) cp ps `mplus` maybe mzero pmAction anp + Nothing -> cld ana + Just cp -> cld $ loop (fch . (p:)) cp ps `mplus` ana where - cld = case H.lookup p c of - Nothing -> mzero - Just cd -> loop fch cd ps + ana = maybe mzero (pmAction mzero) anp + cld nxt = case H.lookup p c of + Nothing -> nxt + Just cd -> loop fch cd ps `mplus` nxt runApiaryT :: (Monad n, Monad m) => (forall b. n b -> IO b) -> ApiaryConfig -> ApiaryT '[] n m a -> m Application -runApiaryT run conf m = unApiaryT m (initialEnv conf) >>= \(wtr, _) -> do +runApiaryT run conf m = unApiaryT m (initialEnv conf) (\_ w -> return w) >>= \wtr -> do let doc = docsToDocuments $ writerDoc wtr [] rtr = writerRouter wtr emptyRouter - return $ execActionT conf doc (hoistActionT run $ routerToAction rtr) + return $! execActionT conf doc (hoistActionT run $ routerToAction rtr) runApiary :: ApiaryConfig -> Apiary '[] a -> Application runApiary conf m = runIdentity $ runApiaryT id conf m -------------------------------------------------------------------------------- -instance Functor m => Functor (ApiaryT c n m) where - fmap f m = ApiaryT $ \env -> - fmap f <$> unApiaryT m env +instance Functor (ApiaryT c n m) where + fmap f m = ApiaryT $ \env cont -> + unApiaryT m env $ \a hdr -> hdr `seq` cont (f a) hdr -instance (Functor m, Monad m, Monad n) => Applicative (ApiaryT c n m) where - pure x = ApiaryT $ \_ -> return (mempty, x) - mf <*> ma = ApiaryT $ \env -> - unApiaryT mf env >>= \(w, f) -> - unApiaryT ma env >>= \(w', a) -> - let w'' = w <> w' - in w'' `seq` return (w'', f a) +instance Monad n => Applicative (ApiaryT c n m) where + pure x = ApiaryT $ \_ cont -> cont x mempty + mf <*> ma = ApiaryT $ \env cont -> + unApiaryT mf env $ \f hdr -> + unApiaryT ma env $ \a hdr' -> + let hdr'' = hdr <> hdr' + in hdr'' `seq` cont (f a) hdr'' -instance (Functor m, Monad m, Monad n) => Monad (ApiaryT c n m) where - return x = ApiaryT $ \_ -> return (mempty, x) - m >>= k = ApiaryT $ \env -> - unApiaryT m env >>= \(w, a) -> - unApiaryT (k a) env >>= \(w', b) -> - let w'' = w <> w' - in w'' `seq` return (w'', b) +instance Monad n => Monad (ApiaryT c n m) where + return x = ApiaryT $ \_ cont -> cont x mempty + m >>= k = ApiaryT $ \env cont -> + unApiaryT m env $ \a hdr -> + unApiaryT (k a) env $ \b hdr' -> + let hdr'' = hdr <> hdr' + in hdr'' `seq` cont b hdr'' instance Monad n => MonadTrans (ApiaryT c n) where - lift m = ApiaryT $ \_ -> (mempty,) `liftM` m + lift m = ApiaryT $ \_ c -> m >>= \a -> c a mempty -instance (Functor m, MonadIO m, Monad n) => MonadIO (ApiaryT c n m) where - liftIO m = ApiaryT $ \_ -> (mempty,) `liftM` liftIO m +instance (Monad n, MonadIO m) => MonadIO (ApiaryT c n m) where + liftIO m = ApiaryT $ \_ c -> liftIO m >>= \a -> c a mempty instance (Monad n, MonadBase b m) => MonadBase b (ApiaryT c n m) where - liftBase m = ApiaryT $ \_ -> (mempty,) `liftM` liftBase m + liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty instance Monad n => MonadTransControl (ApiaryT c n) where - newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (ApiaryWriter n, a) } - liftWith f = ApiaryT $ \env -> - liftM (mempty,) (f $ \t -> liftM StTApiary' $ unApiaryT t env) - restoreT m = ApiaryT $ \_ -> liftM unStTApiary' m + newtype StT (ApiaryT c n) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter n) } + liftWith f = apiaryT $ \env -> + liftM (\a -> (a, mempty)) + (f $ \t -> liftM StTApiary' $ unApiaryT t env (\a w -> return (a,w))) + restoreT m = apiaryT $ \_ -> liftM unStTApiary' m instance (Monad n, MonadBaseControl b m) => MonadBaseControl b (ApiaryT c n m) where newtype StM (ApiaryT c n m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT c n) m a } @@ -187,14 +195,14 @@ -------------------------------------------------------------------------------- -getApiaryEnv :: (Monad m, Monad n) => ApiaryT c n m (ApiaryEnv n c) -getApiaryEnv = ApiaryT $ \env -> return (mempty, env) +getApiaryEnv :: Monad n => ApiaryT c n m (ApiaryEnv n c) +getApiaryEnv = ApiaryT $ \env cont -> cont env mempty -apiaryConfig :: (Functor m, Monad m, Monad n) => ApiaryT c n m ApiaryConfig +apiaryConfig :: Monad n => ApiaryT c n m ApiaryConfig apiaryConfig = liftM envConfig getApiaryEnv -addRoute :: (Monad m, Monad n) => ApiaryWriter n -> ApiaryT c n m () -addRoute r = ApiaryT $ \_ -> return (r, ()) +addRoute :: Monad n => ApiaryWriter n -> ApiaryT c n m () +addRoute r = ApiaryT $ \_ cont -> cont () r -- | filter by action. since 0.6.1.0. focus :: Monad n @@ -209,19 +217,19 @@ -> ([PathElem] -> [PathElem]) -> (SList c -> ActionT n (SList c')) -> ApiaryT c' n m a -> ApiaryT c n m a -focus' d meth pth g m = ApiaryT $ \env -> unApiaryT m env +focus' d meth pth g m = ApiaryT $ \env cont -> unApiaryT m env { envFilter = envFilter env >>= g , envMethod = maybe (envMethod env) Just meth , envPath = envPath env . pth , envDoc = envDoc env . d - } + } cont -- | splice ActionT ApiaryT. -action :: (Functor m, Monad m, Monad n) => Fn c (ActionT n ()) -> ApiaryT c n m () +action :: Monad n => Fn c (ActionT n ()) -> ApiaryT c n m () action = action' . apply -- | like action. but not apply arguments. since 0.8.0.0. -action' :: (Functor m, Monad m, Monad n) => (SList c -> ActionT n ()) -> ApiaryT c n m () +action' :: Monad n => (SList c -> ActionT n ()) -> ApiaryT c n m () action' a = do env <- getApiaryEnv addRoute $ ApiaryWriter @@ -234,8 +242,8 @@ -------------------------------------------------------------------------------- insDoc :: (Doc -> Doc) -> ApiaryT c n m a -> ApiaryT c n m a -insDoc d m = ApiaryT $ \env -> unApiaryT m env - { envDoc = envDoc env . d } +insDoc d m = ApiaryT $ \env cont -> unApiaryT m env + { envDoc = envDoc env . d } cont -- | API document group. since 0.12.0.0. -- @@ -261,7 +269,7 @@ {-# DEPRECATED actionWithPreAction "use action'" #-} -- | execute action before main action. since 0.4.2.0 -actionWithPreAction :: (Functor m, Monad m, Monad n) => (SList xs -> ActionT n a) +actionWithPreAction :: Monad n => (SList xs -> ActionT n a) -> Fn xs (ActionT n ()) -> ApiaryT xs n m () actionWithPreAction pa a = do action' $ \c -> pa c >> apply a c diff --git a/src/Data/Apiary/Method.hs b/src/Data/Apiary/Method.hs --- a/src/Data/Apiary/Method.hs +++ b/src/Data/Apiary/Method.hs @@ -6,6 +6,7 @@ import Data.String import qualified Data.ByteString.Char8 as S import Data.Hashable +import qualified Data.ByteString.Unsafe as U data Method = GET @@ -22,14 +23,14 @@ instance Hashable Method where hash GET = 0 - hash POST = 0 - hash HEAD = 0 - hash PUT = 0 - hash DELETE = 0 - hash TRACE = 0 - hash CONNECT = 0 - hash OPTIONS = 0 - hash PATCH = 0 + hash POST = 1 + hash HEAD = 2 + hash PUT = 3 + hash DELETE = 4 + hash TRACE = 5 + hash CONNECT = 6 + hash OPTIONS = 7 + hash PATCH = 8 hash (NonStandard s) = hash s hashWithSalt salt x = salt `hashWithSalt` hash x @@ -47,7 +48,27 @@ NonStandard a -> a {-# INLINE renderMethod #-} -instance IsString Method where - fromString = NonStandard . S.pack +dispatchMethod :: a -> a -> a -> a -> a -> a -> a -> a -> a -> (S.ByteString -> a) -> S.ByteString -> a +dispatchMethod get post head_ put delete trace connect options patch ns s + | S.length s < 2 = ns s + | otherwise = case U.unsafeHead s of + 71 -> if S.length s == 3 && cc 1 69 && cc 2 84 then get else ns s + 80 -> case U.unsafeIndex s 1 of + 79 -> if S.length s == 4 && cc 2 83 && cc 3 84 then post else ns s + 85 -> if S.length s == 3 && cc 2 84 then put else ns s + 65 -> if S.length s == 5 && cc 2 84 && cc 3 67 && cc 4 72 then patch else ns s + _ -> ns s + 72 -> if S.length s == 4 && cc 1 69 && cc 2 65 && cc 3 68 then head_ else ns s + 68 -> if S.length s == 6 && cc 1 69 && cc 2 76 && cc 3 69 && cc 4 84 && cc 5 69 then delete else ns s + 84 -> if S.length s == 5 && cc 1 82 && cc 2 65 && cc 3 67 && cc 4 69 then trace else ns s + 67 -> if S.length s == 7 && cc 1 79 && cc 2 78 && cc 3 78 && cc 4 69 && cc 5 67 && cc 6 84 then connect else ns s + 79 -> if S.length s == 7 && cc 1 80 && cc 2 84 && cc 3 73 && cc 4 79 && cc 5 78 && cc 6 83 then options else ns s + _ -> ns s + where + cc i c = U.unsafeIndex s i == c +parseMethod :: S.ByteString -> Method +parseMethod = dispatchMethod GET POST HEAD PUT DELETE TRACE CONNECT OPTIONS PATCH NonStandard +instance IsString Method where + fromString = parseMethod . S.pack diff --git a/src/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -24,7 +24,7 @@ import Data.Apiary.Proxy import Data.String(IsString) -import Text.Read +import qualified Data.Text.Read as TR import Data.Text.Encoding.Error import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -34,6 +34,9 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.ByteString.Lex.Integral as SL +import qualified Data.ByteString.Lex.Double as SL + jsToBool :: (IsString a, Eq a) => a -> Bool jsToBool = flip notElem jsFalse where @@ -41,6 +44,7 @@ readPathAs :: Path a => proxy a -> T.Text -> Maybe a readPathAs _ t = readPath t +{-# INLINE readPathAs #-} data Text deriving Typeable @@ -69,25 +73,39 @@ | T.null s = Nothing | otherwise = Just $ T.head s +readText :: TR.Reader a -> T.Text -> (Maybe a) +readText p s = case p s of + Right (a, t) -> if T.null t then Just a else Nothing + Left _ -> Nothing + +readTextInt :: Integral i => T.Text -> Maybe i +readTextInt = readText (TR.signed TR.decimal) + +readTextWord :: Integral i => T.Text -> Maybe i +readTextWord = readText TR.decimal + +readTextDouble :: T.Text -> Maybe Double +readTextDouble = readText TR.double + -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0. -instance Path Bool where readPath = Just . jsToBool +instance Path Bool where readPath = Just . jsToBool -instance Path Int where readPath = readMaybe . T.unpack -instance Path Int8 where readPath = readMaybe . T.unpack -instance Path Int16 where readPath = readMaybe . T.unpack -instance Path Int32 where readPath = readMaybe . T.unpack -instance Path Int64 where readPath = readMaybe . T.unpack -instance Path Integer where readPath = readMaybe . T.unpack +instance Path Int where readPath = readTextInt +instance Path Int8 where readPath = readTextInt +instance Path Int16 where readPath = readTextInt +instance Path Int32 where readPath = readTextInt +instance Path Int64 where readPath = readTextInt +instance Path Integer where readPath = readTextInt -instance Path Word where readPath = readMaybe . T.unpack -instance Path Word8 where readPath = readMaybe . T.unpack -instance Path Word16 where readPath = readMaybe . T.unpack -instance Path Word32 where readPath = readMaybe . T.unpack -instance Path Word64 where readPath = readMaybe . T.unpack +instance Path Word where readPath = readTextWord +instance Path Word8 where readPath = readTextWord +instance Path Word16 where readPath = readTextWord +instance Path Word32 where readPath = readTextWord +instance Path Word64 where readPath = readTextWord -instance Path Double where readPath = readMaybe . T.unpack -instance Path Float where readPath = readMaybe . T.unpack +instance Path Double where readPath = readTextDouble +instance Path Float where readPath = fmap realToFrac . readTextDouble instance Path T.Text where readPath = Just; pathRep _ = typeRep (Proxy :: Proxy Text) instance Path TL.Text where readPath = Just . TL.fromStrict; pathRep _ = typeRep (Proxy :: Proxy Text) @@ -104,25 +122,40 @@ qTypeRep :: proxy a -> TypeRep qTypeRep = typeRep +readBS :: (S.ByteString -> Maybe (a, S.ByteString)) + -> S.ByteString -> Maybe a +readBS p b = case p b of + Just (i, s) -> if S.null s then Just i else Nothing + _ -> Nothing + +readBSInt :: Integral a => S.ByteString -> Maybe a +readBSInt = readBS (SL.readSigned SL.readDecimal) + +readBSWord :: Integral a => S.ByteString -> Maybe a +readBSWord = readBS SL.readDecimal + +readBSDouble :: S.ByteString -> Maybe Double +readBSDouble = readBS SL.readDouble + -- | javascript boolean. -- when \"false\", \"0\", \"-0\", \"\", \"null\", \"undefined\", \"NaN\" then False, else True. since 0.6.0.0. instance Query Bool where readQuery = fmap jsToBool -instance Query Int where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Int8 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Int16 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Int32 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Int64 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Integer where readQuery = maybe Nothing (readMaybe . S.unpack) +instance Query Int where readQuery = maybe Nothing readBSInt +instance Query Int8 where readQuery = maybe Nothing readBSInt +instance Query Int16 where readQuery = maybe Nothing readBSInt +instance Query Int32 where readQuery = maybe Nothing readBSInt +instance Query Int64 where readQuery = maybe Nothing readBSInt +instance Query Integer where readQuery = maybe Nothing readBSInt -instance Query Word where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Word8 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Word16 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Word32 where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Word64 where readQuery = maybe Nothing (readMaybe . S.unpack) +instance Query Word where readQuery = maybe Nothing readBSWord +instance Query Word8 where readQuery = maybe Nothing readBSWord +instance Query Word16 where readQuery = maybe Nothing readBSWord +instance Query Word32 where readQuery = maybe Nothing readBSWord +instance Query Word64 where readQuery = maybe Nothing readBSWord -instance Query Double where readQuery = maybe Nothing (readMaybe . S.unpack) -instance Query Float where readQuery = maybe Nothing (readMaybe . S.unpack) +instance Query Double where readQuery = maybe Nothing readBSDouble +instance Query Float where readQuery = maybe Nothing (fmap realToFrac . readBSDouble) instance Query T.Text where readQuery = fmap $ T.decodeUtf8With lenientDecode