diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 1.2.1 +* reduce dependencies. +* relax version restriction of monad-control. +* move pure capture function. +* export hoistActionT, focus', noExtension. + # 1.2.0 * good bye wai-2. * add Web.Apiary.Develop module for develop static file. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,6 +1,6 @@ name: apiary -version: 1.2.0 -synopsis: Simple and type safe web framework that can be automatically generate API documentation. +version: 1.2.1 +synopsis: Simple and type safe web framework that generate web API documentation. description: Simple and type safe web framework that can be automatically generate API documentation. . @@ -18,7 +18,7 @@ (age, name) <- [params|age,name|] guard (age >= 18) contentType "text/html" - mapM_ lazyBytes ["<h1>Hello, ", name, "!</h1>\\n"] + mapM_ appendLazyBytes ["<h1>Hello, ", name, "!</h1>\\n"] @ . @ @@ -70,6 +70,7 @@ Control.Monad.Apiary Control.Monad.Apiary.Filter + Control.Monad.Apiary.Filter.Capture Control.Monad.Apiary.Action Data.Apiary.Extension @@ -80,7 +81,8 @@ Data.Apiary.Document Data.Apiary.Document.Html - other-modules: Data.Apiary.Document.Internal + other-modules: Network.Wai.Parse + Data.Apiary.Document.Internal Data.Apiary.Extension.Internal Control.Monad.Apiary.Internal Control.Monad.Apiary.Filter.Internal @@ -93,7 +95,7 @@ , transformers >=0.2 && <0.5 , transformers-base >=0.4 && <0.5 , mtl >=2.1 && <2.3 - , monad-control >=0.3 && <0.4 + , monad-control >=0.3 && <1.1 , exceptions >=0.6 && <0.7 , http-types >=0.8 && <0.9 @@ -117,7 +119,7 @@ , http-date >=0.0 && <0.1 , wai >=3.0 && <3.1 - , wai-extra >=3.0 && <3.1 + , stringsearch >=0.3 && <0.4 default-extensions: OverlappingInstances hs-source-dirs: src diff --git a/src/Control/Monad/Apiary/Action.hs b/src/Control/Monad/Apiary/Action.hs --- a/src/Control/Monad/Apiary/Action.hs +++ b/src/Control/Monad/Apiary/Action.hs @@ -1,5 +1,6 @@ module Control.Monad.Apiary.Action ( ActionT + , hoistActionT -- * stop action , stop @@ -63,5 +64,3 @@ import Control.Monad.Apiary.Action.Internal import Network.Wai -import Data.Apiary.Document.Html - 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 @@ -13,9 +13,80 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} -module Control.Monad.Apiary.Action.Internal where +module Control.Monad.Apiary.Action.Internal + ( ActionT + , stop + + , param + , params + + , status + + , addHeader, setHeaders, modifyHeader + , contentType + + , reset + , builder + , bytes, lazyBytes + , text, lazyText + , showing + , string, char + , appendBuilder + , appendBytes, appendLazyBytes + , appendText, appendLazyText + , appendShowing + , appendString, appendChar + , file + , file' + + , redirect, redirectPermanently, redirectTemporary + + , defaultDocumentationAction + , DefaultDocumentConfig(..) + + , hoistActionT + , ContentType + , stopWith + + , getRequest + , getHeaders + , getParams + , getQueryParams + , getReqBodyParams + , getReqBodyFiles + + , devFile + , devFile' + , stream + , rawResponse + + , lookupVault + , modifyVault + , insertVault + , adjustVault + , deleteVault + + , redirectWith + + -- internal + , ApiaryConfig(..) + , getState + , modifyState + , getRequestBody + , actionFetches + , execActionT + , applyDict + + , MonadExts(..) + , Extensions(..) + , Extension(..) + , Middleware' + ) where + + import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote(QuasiQuoter(..)) @@ -43,7 +114,7 @@ import Data.Apiary.Param(Param, File(..)) import Data.Apiary.Compat(SProxy(..)) import Data.Apiary.Document(Documents) -import Data.Apiary.Document.Html(defaultDocumentToHtml, DefaultDocumentConfig) +import Data.Apiary.Document.Html(defaultDocumentToHtml, DefaultDocumentConfig(..)) import Data.Default.Class(Default(..)) import Blaze.ByteString.Builder(Builder) @@ -283,16 +354,29 @@ instance MonadBase b m => MonadBase b (ActionT exts prms m) where liftBase = liftBaseDefault +-- `MIN_VERSION_base(major1,major2,minor) instance MonadTransControl (ActionT exts prms) where +#if MIN_VERSION_monad_control(1,0,0) + type StT (ActionT exts prms) a = Action a + liftWith f = actionT $ \prms e !s -> liftM (\a -> Continue s a) (f $ \t -> runActionT t prms e s) + restoreT m = actionT $ \_ _ _ -> m +#else newtype StT (ActionT exts prms) a = StActionT { unStActionT :: Action a } liftWith f = actionT $ \prms e !s -> liftM (\a -> Continue s a) (f $ \t -> liftM StActionT $ runActionT t prms e s) restoreT m = actionT $ \_ _ _ -> liftM unStActionT m +#endif instance MonadBaseControl b m => MonadBaseControl b (ActionT exts prms m) where +#if MIN_VERSION_monad_control(1,0,0) + type StM (ActionT exts prms m) a = ComposeSt (ActionT exts prms) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM +#else newtype StM (ActionT exts prms m) a = StMActionT { unStMActionT :: ComposeSt (ActionT exts prms) m a } liftBaseWith = defaultLiftBaseWith StMActionT restoreM = defaultRestoreM unStMActionT +#endif instance MonadReader r m => MonadReader r (ActionT exts prms m) where ask = lift ask diff --git a/src/Control/Monad/Apiary/Filter.hs b/src/Control/Monad/Apiary/Filter.hs --- a/src/Control/Monad/Apiary/Filter.hs +++ b/src/Control/Monad/Apiary/Filter.hs @@ -32,13 +32,8 @@ , QueryKey(..) , query , Control.Monad.Apiary.Filter.httpVersion - , Capture.path - , Capture.endPath - , Capture.fetch - , Capture.restPath - , Capture.anyPath - , function, function', function_, focus + , function, function', function_, focus, focus' , Doc(..) ) where @@ -57,7 +52,6 @@ , Doc(DocMethod, DocPrecondition, DocRoot, DocQuery, DocAccept)) import Control.Monad.Apiary.Filter.Internal.Capture.TH(capture) import Control.Monad.Apiary.Internal(ApiaryT, focus', focus, PathElem(RootPath)) -import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture import Text.Blaze.Html(Html, toHtml) import qualified Data.ByteString.Char8 as SC diff --git a/src/Control/Monad/Apiary/Filter/Capture.hs b/src/Control/Monad/Apiary/Filter/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Apiary/Filter/Capture.hs @@ -0,0 +1,5 @@ +module Control.Monad.Apiary.Filter.Capture + ( path, endPath, fetch, anyPath, restPath + ) where + +import Control.Monad.Apiary.Filter.Internal.Capture 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 @@ -6,7 +6,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DataKinds #-} -module Control.Monad.Apiary.Filter.Internal.Capture where +module Control.Monad.Apiary.Filter.Internal.Capture + ( path, endPath, fetch, fetch', anyPath, restPath ) where import Control.Applicative((<$>), (<$)) import Control.Monad(liftM, 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 @@ -4,9 +4,33 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} -module Control.Monad.Apiary.Internal where +module Control.Monad.Apiary.Internal + ( ApiaryT + , runApiaryTWith + , runApiaryWith + , runApiary + , ApiaryConfig(..) + + , action + + , middleware + , group + , document + , precondition + , noDoc + + , apiaryConfig + , apiaryExt + + -- internal + , focus, focus' + , PathElem(..) + ) where + + import qualified Network.Wai as Wai import Control.Applicative(Applicative(..), (<$>)) @@ -211,16 +235,28 @@ liftBase m = ApiaryT $ \_ c -> liftBase m >>= \a -> c a mempty instance Monad actM => MonadTransControl (ApiaryT exts prms actM) where - newtype StT (ApiaryT exts prms actM) a = StTApiary' { unStTApiary' :: (a, ApiaryWriter exts actM) } +#if MIN_VERSION_monad_control(1,0,0) + type StT (ApiaryT exts prms actM) a = (a, ApiaryWriter exts actM) + liftWith f = apiaryT $ \env -> liftM (\a -> (a, mempty)) (f $ \t -> unApiaryT t env (\a w -> return (a,w))) + restoreT = apiaryT . const +#else + newtype StT (ApiaryT exts prms actM) a = StTApiary { unStTApiary :: (a, ApiaryWriter exts actM) } 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 + (f $ \t -> liftM StTApiary $ unApiaryT t env (\a w -> return (a,w))) + restoreT m = apiaryT $ \_ -> liftM unStTApiary m +#endif instance (Monad actM, MonadBaseControl b m) => MonadBaseControl b (ApiaryT exts prms actM m) where - newtype StM (ApiaryT exts prms actM m) a = StMApiary' { unStMApiary' :: ComposeSt (ApiaryT exts prms actM) m a } - liftBaseWith = defaultLiftBaseWith StMApiary' - restoreM = defaultRestoreM unStMApiary' +#if MIN_VERSION_monad_control(1,0,0) + type StM (ApiaryT exts prms actM m) a = ComposeSt (ApiaryT exts prms actM) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM +#else + newtype StM (ApiaryT exts prms actM m) a = StMApiary { unStMApiary :: ComposeSt (ApiaryT exts prms actM) m a } + liftBaseWith = defaultLiftBaseWith StMApiary + restoreM = defaultRestoreM unStMApiary +#endif instance Monad actM => MonadExts exts (ApiaryT exts prms actM m) where getExts = envExts <$> getApiaryEnv diff --git a/src/Data/Apiary/Document/Internal.hs b/src/Data/Apiary/Document/Internal.hs --- a/src/Data/Apiary/Document/Internal.hs +++ b/src/Data/Apiary/Document/Internal.hs @@ -2,7 +2,15 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} -module Data.Apiary.Document.Internal where +module Data.Apiary.Document.Internal + ( Doc(..) + , Documents(..) + , PathDoc(..) + , QueryDoc(..) + , MethodDoc(..) + , Route(..) + , docsToDocuments + ) where import Control.Applicative((<$>)) diff --git a/src/Data/Apiary/Extension/Internal.hs b/src/Data/Apiary/Extension/Internal.hs --- a/src/Data/Apiary/Extension/Internal.hs +++ b/src/Data/Apiary/Extension/Internal.hs @@ -7,7 +7,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} -module Data.Apiary.Extension.Internal where +module Data.Apiary.Extension.Internal + ( Initializer(..) + , Has(..) + , allMiddleware' + , allMiddleware + ) where #if __GLASGOW_HASKELL__ >= 708 import qualified Control.Category as Cat 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 @@ -1,7 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -module Data.Apiary.Method where +module Data.Apiary.Method + ( Method(..) + , renderMethod + , dispatchMethod + , parseMethod + ) where import Data.Hashable(Hashable(..)) import Data.String(IsString(..)) diff --git a/src/Network/Wai/Parse.hs b/src/Network/Wai/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Parse.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +-- | Some helpers for parsing data out of a raw WAI 'Request'. +-- +-- copy from wai-extra 3.0.3. + +module Network.Wai.Parse + ( parseHttpAccept + , parseRequestBody + , RequestBodyType (..) + , getRequestBodyType + , sinkRequestBody + , BackEnd + , lbsBackEnd + , Param + , File + , FileInfo (..) + , parseContentType +#if TEST + , Bound (..) + , findBound + , sinkTillBound + , killCR + , killCRLF + , takeLine +#endif + ) where + +import qualified Data.ByteString.Search as Search +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as S8 +import Data.Word (Word8) +import Data.Maybe (fromMaybe) +import Data.List (sortBy) +import Data.Function (on) +import Network.Wai +import qualified Network.HTTP.Types as H +import Control.Monad (when, unless) +import Data.IORef + +breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) +breakDiscard w s = + let (x, y) = S.break (== w) s + in (x, S.drop 1 y) + +-- | Parse the HTTP accept string to determine supported content types. +parseHttpAccept :: S.ByteString -> [S.ByteString] +parseHttpAccept = map fst + . sortBy (rcompare `on` snd) + . map (addSpecificity . grabQ) + . S.split 44 -- comma + where + rcompare :: (Double,Int) -> (Double,Int) -> Ordering + rcompare = flip compare + addSpecificity (s, q) = + -- Prefer higher-specificity types + let semicolons = S.count 0x3B s + stars = S.count 0x2A s + in (s, (q, semicolons - stars)) + grabQ s = + -- Stripping all spaces may be too harsh. + -- Maybe just strip either side of semicolon? + let (s', q) = S.breakSubstring ";q=" (S.filter (/=0x20) s) -- 0x20 is space + q' = S.takeWhile (/=0x3B) (S.drop 3 q) -- 0x3B is semicolon + in (s', readQ q') + readQ s = case reads $ S8.unpack s of + (x, _):_ -> x + _ -> 1.0 + +-- | Store uploaded files in memory +lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString +lbsBackEnd _ _ popper = + loop id + where + loop front = do + bs <- popper + if S.null bs + then return $ L.fromChunks $ front [] + else loop $ front . (bs:) + +-- | Information on an uploaded file. +data FileInfo c = FileInfo + { fileName :: S.ByteString + , fileContentType :: S.ByteString + , fileContent :: c + } + deriving (Eq, Show) + +-- | Post parameter name and value. +type Param = (S.ByteString, S.ByteString) + +-- | Post parameter name and associated file information. +type File y = (S.ByteString, FileInfo y) + +-- | A file uploading backend. Takes the parameter name, file name, and a +-- stream of data. +type BackEnd a = S.ByteString -- ^ parameter name + -> FileInfo () + -> IO S.ByteString + -> IO a + +data RequestBodyType = UrlEncoded | Multipart S.ByteString + +getRequestBodyType :: Request -> Maybe RequestBodyType +getRequestBodyType req = do + ctype' <- lookup "Content-Type" $ requestHeaders req + let (ctype, attrs) = parseContentType ctype' + case ctype of + "application/x-www-form-urlencoded" -> return UrlEncoded + "multipart/form-data" | Just bound <- lookup "boundary" attrs -> return $ Multipart bound + _ -> Nothing + +-- | Parse a content type value, turning a single @ByteString@ into the actual +-- content type and a list of pairs of attributes. +-- +-- Since 1.3.2 +parseContentType :: S.ByteString -> (S.ByteString, [(S.ByteString, S.ByteString)]) +parseContentType a = do + let (ctype, b) = S.break (== semicolon) a + attrs = goAttrs id $ S.drop 1 b + in (ctype, attrs) + where + semicolon = 59 + equals = 61 + space = 32 + goAttrs front bs + | S.null bs = front [] + | otherwise = + let (x, rest) = S.break (== semicolon) bs + in goAttrs (front . (goAttr x:)) $ S.drop 1 rest + goAttr bs = + let (k, v') = S.break (== equals) bs + v = S.drop 1 v' + in (strip k, strip v) + strip = S.dropWhile (== space) . fst . S.breakEnd (/= space) + +parseRequestBody :: BackEnd y + -> Request + -> IO ([Param], [File y]) +parseRequestBody s r = + case getRequestBodyType r of + Nothing -> return ([], []) + Just rbt -> sinkRequestBody s rbt (requestBody r) + +sinkRequestBody :: BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> IO ([Param], [File y]) +sinkRequestBody s r body = do + ref <- newIORef (id, id) + let add x = atomicModifyIORef ref $ \(y, z) -> + case x of + Left y' -> ((y . (y':), z), ()) + Right z' -> ((y, z . (z':)), ()) + conduitRequestBody s r body add + (x, y) <- readIORef ref + return (x [], y []) + +conduitRequestBody :: BackEnd y + -> RequestBodyType + -> IO S.ByteString + -> (Either Param (File y) -> IO ()) + -> IO () +conduitRequestBody _ UrlEncoded rbody add = do + -- NOTE: in general, url-encoded data will be in a single chunk. + -- Therefore, I'm optimizing for the usual case by sticking with + -- strict byte strings here. + let loop front = do + bs <- rbody + if S.null bs + then return $ S.concat $ front [] + else loop $ front . (bs:) + bs <- loop id + mapM_ (add . Left) $ H.parseSimpleQuery bs +conduitRequestBody backend (Multipart bound) rbody add = + parsePieces backend (S8.pack "--" `S.append` bound) rbody add + +takeLine :: Source -> IO (Maybe S.ByteString) +takeLine src = + go id + where + go front = do + bs <- readSource src + if S.null bs + then close front + else push front bs + + close front = leftover src (front S.empty) >> return Nothing + push front bs = do + let (x, y) = S.break (== 10) $ front bs -- LF + in if S.null y + then go $ S.append x + else do + when (S.length y > 1) $ leftover src $ S.drop 1 y + return $ Just $ killCR x + +takeLines :: Source -> IO [S.ByteString] +takeLines src = do + res <- takeLine src + case res of + Nothing -> return [] + Just l + | S.null l -> return [] + | otherwise -> do + ls <- takeLines src + return $ l : ls + +data Source = Source (IO S.ByteString) (IORef S.ByteString) + +mkSource :: IO S.ByteString -> IO Source +mkSource f = do + ref <- newIORef S.empty + return $ Source f ref + +readSource :: Source -> IO S.ByteString +readSource (Source f ref) = do + bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs) + if S.null bs + then f + else return bs + +leftover :: Source -> S.ByteString -> IO () +leftover (Source _ ref) bs = writeIORef ref bs + +parsePieces :: BackEnd y + -> S.ByteString + -> IO S.ByteString + -> (Either Param (File y) -> IO ()) + -> IO () +parsePieces sink bound rbody add = + mkSource rbody >>= loop + where + loop src = do + _boundLine <- takeLine src + res' <- takeLines src + unless (null res') $ do + let ls' = map parsePair res' + let x = do + cd <- lookup contDisp ls' + let ct = lookup contType ls' + let attrs = parseAttrs cd + name <- lookup "name" attrs + return (ct, name, lookup "filename" attrs) + case x of + Just (mct, name, Just filename) -> do + let ct = fromMaybe "application/octet-stream" mct + fi0 = FileInfo filename ct () + (wasFound, y) <- sinkTillBound' bound name fi0 sink src + add $ Right (name, fi0 { fileContent = y }) + when wasFound (loop src) + Just (_ct, name, Nothing) -> do + let seed = id + let iter front bs = return $ front . (:) bs + (wasFound, front) <- sinkTillBound bound iter seed src + let bs = S.concat $ front [] + let x' = (name, bs) + add $ Left x' + when wasFound (loop src) + _ -> do + -- ignore this part + let seed = () + iter () _ = return () + (wasFound, ()) <- sinkTillBound bound iter seed src + when wasFound (loop src) + where + contDisp = S8.pack "Content-Disposition" + contType = S8.pack "Content-Type" + parsePair s = + let (x, y) = breakDiscard 58 s -- colon + in (x, S.dropWhile (== 32) y) -- space + +data Bound = FoundBound S.ByteString S.ByteString + | NoBound + | PartialBound + deriving (Eq, Show) + +findBound :: S.ByteString -> S.ByteString -> Bound +findBound b bs = handleBreak $ Search.breakOn b bs + where + handleBreak (h, t) + | S.null t = go [lowBound..S.length bs - 1] + | otherwise = FoundBound h $ S.drop (S.length b) t + + lowBound = max 0 $ S.length bs - S.length b + + go [] = NoBound + go (i:is) + | mismatch [0..S.length b - 1] [i..S.length bs - 1] = go is + | otherwise = + let endI = i + S.length b + in if endI > S.length bs + then PartialBound + else FoundBound (S.take i bs) (S.drop endI bs) + mismatch [] _ = False + mismatch _ [] = False + mismatch (x:xs) (y:ys) + | S.index b x == S.index bs y = mismatch xs ys + | otherwise = True + +sinkTillBound' :: S.ByteString + -> S.ByteString + -> FileInfo () + -> BackEnd y + -> Source + -> IO (Bool, y) +sinkTillBound' bound name fi sink src = do + (next, final) <- wrapTillBound bound src + y <- sink name fi next + b <- final + return (b, y) + +data WTB = WTBWorking (S.ByteString -> S.ByteString) + | WTBDone Bool +wrapTillBound :: S.ByteString -- ^ bound + -> Source + -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found +wrapTillBound bound src = do + ref <- newIORef $ WTBWorking id + return (go ref, final ref) + where + final ref = do + x <- readIORef ref + case x of + WTBWorking _ -> error "wrapTillBound did not finish" + WTBDone y -> return y + + go ref = do + state <- readIORef ref + case state of + WTBDone _ -> return S.empty + WTBWorking front -> do + bs <- readSource src + if S.null bs + then do + writeIORef ref $ WTBDone False + return $ front bs + else push $ front bs + where + push bs = + case findBound bound bs of + FoundBound before after -> do + let before' = killCRLF before + leftover src after + writeIORef ref $ WTBDone True + return before' + NoBound -> do + -- don't emit newlines, in case it's part of a bound + let (toEmit, front') = + if not (S8.null bs) && S8.last bs `elem` "\r\n" + then let (x, y) = S.splitAt (S.length bs - 2) bs + in (x, S.append y) + else (bs, id) + writeIORef ref $ WTBWorking front' + if S.null toEmit + then go ref + else return toEmit + PartialBound -> do + writeIORef ref $ WTBWorking $ S.append bs + go ref + +sinkTillBound :: S.ByteString + -> (x -> S.ByteString -> IO x) + -> x + -> Source + -> IO (Bool, x) +sinkTillBound bound iter seed0 src = do + (next, final) <- wrapTillBound bound src + let loop seed = do + bs <- next + if S.null bs + then return seed + else iter seed bs >>= loop + seed <- loop seed0 + b <- final + return (b, seed) + +parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] +parseAttrs = map go . S.split 59 -- semicolon + where + tw = S.dropWhile (== 32) -- space + dq s = if S.length s > 2 && S.head s == 34 && S.last s == 34 -- quote + then S.tail $ S.init s + else s + go s = + let (x, y) = breakDiscard 61 s -- equals sign + in (tw x, dq $ tw y) + +killCRLF :: S.ByteString -> S.ByteString +killCRLF bs + | S.null bs || S.last bs /= 10 = bs -- line feed + | otherwise = killCR $ S.init bs + +killCR :: S.ByteString -> S.ByteString +killCR bs + | S.null bs || S.last bs /= 13 = bs -- carriage return + | otherwise = S.init bs diff --git a/src/Web/Apiary.hs b/src/Web/Apiary.hs --- a/src/Web/Apiary.hs +++ b/src/Web/Apiary.hs @@ -7,7 +7,7 @@ -- | Method(..) , module Data.Apiary.Method - -- | Has, MonadHas, Extensions, Initializer, Initializer', (+>) + -- | Has, MonadHas, Extensions, Initializer, Initializer', (+>), noExtension , module Data.Apiary.Extension -- | key, Member, Members, NotMember, Elem((:=)) , module Data.Apiary.Dict @@ -63,6 +63,7 @@ , redirect, redirectPermanently, redirectTemporary , defaultDocumentationAction , DefaultDocumentConfig(..) + , hoistActionT ) import Control.Monad.Apiary.Filter @@ -87,7 +88,7 @@ ) import Data.Apiary.Method(Method(..)) -import Data.Apiary.Extension(Has, MonadExts(..), getExt, Extensions, Initializer, Initializer', (+>)) +import Data.Apiary.Extension(Has, MonadExts(..), getExt, Extensions, Initializer, Initializer', (+>), noExtension) import Data.Apiary.Dict(key, Member, Members, NotMember, Elem((:=))) import Network.HTTP.Types.Status hiding (mkStatus)