apiary 0.15.0 → 0.15.1

raw patch · 7 files changed

+240/−172 lines, 7 filesdep +bytestring-lexingPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring-lexing

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• apiary.cabal +6/−12
• src/Control/Monad/Apiary/Action/Internal.hs +80/−71
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +1/−1
• src/Control/Monad/Apiary/Internal.hs +58/−50
• src/Data/Apiary/Method.hs +31/−10
• src/Data/Apiary/Param.hs +61/−28

@@ -1,4 +1,7 @@ # 0.15.0+* enhance performance(especially parsing parameter).++# 0.15.0 * enhance performance(new router). * add anyPath function. 

@@ -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: <https://github.com/philopon/apiary/blob/v0.15.0/bench>).+    * high performance(benchmark: <https://github.com/philopon/apiary/blob/v0.15.1/bench>).   .     * Nestable route handling(Apiary Monad; capture, method and more.).   .     * type safe route filter.   .-    * auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.15.0/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.15.0/examples/api.html>).+    * auto generate API documentation(example: <https://github.com/philopon/apiary/blob/v0.15.1/examples/api.hs>, <https://rawgit.com/philopon/apiary/v0.15.1/examples/api.html>).   .-  more examples: <https://github.com/philopon/apiary/blob/v0.15.0/examples/>+  more examples: <https://github.com/philopon/apiary/blob/v0.15.1/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

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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