diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +# 0.17.0 +* fix not accept in multi Accept header. +* add greedy path capture('\*\*'). +* add switchQuery filter. +* add Heroku module. +* add google analytics support to API documentation. + +## Extension API +* change interface. +* fix bug which immediately finalize. +* deprecate preAction. +* Category initializer only ghc-7.8+. + +## new extensions +* apiary-mongoDB +* apiary-memcached + # 0.16.0 * new Extension API. * add middleware function. diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.16.0 +version: 0.17.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. @@ -31,15 +31,17 @@ 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: ) license: MIT license-file: LICENSE @@ -66,6 +68,7 @@ library exposed-modules: Web.Apiary + Web.Apiary.Heroku Web.Apiary.Wai Control.Monad.Apiary @@ -100,7 +103,7 @@ , http-types >=0.8 && <0.9 , mime-types >=0.1 && <0.2 - , text >=1.1 && <1.2 + , text >=1.1 && <1.3 , bytestring >=0.10 && <0.11 , bytestring-lexing >=0.4 && <0.5 , blaze-builder >=0.3 && <0.4 @@ -111,7 +114,8 @@ , data-default-class >=0.0 && <0.1 , unordered-containers >=0.2 && <0.3 , hashable >=1.1 && <1.3 - , time >=1.4 && <1.5 + , time >=1.4 && <1.6 + , process >=1.2 && <1.3 if impl(ghc < 7.8) build-depends: tagged >=0.7 && <0.8 diff --git a/src/Control/Monad/Apiary.hs b/src/Control/Monad/Apiary.hs --- a/src/Control/Monad/Apiary.hs +++ b/src/Control/Monad/Apiary.hs @@ -1,7 +1,6 @@ module Control.Monad.Apiary - ( ApiaryT, server - , runApiaryTWith - , runApiaryWith + ( ApiaryT, EApplication, server, serverWith + , runApiaryT , runApiary -- * getter , apiaryConfig 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 @@ -18,7 +18,6 @@ , http09, http10, http11 -- ** path matcher , root - , anyPath , capture , Capture.path , Capture.endPath @@ -30,6 +29,7 @@ -- *** specified operators , (=:), (=!:), (=?:), (=?!:), (?:), (=*:), (=+:) , hasQuery + , switchQuery -- ** header matcher , hasHeader @@ -44,7 +44,7 @@ -- * deprecated , stdMethod - + , anyPath ) where import Network.Wai as Wai @@ -68,7 +68,9 @@ import qualified Data.Text.Encoding as T import Data.Monoid import Data.Proxy +import Data.Apiary.SList import Data.String +import Data.Maybe import Data.Apiary.Param import Data.Apiary.Document @@ -112,9 +114,10 @@ root :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () root = focus' DocRoot Nothing (RootPath:) return +{-# DEPRECATED anyPath "use greedy filter [capture|/**|] or use restPath." #-} -- | match all subsequent path. since 0.15.0. anyPath :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () -anyPath = focus' id Nothing (AnyPath:) return +anyPath = focus' id Nothing (RestPath:) return -------------------------------------------------------------------------------- @@ -239,6 +242,14 @@ hasQuery :: MonadIO actM => QueryKey -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () hasQuery q = query q (Strategy.Check :: Strategy.Check ()) +-- | get existance of key only query parameter. since v0.17.0. +switchQuery :: Monad actM => QueryKey -> ApiaryT exts (Bool ': prms) actM m () -> ApiaryT exts prms actM m () +switchQuery QueryKey{..} = focus doc $ \l -> do + r <- getRequest + return $ (not . null $ filter (\(k,v) -> isNothing v && queryKey == k) (queryString r)) ::: l + where + doc = DocQuery queryKey (StrategyRep "Switch") NoValue queryDesc + -------------------------------------------------------------------------------- -- | check whether to exists specified header or not. since 0.6.0.0. @@ -284,6 +295,6 @@ accept ect = focus (DocPrecondition $ "Accept: " <> toHtml (T.decodeUtf8 ect)) $ \c -> (lookup "Accept" . requestHeaders <$> getRequest) >>= \case Nothing -> mzero - Just ct -> if ect == fst (parseContentType ct) + Just ac -> if parseContentType ect `elem` map (parseContentType . SC.dropWhile (== ' ')) (SC.split ',' ac) then contentType ect >> return c else mzero 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 @@ -41,3 +41,8 @@ f:fs -> case readPathAs p f of Just r -> (r ::: l) <$ modifyState (\s -> s {actionFetches = fs}) Nothing -> mzero + +restPath :: (Monad m, Monad actM) => ApiaryT exts ([T.Text] ': prms) actM m () -> ApiaryT exts prms actM m () +restPath = focus' id Nothing (RestPath:) $ \l -> liftM actionFetches getState >>= \case + [] -> return $ [] ::: l + fs -> fs ::: l <$ modifyState (\s -> s {actionFetches = []}) diff --git a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs --- a/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +++ b/src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs @@ -50,8 +50,8 @@ S h -> [|Just $(stringE h)|] N n -> [|Just $(varE n)|] [|Capture.fetch (Proxy :: Proxy $(conT ty)) $d . $(mkCap as)|] -mkCap (eq:as) = do - [|(Capture.path (fromString $(stringE eq))) . $(mkCap as) |] +mkCap ("**":as) = [|Capture.restPath . $(mkCap as) |] +mkCap (eq:as) = [|(Capture.path (fromString $(stringE eq))) . $(mkCap as) |] -- | capture QuasiQuoter. since 0.1.0.0. -- @@ -61,6 +61,7 @@ -- [capture|\/path|] -- first path == "path" -- [capture|\/int\/:Int|] -- first path == "int" && get 2nd path as Int. -- [capture|\/:Int\/:Double|] -- get first path as Int and get 2nd path as Double. +-- [capture|/**|] -- feed greedy and get all path as [Text] (since 0.17.0). -- @ -- capture :: QuasiQuoter 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 @@ -40,7 +40,7 @@ data Router exts actM = Router { children :: H.HashMap T.Text (Router exts actM) , capturing :: Maybe (Router exts actM) - , anyMatch :: Maybe (PathMethod exts actM) + , restMatch :: Maybe (PathMethod exts actM) , pathMethod :: PathMethod exts actM } @@ -69,7 +69,7 @@ FetchPath -> Router cln (Just $ loop ps (maybe emptyRouter id cap)) anp pm Exact p -> Router (adjust' (loop ps) p cln) cap anp pm EndPath -> loop ps rtr - AnyPath -> Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm + RestPath -> Router cln cap (Just . insPathMethod $ maybe emptyPathMethod id anp) pm RootPath -> let cln' = foldl' (flip $ adjust' (loop [EndPath])) cln rootPat in loop [EndPath] $ Router cln' cap anp pm @@ -83,7 +83,7 @@ | FetchPath | RootPath | EndPath - | AnyPath + | RestPath data ApiaryEnv exts prms actM = ApiaryEnv { envFilter :: ActionT exts actM (SList prms) @@ -94,8 +94,8 @@ , envExts :: Extensions exts } -initialEnv :: Monad actM => Extensions exts -> ApiaryConfig -> ApiaryEnv exts '[] actM -initialEnv exts conf = ApiaryEnv (return SNil) Nothing id conf id exts +initialEnv :: Monad actM => ApiaryConfig -> Extensions exts -> ApiaryEnv exts '[] actM +initialEnv conf = ApiaryEnv (return SNil) Nothing id conf id data ApiaryWriter exts actM = ApiaryWriter { writerRouter :: Router exts actM -> Router exts actM @@ -114,10 +114,11 @@ -> (a -> ApiaryWriter exts actM -> m b) -> m b } + apiaryT :: Monad m => (ApiaryEnv exts prms actM -> m (a, ApiaryWriter exts actM)) -> ApiaryT exts prms actM m a -apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a,w) -> cont a w +apiaryT f = ApiaryT $ \rdr cont -> f rdr >>= \(a, w) -> cont a w routerToAction :: Monad actM => Router exts actM -> ActionT exts actM () routerToAction router = getRequest >>= go @@ -138,30 +139,40 @@ Nothing -> cld ana Just cp -> cld $ loop (fch . (p:)) cp ps `mplus` ana where - ana = maybe mzero (pmAction mzero) anp + ana = do + modifyState (\s -> s {actionFetches = fch $ p:ps} ) + maybe mzero (pmAction mzero) anp cld nxt = case H.lookup p c of Nothing -> nxt Just cd -> loop fch cd ps `mplus` nxt -runApiaryTWith :: (Monad actM, Monad m) => Initializer '[] m exts - -> ApiaryConfig -> (forall b. actM b -> IO b) -> ApiaryT exts '[] actM m () -> m Application -runApiaryTWith (Initializer ir) conf run m = do - exts <- ir NoExtension - wtr <- unApiaryT m (initialEnv exts conf) (\_ w -> return w) +type EApplication e m = Extensions e -> m Application + +runApiaryT :: (Monad actM, Monad m) + => (forall b. actM b -> IO b) + -> ApiaryConfig + -> ApiaryT exts '[] actM m () + -> EApplication exts m +runApiaryT runAct conf m exts = do + wtr <- unApiaryT m (initialEnv conf exts) (\_ w -> return w) let doc = docsToDocuments $ writerDoc wtr [] rtr = writerRouter wtr emptyRouter mw = writerMw wtr - return $! mw $ execActionT conf exts doc (hoistActionT run $ routerToAction rtr) + return $! mw $ execActionT conf exts doc (hoistActionT runAct $ routerToAction rtr) -runApiaryWith :: Monad m => Initializer '[] m exts - -> ApiaryConfig -> ApiaryT exts '[] IO m () -> m Application -runApiaryWith ef conf m = runApiaryTWith ef conf id m +runApiary :: Monad m + => ApiaryConfig + -> ApiaryT exts '[] IO m () + -> EApplication exts m +runApiary = runApiaryT id -runApiary :: Monad m => ApiaryConfig -> ApiaryT '[] '[] IO m () -> m Application -runApiary = runApiaryWith noExtension +server :: Monad m => (Application -> m a) -> EApplication '[] m -> m a +server = serverWith noExtension -server :: Monad m => (Application -> m a) -> m Application -> m a -server = (=<<) +serverWith :: Monad m => Initializer m '[] exts + -> (Application -> m a) -> (EApplication exts m) -> m a +serverWith (Initializer ir) run em = ir NoExtension $ \exts -> + em exts >>= run -------------------------------------------------------------------------------- @@ -211,11 +222,11 @@ getApiaryEnv :: Monad actM => ApiaryT exts prms actM m (ApiaryEnv exts prms actM) getApiaryEnv = ApiaryT $ \env cont -> cont env mempty +apiaryExt :: (Has e exts, Monad actM) => proxy e -> ApiaryT exts prms actM m e +apiaryExt p = getExtension p . envExts <$> getApiaryEnv + apiaryConfig :: Monad actM => ApiaryT exts prms actM m ApiaryConfig apiaryConfig = liftM envConfig getApiaryEnv - -apiaryExt :: (Has e exts, Monad actM) => proxy e -> ApiaryT exts prms actM m e -apiaryExt p = liftM (getExtension p . envExts) getApiaryEnv addRoute :: Monad actM => ApiaryWriter exts actM -> ApiaryT exts prms actM m () addRoute r = ApiaryT $ \_ cont -> cont () r diff --git a/src/Data/Apiary/Document/Html.hs b/src/Data/Apiary/Document/Html.hs --- a/src/Data/Apiary/Document/Html.hs +++ b/src/Data/Apiary/Document/Html.hs @@ -44,13 +44,25 @@ ) data DefaultDocumentConfig = DefaultDocumentConfig - { documentTitle :: T.Text - , documentDescription :: Maybe Html - , documentUseCDN :: Bool + { documentTitle :: T.Text + , documentDescription :: Maybe Html + , documentUseCDN :: Bool + , documentGoogleAnalytics :: Maybe T.Text -- ^ google analytics. since 0.17.0. } +analytics :: T.Text -> Html +analytics code = H.script . H.preEscapedToHtml . T.concat $ + [ "(function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){" + , "(i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o)," + , "m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)" + , "})(window,document,'script','//www.google-analytics.com/analytics.js','ga');" + , "ga('create', '", code, "', 'auto');" + , "ga('send', 'pageview');" + ] + + instance Default DefaultDocumentConfig where - def = DefaultDocumentConfig "API documentation" Nothing True + def = DefaultDocumentConfig "API documentation" Nothing True Nothing defaultDocumentToHtml :: DefaultDocumentConfig -> Documents -> Html defaultDocumentToHtml DefaultDocumentConfig{..} docs = @@ -84,11 +96,13 @@ , $(runIO (readFile "static/jquery.cookie-1.4.1.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) , $(runIO (readFile "static/api-documentation.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|]) , $(runIO (readFile "static/api-documentation.min.css") >>= \c -> [|H.style $ preEscapedToHtml (c::String)|]) + , maybe mempty analytics documentGoogleAnalytics ] htmlQR (Strict r) = toHtml (show r) htmlQR (Nullable r) = H.span (toHtml (show r) <> "?") ! A.title (toValue (show r) <> "(nullable)") htmlQR Check = "check" + htmlQR NoValue = "-" noDesc = H.span "no description" ! A.class_ "no-description" 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 @@ -7,28 +7,48 @@ ( Has(getExtension) , Extensions , addExtension - , Initializer, Initializer' - , initializer, preAction, (+>) , noExtension + -- * create initializer + , Initializer, initializer + , Initializer', initializer' + , initializerBracket + , initializerBracket' + + -- * combine initializer + , (+>) + -- * deprecated + , preAction ) where import Data.Apiary.Extension.Internal -type Initializer' m a = forall i. Initializer i m (a ': i) +type Initializer' m a = forall i. Initializer m i (a ': i) addExtension :: e -> Extensions es -> Extensions (e ': es) addExtension = AddExtension -initializer :: Monad m => m e -> Initializer' m e -initializer m = Initializer $ \e -> do - a <- m - return (addExtension a e) +initializer :: Monad m => (Extensions es -> m e) -> Initializer m es (e ': es) +initializer m = Initializer $ \es n -> do + e <- m es + n (addExtension e es) -preAction :: Monad m => m a -> Initializer i m i -preAction f = Initializer $ \e -> f >> return e +initializer' :: Monad m => m e -> Initializer' m e +initializer' m = initializer (const m) -(+>) :: Monad m => Initializer i m x -> Initializer x m o -> Initializer i m o -Initializer a +> Initializer b = Initializer $ \e -> a e >>= b +initializerBracket :: (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) -noExtension :: Monad m => Initializer '[] m '[] -noExtension = Initializer $ return +initializerBracket' :: (forall a. (e -> m a) -> m a) -> Initializer m es (e ': es) +initializerBracket' m = initializerBracket (const m) + +{-# DEPRECATED preAction "DEPRECATED" #-} +preAction :: Monad m => m a -> Initializer m i i +preAction f = Initializer $ \es n -> f >> n es + +-- | combine two Initializer. since 0.16.0. +(+>) :: Monad m => Initializer m i x -> Initializer m x o -> Initializer m i o +Initializer a +> Initializer b = Initializer $ \e m -> a e (\e' -> b e' m) + +noExtension :: Monad m => Initializer m i i +noExtension = Initializer $ \es n -> n es 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 @@ -5,11 +5,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} module Data.Apiary.Extension.Internal where -newtype Initializer i m o = Initializer - {unInitializer :: Extensions i -> m (Extensions o)} +import Control.Category data Extensions (es :: [*]) where NoExtension :: Extensions '[] @@ -24,3 +25,11 @@ instance Has a as => Has a (a' ': as) where getExtension p (AddExtension _ as) = getExtension p as +newtype Initializer m i o = Initializer + {unInitializer :: forall a. Extensions i -> (Extensions o -> m a) -> m a} + +#if __GLASGOW_HASKELL__ >= 708 +instance Monad m => 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/Data/Apiary/Param.hs b/src/Data/Apiary/Param.hs --- a/src/Data/Apiary/Param.hs +++ b/src/Data/Apiary/Param.hs @@ -64,6 +64,7 @@ = Strict TypeRep | Nullable TypeRep | Check + | NoValue deriving (Show, Eq) class Path a where 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 @@ , module Control.Monad.Apiary.Filter.Internal.Strategy -- | Method(..) , module Data.Apiary.Method - -- | (+>) + -- | Has, Extensions, Initializer, Initializer', (+>) , module Data.Apiary.Extension , act @@ -19,14 +19,14 @@ , module Control.Monad.IO.Class -- | MonadPlus(..), msum, mfilter, guard, (>=>) , module Control.Monad - -- | FilePart(..) + -- | FilePart(..), Application , module Network.Wai -- | Html , module Text.Blaze.Html ) where import Web.Apiary.TH -import Network.Wai(FilePart(..)) +import Network.Wai(FilePart(..), Application) import Network.HTTP.Types.Status hiding (mkStatus) import Control.Monad.Apiary @@ -38,6 +38,6 @@ import Data.Default.Class(def) import Data.Apiary.Param -import Data.Apiary.Extension((+>)) +import Data.Apiary.Extension(Has, Extensions, Initializer, Initializer', (+>)) import Data.Apiary.Method(Method(..)) import Text.Blaze.Html(Html) diff --git a/src/Web/Apiary/Heroku.hs b/src/Web/Apiary/Heroku.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Heroku.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + +module Web.Apiary.Heroku + ( Heroku, HerokuConfig(..) + , heroku, herokuWith + , getHerokuEnv, getHerokuEnv' + ) where + +import System.Environment +import System.Process +import System.Exit + +import Control.Exception +import Control.Arrow hiding (app) +import Control.Applicative +import Control.Monad.Trans + +import Data.IORef +import Data.Proxy +import Data.Default.Class +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Network.Wai +import Control.Monad.Apiary +import Data.Apiary.Extension +import Data.Apiary.Extension.Internal + +data Heroku = Heroku + { herokuEnv :: IORef (Maybe (H.HashMap T.Text T.Text)) + , herokuConfig :: HerokuConfig + } + +data HerokuConfig = HerokuConfig + { defaultPort :: Int + , herokuExecutableName :: String + , herokuAppName :: Maybe String + } + +instance Default HerokuConfig where + def = HerokuConfig 3000 "heroku" Nothing + +initHeroku :: MonadIO m => HerokuConfig -> Initializer' m Heroku +initHeroku conf = initializer' . liftIO $ + Heroku <$> newIORef Nothing <*> pure conf + +-- | use this function instead of serverWith in heroku app. since 0.17.0. +-- +-- @ serverWith exts (run 3000) . runApiary def $ foo @ +-- +-- to +-- +-- @ herokuWith exts run def . runApiary def $ foo @ +-- +herokuWith :: MonadIO m => Initializer m '[Heroku] exts + -> (Int -> Application -> m a) + -> HerokuConfig -> EApplication exts m -> m a +herokuWith ir run conf eapp = ir' NoExtension $ \exts -> do + port <- liftIO $ fmap read (getEnv "PORT") + `catch` (\(_::IOError) -> return $ defaultPort conf) + app <- eapp exts + run port app + where + Initializer ir' = initHeroku conf +> ir + +-- | use this function instead of server in heroku app. since 0.17.0. +-- +-- @ server (run 3000) . runApiary def $ foo @ +-- +-- to +-- +-- @ heroku run def . runApiary def $ foo @ +-- +-- this function provide: +-- +-- * set port by PORT environment variable. +-- * getHerokuEnv function(get config from environment variable or @ heroku config @ command). +heroku :: MonadIO m => (Int -> Application -> m a) + -> HerokuConfig -> EApplication '[Heroku] m -> m a +heroku = herokuWith noExtension + +getHerokuEnv' :: T.Text -> Heroku -> IO (Maybe T.Text) +getHerokuEnv' key Heroku{..} = try (getEnv $ T.unpack key) >>= \case + Right e -> return (Just $ T.pack e) + Left (_::SomeException) -> readIORef herokuEnv >>= \case + Just hm -> return $ H.lookup key hm + Nothing -> do + let args = ["config", "-s"] ++ + maybe [] (\n -> ["--app", n]) (herokuAppName herokuConfig) + cp = proc (herokuExecutableName herokuConfig) args + (_, Just hout, _, h) <- createProcess cp {std_out = CreatePipe} + xc <- waitForProcess h + if xc == ExitSuccess + then do + hm <- H.fromList . map (second T.tail . T.break (== '=')) . T.lines + <$> T.hGetContents hout + writeIORef herokuEnv (Just hm) + return $ H.lookup key hm + else Nothing <$ writeIORef herokuEnv (Just H.empty) + + +getHerokuEnv :: Has Heroku exts => T.Text -> Extensions exts -> IO (Maybe T.Text) +getHerokuEnv key exts = getHerokuEnv' key (getExtension Proxy exts) diff --git a/src/Web/Apiary/TH.hs b/src/Web/Apiary/TH.hs --- a/src/Web/Apiary/TH.hs +++ b/src/Web/Apiary/TH.hs @@ -65,6 +65,7 @@ n -> fail $ "unknown HTTP status code:" ++ show n +{-# DEPRECATED act "no longer maintained" #-} -- | shortcut action. since 0.6.0.0. -- -- @ diff --git a/test/Application.hs b/test/Application.hs --- a/test/Application.hs +++ b/test/Application.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE DataKinds #-} module Application where @@ -50,9 +51,12 @@ assert404 = assertRequest 404 (Just "text/plain") "404 Page Notfound.\n" -------------------------------------------------------------------------------- +runApp :: ApiaryT '[] '[] IO Identity () -> Application +runApp = runIdentity . server return . runApiary def +-------------------------------------------------------------------------------- helloWorldApp :: Application -helloWorldApp = runIdentity . runApiary def $ action $ do +helloWorldApp = runApp $ action $ do contentType "text/plain" bytes "hello" @@ -66,7 +70,7 @@ -------------------------------------------------------------------------------- methodFilterApp :: Application -methodFilterApp = runIdentity . runApiary def $ do +methodFilterApp = runApp $ do method "GET" . action $ contentType "text/plain" >> bytes "GET" method POST . action $ contentType "text/plain" >> bytes "POST" @@ -81,7 +85,7 @@ -------------------------------------------------------------------------------- httpVersionApp :: Application -httpVersionApp = runIdentity . runApiary def $ do +httpVersionApp = runApp $ do http09 . action $ contentType "text/plain" >> bytes "09" http10 . action $ contentType "text/plain" >> bytes "10" http11 . action $ contentType "text/plain" >> bytes "11" @@ -96,7 +100,7 @@ -------------------------------------------------------------------------------- rootFilterApp :: Application -rootFilterApp = runIdentity . runApiary def . root . action $ do +rootFilterApp = runApp . root . action $ do contentType "text/html" bytes "root" @@ -110,7 +114,7 @@ -------------------------------------------------------------------------------- anyFilterApp :: Application -anyFilterApp = runIdentity . runApiary def $ [capture|/test|] . anyPath . action $ do +anyFilterApp = runApp $ [capture|/test|] . anyPath . action $ do contentType "text/plain" bytes "hello" @@ -123,8 +127,24 @@ -------------------------------------------------------------------------------- +restFilterApp :: Application +restFilterApp = runApp $ do + [capture|/test/**|] . action $ \l -> contentType "text/plain" >> showing l + [capture|/test/neko|] . action $ contentType "text/plain" >> bytes "nyan" + +restFilterTest :: Test +restFilterTest = testGroup "rest capture" $ map ($ restFilterApp) + [ testReq "GET /" . assert404 + , testReq "GET /test" . assertPlain200 "[]" + , testReq "GET /test/foo" . assertPlain200 "[\"foo\"]" + , testReq "GET /test/foo/bar" . assertPlain200 "[\"foo\",\"bar\"]" + , testReq "GET /test/neko" . assertPlain200 "nyan" + ] + +-------------------------------------------------------------------------------- + captureApp :: Application -captureApp = runIdentity . runApiary def $ do +captureApp = runApp $ do [capture|/foo|] . action $ contentType "text/plain" >> bytes "foo" [capture|/:Int|] . method GET . action $ \i -> contentType "text/plain" >> bytes "Int " >> showing i [capture|/:Double|] . action $ \i -> contentType "text/plain" >> bytes "Double " >> showing i @@ -145,19 +165,19 @@ -------------------------------------------------------------------------------- -queryApp f g h = runIdentity . runApiary def $ do +queryApp f g h = runApp $ do _ <- (f "foo" pInt) . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i _ <- (g "foo" pString) . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i (h "foo" (pMaybe pString)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i queryOptionalApp :: Application -queryOptionalApp = runIdentity . runApiary def $ do +queryOptionalApp = runApp $ do ("foo" =?!: (5 :: Int)) . action $ \i -> contentType "text/plain" >> bytes "foo Int " >> showing i ("foo" =?!: ("bar" :: String)) . action $ \i -> contentType "text/plain" >> bytes "foo String " >> showing i ("foo" =?!: (Just "baz" :: Maybe String)) . action $ \i -> contentType "text/plain" >> bytes "foo Maybe String " >> showing i queryCheckApp :: Application -queryCheckApp = runIdentity . runApiary def $ do +queryCheckApp = runApp $ do ("foo" ?: pInt) . action $ contentType "text/plain" >> bytes "foo Int" ("foo" ?: pString) . action $ contentType "text/plain" >> bytes "foo String" ("foo" ?: pMaybe pString) . action $ contentType "text/plain" >> bytes "foo Maybe String" @@ -253,7 +273,7 @@ -------------------------------------------------------------------------------- stopApp :: Application -stopApp = runIdentity . runApiary def $ do +stopApp = runApp $ do [capture|/a/:Int|] . action $ \i -> do contentType "text/plain" when (i == 1) $ bytes "one\n" @@ -272,7 +292,7 @@ -------------------------------------------------------------------------------- acceptApp :: Application -acceptApp = runIdentity . runApiary def $ [capture|/|] $ do +acceptApp = runApp $ [capture|/|] $ do accept "application/json" . action $ bytes "json" accept "text/html" . action $ bytes "html" action $ bytes "other" @@ -291,7 +311,7 @@ -------------------------------------------------------------------------------- multipleFilter1App :: Application -multipleFilter1App = runIdentity . runApiary def $ do +multipleFilter1App = runApp $ do root $ do method GET . action $ contentType "text/plain" >> bytes "GET /" method POST . action $ contentType "text/html" >> bytes "POST /" @@ -315,6 +335,7 @@ , httpVersionTest , rootFilterTest , anyFilterTest + , restFilterTest , captureTest , queryTest , stopTest