diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 1.1.0 +* Added Extension class. now Extension can add middleware. +* Added apiary-helics submodule. + # 1.0.0 * included named parameter. motivation: diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 1.0.0 +version: 1.1.0 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. @@ -32,15 +32,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: . live demo: (source code: ) 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 @@ -69,6 +69,7 @@ , defaultStatus :: Status -- | initial headers. , defaultHeaders :: ResponseHeaders + , defaultContentType :: S.ByteString , failStatus :: Status , failHeaders :: ResponseHeaders -- | used by 'Control.Monad.Apiary.Filter.root' filter. @@ -95,6 +96,7 @@ { notFound = defaultNotFound , defaultStatus = ok200 , defaultHeaders = [] + , defaultContentType = "text/plain" , failStatus = internalServerError500 , failHeaders = [] , rootPattern = ["index.html", "index.htm"] @@ -115,34 +117,37 @@ ResponseBuilder a `mappend` ResponseBuilder b = ResponseBuilder $ a <> b _ `mappend` b = b - toResponse :: ActionState -> Response toResponse ActionState{..} = case actionResponse of - ResponseFile f p -> responseFile actionStatus actionHeaders f p - ResponseBuilder b -> responseBuilder actionStatus actionHeaders b + ResponseFile f p -> responseFile actionStatus headers f p + ResponseBuilder b -> responseBuilder actionStatus headers b #ifdef WAI3 - ResponseStream s -> responseStream actionStatus actionHeaders s + ResponseStream s -> responseStream actionStatus headers s #else - ResponseStream s -> responseSource actionStatus actionHeaders s + ResponseStream s -> responseSource actionStatus headers s #endif ResponseRaw f r -> responseRaw f r - ResponseFunc f -> f actionStatus actionHeaders + ResponseFunc f -> f actionStatus headers + where + headers = ("Content-Type", actionContentType) : actionHeaders data ActionState = ActionState - { actionResponse :: ResponseBody - , actionStatus :: Status - , actionHeaders :: ResponseHeaders - , actionReqBody :: Maybe ([Param], [File]) - , actionFetches :: [T.Text] + { actionResponse :: ResponseBody + , actionStatus :: Status + , actionHeaders :: ResponseHeaders + , actionContentType :: S.ByteString + , actionReqBody :: Maybe ([Param], [File]) + , actionFetches :: [T.Text] } initialState :: ApiaryConfig -> ActionState initialState conf = ActionState - { actionResponse = ResponseBuilder mempty - , actionStatus = defaultStatus conf - , actionHeaders = defaultHeaders conf - , actionReqBody = Nothing - , actionFetches = [] + { actionResponse = ResponseBuilder mempty + , actionStatus = defaultStatus conf + , actionHeaders = defaultHeaders conf + , actionContentType = defaultContentType conf + , actionReqBody = Nothing + , actionFetches = [] } {-# INLINE initialState #-} @@ -242,6 +247,8 @@ unActionT' mf env st $ \f !st' -> unActionT' ma env st' $ \a !st'' -> cont (f a) st'' + {-# INLINE pure #-} + {-# INLINE (<*>) #-} instance Monad m => Monad (ActionT' exts m) where return x = ActionT' $ \_ !st cont -> cont x st @@ -250,6 +257,8 @@ unActionT' (k a) env st' cont fail s = ActionT' $ \(ActionEnv{actionConfig = c}) _ _ -> return $ Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s) + {-# INLINE return #-} + {-# INLINE (>>=) #-} instance (Monad m, Functor m) => Alternative (ActionT' exts m) where empty = mzero @@ -440,24 +449,30 @@ getHeaders = requestHeaders `liftM` getRequest -- | modify response header. since 0.1.0.0. +-- +-- Don't set Content-Type using this function. Use @contentType@. modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT exts prms m () modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } ) -- | add response header. since 0.1.0.0. +-- +-- Don't set Content-Type using this function. Use @contentType@. addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT exts prms m () addHeader h v = modifyHeader ((h,v):) -- | set response headers. since 0.1.0.0. +-- +-- Don't set Content-Type using this function. Use @contentType@. setHeaders :: Monad m => ResponseHeaders -> ActionT exts prms m () setHeaders hs = modifyHeader (const hs) type ContentType = S.ByteString -- | set content-type header. +-- -- if content-type header already exists, replace it. since 0.1.0.0. contentType :: Monad m => ContentType -> ActionT exts prms m () -contentType c = modifyHeader - (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h) +contentType c = modifyState (\s -> s { actionContentType = c } ) -------------------------------------------------------------------------------- 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 @@ -158,9 +158,9 @@ wtr <- unApiaryT m (initialEnv conf exts) (\_ w -> return w) let doc = docsToDocuments $ writerDoc wtr [] rtr = writerRouter wtr emptyRouter - mw = writerMw wtr + mw = allMiddleware exts . writerMw wtr app = mw $ execActionT' conf exts doc (hoistActionT' runAct $ routerToAction rtr) - run app + run $! app runApiaryWith :: Monad m => (Application -> m a) diff --git a/src/Data/Apiary/Extension.hs b/src/Data/Apiary/Extension.hs --- a/src/Data/Apiary/Extension.hs +++ b/src/Data/Apiary/Extension.hs @@ -5,6 +5,7 @@ module Data.Apiary.Extension ( Has(getExtension) + , Extension(..) , Extensions , noExtension -- * initializer constructor @@ -21,22 +22,22 @@ type Initializer' m a = forall i. Initializer m i (a ': i) -addExtension :: e -> Extensions es -> Extensions (e ': es) +addExtension :: Extension e => e -> Extensions es -> Extensions (e ': es) addExtension = AddExtension -initializer :: Monad m => (Extensions es -> m e) -> Initializer m es (e ': es) +initializer :: (Extension e, Monad m) => (Extensions es -> m e) -> Initializer m es (e ': es) initializer m = Initializer $ \es n -> do e <- m es n (addExtension e es) -initializer' :: Monad m => m e -> Initializer' m e +initializer' :: (Extension e, Monad m) => m e -> Initializer' m e initializer' m = initializer (const m) -initializerBracket :: (forall a. Extensions es -> (e -> m a) -> m a) -> Initializer m es (e ': es) +initializerBracket :: Extension e => (forall a. Extensions es -> (e -> m a) -> m a) -> Initializer m es (e ': es) initializerBracket b = Initializer $ \es n -> b es $ \e -> n (addExtension e es) -initializerBracket' :: (forall a. (e -> m a) -> m a) -> Initializer m es (e ': es) +initializerBracket' :: Extension e => (forall a. (e -> m a) -> m a) -> Initializer m es (e ': es) initializerBracket' m = initializerBracket (const m) -- | combine two Initializer. since 0.16.0. 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 @@ -10,11 +10,12 @@ module Data.Apiary.Extension.Internal where -import Control.Category +import Network.Wai +import qualified Control.Category as Cat data Extensions (es :: [*]) where NoExtension :: Extensions '[] - AddExtension :: (e :: *) -> Extensions es -> Extensions (e ': es) + AddExtension :: Extension e => (e :: *) -> Extensions es -> Extensions (e ': es) class Has a (as :: [*]) where getExtension :: proxy a -> Extensions as -> a @@ -28,8 +29,16 @@ newtype Initializer m i o = Initializer {unInitializer :: forall a. Extensions i -> (Extensions o -> m a) -> m a} +class Extension a where + extMiddleware :: a -> Middleware + extMiddleware _ = id + +allMiddleware :: Extensions es -> Middleware +allMiddleware NoExtension = id +allMiddleware (AddExtension e es) = extMiddleware e . allMiddleware es + #if __GLASGOW_HASKELL__ >= 708 -instance Monad m => Category (Initializer m) where +instance Monad m => Cat.Category (Initializer m) where id = Initializer $ \es m -> m es Initializer a . Initializer b = Initializer $ \e m -> b e (\e' -> a e' m) #endif diff --git a/src/Web/Apiary/Heroku.hs b/src/Web/Apiary/Heroku.hs --- a/src/Web/Apiary/Heroku.hs +++ b/src/Web/Apiary/Heroku.hs @@ -41,6 +41,8 @@ , herokuConfig :: HerokuConfig } +instance Extension Heroku + data HerokuConfig = HerokuConfig { defaultPort :: Int , herokuExecutableName :: String