apiary 1.1.4 → 1.2.0

raw patch · 22 files changed

+624/−607 lines, 22 filesdep +vaultdep −conduitdep −wai-testdep ~waidep ~wai-extraPVP ok

version bump matches the API change (PVP)

Dependencies added: vault

Dependencies removed: conduit, wai-test

Dependency ranges changed: wai, wai-extra

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• apiary.cabal +7/−19
• src/Control/Monad/Apiary/Action.hs +14/−8
• src/Control/Monad/Apiary/Action/Internal.hs +193/−202
• src/Control/Monad/Apiary/Filter.hs +36/−34
• src/Control/Monad/Apiary/Filter/Internal.hs +14/−10
• src/Control/Monad/Apiary/Filter/Internal/Capture.hs +19/−21
• src/Control/Monad/Apiary/Filter/Internal/Capture/TH.hs +23/−25
• src/Control/Monad/Apiary/Internal.hs +40/−38
• src/Data/Apiary/Compat.hs +8/−7
• src/Data/Apiary/Dict.hs +41/−40
• src/Data/Apiary/Document/Html.hs +91/−92
• src/Data/Apiary/Document/Internal.hs +9/−12
• src/Data/Apiary/Extension.hs +9/−7
• src/Data/Apiary/Extension/Internal.hs +14/−14
• src/Data/Apiary/Method.hs +3/−3
• src/Data/Apiary/Param.hs +28/−32
• src/Web/Apiary.hs +7/−2
• src/Web/Apiary/Develop.hs +18/−0
• src/Web/Apiary/Heroku.hs +22/−22
• src/Web/Apiary/Wai.hs +0/−6
• test/Application.hs +13/−13

@@ -1,3 +1,18 @@+# 1.2.0+* good bye wai-2.+* add Web.Apiary.Develop module for develop static file.+* *change* response body function behaviour(append to set).+* add append* functions.+* remove MonadHas class. add MonadExt class.+* add action vault for extension.+* change binary package to cereal package.++## apiary-websockets+* fix actionWithWebSockets don't exec action.++## apiary-session/apiary-clientsession/apiary-authenticate+* new session system.+ # 1.1.4 * enhance API documentation. * add MonadHas class.

@@ -1,5 +1,5 @@ name:                apiary-version:             1.1.4+version:             1.2.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.@@ -40,7 +40,7 @@   .     * Auto generate API documentation(example: <http://best-haskell.herokuapp.com/api/documentation>).   .-  more examples: <https://github.com/philopon/apiary/blob/v1.1.4/examples/>+  more examples: <https://github.com/philopon/apiary/blob/v1.2.0/examples/>   .   live demo: <http://best-haskell.herokuapp.com/> (source code: <https://github.com/philopon/best-haskell>) @@ -63,14 +63,10 @@                    , CHANGELOG.md cabal-version:       >=1.10 -flag wai3-  description: use wai-3.0-  default: True- library   exposed-modules:     Web.Apiary+                       Web.Apiary.Develop                        Web.Apiary.Heroku-                       Web.Apiary.Wai                         Control.Monad.Apiary                        Control.Monad.Apiary.Filter@@ -110,6 +106,7 @@                      , blaze-html           >=0.7   && <0.8                      , blaze-markup         >=0.6   && <0.7                      , case-insensitive     >=1.1   && <1.3+                     , vault                >=0.3   && <0.4                       , data-default-class   >=0.0   && <0.1                      , unordered-containers >=0.2   && <0.3@@ -119,15 +116,10 @@                      , unix-compat          >=0.4   && <0.5                      , http-date            >=0.0   && <0.1 -  if flag(wai3)-    build-depends:     wai                  >=3.0   && <3.1+                     , wai                  >=3.0   && <3.1                      , wai-extra            >=3.0   && <3.1-    cpp-options:       -DWAI3-  else-    build-depends:     wai                  >=2.1   && <2.2-                     , wai-extra            >=2.1   && <2.2-                     , conduit              >=1.1   && <1.2 +  default-extensions:  OverlappingInstances   hs-source-dirs:      src   ghc-options:         -O2 -Wall   ghc-prof-options:    -O2 -Wall -auto-all@@ -146,12 +138,8 @@                      , bytestring           >=0.10  && <0.11                      , http-types           >=0.8   && <0.9                      , HUnit                >=1.2   && <1.3-  if flag(wai3)-    build-depends:     wai                  >=3.0   && <3.1+                     , wai                  >=3.0   && <3.1                      , wai-extra            >=3.0   && <3.1-  else-    build-depends:     wai                  >=2.1   && <2.2-                     , wai-test             >=2.0   && <2.1    hs-source-dirs:      test   ghc-options:         -O2 -Wall -fno-warn-missing-signatures

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Control.Monad.Apiary.Action      ( ActionT     -- * stop action@@ -21,8 +19,13 @@     , text,  lazyText     , showing     , string, char+    , appendBuilder+    , appendBytes, appendLazyBytes+    , appendText, appendLazyText+    , appendShowing+    , appendString, appendChar     , file-    , devFile+    , file'      -- ** monolithic action     -- *** redirect@@ -43,19 +46,22 @@     , getReqBodyParams     , getReqBodyFiles     -- ** setter-    , file'+    , devFile     , devFile'     , stream     , rawResponse     , StreamingBody+    -- ** vault+    , lookupVault+    , modifyVault+    , insertVault+    , adjustVault+    , deleteVault     -- ** redirect     , redirectWith     ) where  import Control.Monad.Apiary.Action.Internal-+import Network.Wai import Data.Apiary.Document.Html -#ifdef WAI3-import Network.Wai-#endif

@@ -1,54 +1,53 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}  module Control.Monad.Apiary.Action.Internal where -import Language.Haskell.TH-import Language.Haskell.TH.Quote+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote(QuasiQuoter(..)) -import System.PosixCompat.Files+import qualified System.PosixCompat.Files as Files -import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Base-import Control.Monad.Reader-import Control.Monad.Catch+import Control.Applicative (Applicative(..), Alternative(..), (<$>))+import Control.Monad (MonadPlus(..), liftM)+import Control.Monad.Trans(MonadIO(..), MonadTrans(..))+import Control.Monad.Base(MonadBase(..), liftBaseDefault)+import Control.Monad.Reader(MonadReader(..), ReaderT)+import Control.Monad.Catch(MonadThrow(..), MonadCatch(..), MonadMask(..)) import Control.Monad.Trans.Control+    (MonadTransControl(..), MonadBaseControl(..)+    , ComposeSt+    , defaultLiftBaseWith, defaultRestoreM) -import Network.Mime hiding (Extension)-import Network.HTTP.Date-import Network.HTTP.Types as Http-import Network.Wai+import Network.Mime(defaultMimeLookup)+import Network.HTTP.Date(parseHTTPDate, epochTimeToHTTPDate, formatHTTPDate)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P -import Data.Monoid hiding (All)-import Data.Apiary.Extension-import Data.Apiary.Dict-import Data.Apiary.Param-import Data.Apiary.Compat-import Data.Apiary.Document-import Data.Apiary.Document.Html-import Data.Default.Class+import Data.Monoid(Monoid(..), (<>))+import qualified Data.Apiary.Dict as Dict+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.Default.Class(Default(..)) -import Blaze.ByteString.Builder-import Text.Blaze.Html.Renderer.Utf8+import Blaze.ByteString.Builder(Builder)+import Text.Blaze.Html.Renderer.Utf8(renderHtmlBuilder) import qualified Blaze.ByteString.Builder as B import qualified Blaze.ByteString.Builder.Char.Utf8 as B import qualified Data.ByteString as S@@ -56,22 +55,18 @@ import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.Text as T import qualified Data.Text.Lazy as TL--#ifndef WAI3-import Data.Conduit-type StreamingBody = Source IO (Flush Builder)-#endif+import qualified Data.Vault.Lazy as V  data ApiaryConfig = ApiaryConfig     { -- | call when no handler matched.-      notFound            :: Application+      notFound            :: Wai.Application       -- | used unless call 'status' function.-    , defaultStatus       :: Status+    , defaultStatus       :: HTTP.Status       -- | initial headers.-    , defaultHeaders      :: ResponseHeaders+    , defaultHeaders      :: HTTP.ResponseHeaders     , defaultContentType  :: S.ByteString-    , failStatus          :: Status-    , failHeaders         :: ResponseHeaders+    , failStatus          :: HTTP.Status+    , failHeaders         :: HTTP.ResponseHeaders       -- | used by 'Control.Monad.Apiary.Filter.root' filter.     , rootPattern         :: [T.Text]     , mimeType            :: FilePath -> S.ByteString@@ -84,20 +79,16 @@     contentType "text/html"     builder . renderHtmlBuilder $ defaultDocumentToHtml conf d -defaultNotFound :: Application-#ifdef WAI3-defaultNotFound _ f = f      $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"-#else-defaultNotFound _   = return $ responseLBS status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"-#endif+defaultNotFound :: Wai.Application+defaultNotFound _ f = f      $ Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "404 Page Notfound.\n"  instance Default ApiaryConfig where     def = ApiaryConfig          { notFound            = defaultNotFound-        , defaultStatus       = ok200+        , defaultStatus       = HTTP.ok200         , defaultHeaders      = []         , defaultContentType  = "text/plain"-        , failStatus          = internalServerError500+        , failStatus          = HTTP.internalServerError500         , failHeaders         = []         , rootPattern         = ["index.html", "index.htm"]         , mimeType            = defaultMimeLookup . T.pack@@ -106,35 +97,34 @@ --------------------------------------------------------------------------------  data ResponseBody-    = ResponseFile FilePath (Maybe FilePart)+    = ResponseFile FilePath (Maybe Wai.FilePart)     | ResponseBuilder Builder-    | ResponseStream StreamingBody-    | ResponseRaw (IO S.ByteString -> (S.ByteString -> IO ()) -> IO ()) Response-    | ResponseFunc (Status -> ResponseHeaders -> Response)+    | ResponseStream Wai.StreamingBody+    | ResponseRaw (IO S.ByteString -> (S.ByteString -> IO ()) -> IO ()) Wai.Response+    | ResponseFunc (HTTP.Status -> HTTP.ResponseHeaders -> Wai.Response)  instance Monoid ResponseBody where     mempty = ResponseBuilder mempty     ResponseBuilder a `mappend` ResponseBuilder b = ResponseBuilder $ a <> b     _ `mappend` b = b -toResponse :: ActionState -> Response+toResponse :: ActionState -> Wai.Response toResponse ActionState{..} = case actionResponse of-    ResponseFile  f p -> responseFile    actionStatus headers f p-    ResponseBuilder b -> responseBuilder actionStatus headers b-#ifdef WAI3-    ResponseStream  s -> responseStream  actionStatus headers s-#else-    ResponseStream  s -> responseSource  actionStatus headers s-#endif-    ResponseRaw   f r -> responseRaw f r+    ResponseFile  f p -> Wai.responseFile    actionStatus headers f p+    ResponseBuilder b -> Wai.responseBuilder actionStatus headers b+    ResponseStream  s -> Wai.responseStream  actionStatus headers s+    ResponseRaw   f r -> Wai.responseRaw f r     ResponseFunc    f -> f actionStatus headers   where     headers = ("Content-Type", actionContentType) : actionHeaders +--------------------------------------------------------------------------------+ data ActionState = ActionState     { actionResponse    :: ResponseBody-    , actionStatus      :: Status-    , actionHeaders     :: ResponseHeaders+    , actionStatus      :: HTTP.Status+    , actionHeaders     :: HTTP.ResponseHeaders+    , actionVault       :: V.Vault     , actionContentType :: S.ByteString     , actionReqBody     :: Maybe ([Param], [File])     , actionFetches     :: [T.Text]@@ -145,6 +135,7 @@     { actionResponse    = ResponseBuilder mempty     , actionStatus      = defaultStatus  conf     , actionHeaders     = defaultHeaders conf+    , actionVault       = V.empty     , actionContentType = defaultContentType conf     , actionReqBody     = Nothing     , actionFetches     = []@@ -152,10 +143,32 @@ {-# INLINE initialState #-}  --------------------------------------------------------------------------------+data Extensions (es :: [*]) where+    NoExtension  :: Extensions '[]+    AddExtension :: Extension e => (e :: *) -> Extensions es -> Extensions (e ': es) +type Middleware' = forall exts. ActionT exts '[] IO () -> ActionT exts '[] IO ()++class Extension e where+    extMiddleware :: e -> Wai.Middleware+    extMiddleware _ = id+    {-# INLINE extMiddleware #-}++    extMiddleware'  :: e -> Middleware'+    extMiddleware'  _ = id+    {-# INLINE extMiddleware' #-}++class Monad m => MonadExts es m | m -> es where+    getExts :: m (Extensions es)++instance Monad m => MonadExts es (ReaderT (Extensions es) m) where+    getExts = ask++--------------------------------------------------------------------------------+ data ActionEnv exts = ActionEnv     { actionConfig    :: ApiaryConfig-    , actionRequest   :: Request+    , actionRequest   :: Wai.Request     , actionDocuments :: Documents     , actionExts      :: Extensions exts     }@@ -163,10 +176,10 @@ data Action a      = Continue ActionState a     | Pass-    | Stop Response+    | Stop Wai.Response  newtype ActionT exts prms m a = ActionT { unActionT :: forall b. -    Dict prms+    Dict.Dict prms     -> ActionEnv exts     -> ActionState     -> (a -> ActionState -> m (Action b))@@ -174,14 +187,14 @@     } deriving (Functor)  runActionT :: Monad m => ActionT exts prms m a-           -> Dict prms -> ActionEnv exts -> ActionState+           -> Dict.Dict prms -> ActionEnv exts -> ActionState            -> m (Action a) runActionT m dict env st = unActionT m dict env st $ \a !st' ->     return (Continue st' a) {-# INLINE runActionT #-}  actionT :: Monad m -        => (Dict prms -> ActionEnv exts -> ActionState -> m (Action a))+        => (Dict.Dict prms -> ActionEnv exts -> ActionState -> m (Action a))         -> ActionT exts prms m a actionT f = ActionT $ \dict env !st cont -> f dict env st >>= \case     Pass            -> return Pass@@ -195,85 +208,17 @@ hoistActionT run m = actionT $ \d e s -> run (runActionT m d e s) {-# INLINE hoistActionT #-} -newtype ActionT' exts m a = ActionT' { unActionT' :: forall b. -    ActionEnv exts-    -> ActionState-    -> (a -> ActionState -> m (Action b))-    -> m (Action b)-    } deriving (Functor)--applyDict :: Dict prms -> ActionT exts prms m a -> ActionT' exts m a-applyDict d (ActionT m) = ActionT' (m d)+applyDict :: Dict.Dict prms -> ActionT exts prms m a -> ActionT exts '[] m a+applyDict d (ActionT m) = ActionT $ const (m d) {-# INLINE applyDict #-} -actionT' :: Monad m -         => (ActionEnv exts -> ActionState -> m (Action a))-         -> ActionT' exts 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' #-}--runActionT' :: Monad m => ActionT' exts m a-            -> ActionEnv exts -> ActionState-            -> m (Action a)-runActionT' m env st = unActionT' m env st $ \a !st' -> return (Continue st' a)-{-# INLINE runActionT' #-}--hoistActionT' :: (Monad m, Monad n)-              => (forall b. m b -> n b) -> ActionT' exts m a -> ActionT' exts n a-hoistActionT' run m = actionT' $ \e s -> run (runActionT' m e s)-{-# INLINE hoistActionT' #-}--execActionT' :: ApiaryConfig -> Extensions exts -> Documents -> ActionT' exts IO () -> Application-#ifdef WAI3-execActionT' config exts doc m request send = -#else-execActionT' config exts doc m request = let send = return in-#endif-    runActionT' m (ActionEnv config request doc exts) (initialState config) >>= \case-#ifdef WAI3+execActionT :: ApiaryConfig -> Extensions exts -> Documents -> ActionT exts '[] IO () -> Wai.Application+execActionT config exts doc m request send = +    runActionT m Dict.empty (ActionEnv config request doc exts) (initialState config) >>= \case         Pass         -> notFound config request send-#else-        Pass         -> notFound config request-#endif         Stop s       -> send s         Continue r _ -> send $ toResponse r -instance Applicative (ActionT' exts 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''-    {-# INLINE pure #-}-    {-# INLINE (<*>) #-}--instance Monad m => Monad (ActionT' exts m) where-    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)-    {-# INLINE return #-}-    {-# INLINE (>>=) #-}--instance (Monad m, Functor m) => Alternative (ActionT' exts m) where-    empty = mzero-    (<|>) = mplus-    {-# INLINE empty #-}-    {-# INLINE (<|>) #-}--instance Monad m => MonadPlus (ActionT' exts m) where-    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 #-} --------------------------------------------------------------------------------  instance Applicative (ActionT exts prms m) where@@ -289,7 +234,7 @@         unActionT m dict env st $ \a !st' ->         unActionT (k a) dict env st' cont     fail s = ActionT $ \_ (ActionEnv{actionConfig = c}) _ _ -> return $-        Stop (responseLBS (failStatus c) (failHeaders c) $ LC.pack s)+        Stop (Wai.responseLBS (failStatus c) (failHeaders c) $ LC.pack s)  instance MonadIO m => MonadIO (ActionT exts prms m) where     liftIO m = ActionT $ \_ _ !st cont ->@@ -353,26 +298,25 @@     ask     = lift ask     local f = hoistActionT $ local f -instance (Monad m, Has e exts) => MonadHas e (ActionT exts prms m) where-    getExt p = liftM (getExtension p . actionExts) getEnv+instance Monad m => MonadExts exts (ActionT exts prms m) where+    getExts = liftM actionExts getEnv  --------------------------------------------------------------------------------  getEnv :: Monad m => ActionT exts prms m (ActionEnv exts) getEnv = ActionT $ \_ e s c -> c e s--getRequest' :: Monad m => ActionT' exts m Request-getRequest' = ActionT' $ \e s c -> c (actionRequest e) s+{-# INLINE getEnv #-}  -- | get raw request. since 0.1.0.0.-getRequest :: Monad m => ActionT exts prms m Request+getRequest :: Monad m => ActionT exts prms m Wai.Request getRequest = liftM actionRequest getEnv  getConfig :: Monad m => ActionT exts prms m ApiaryConfig getConfig = liftM actionConfig getEnv -getParams :: Monad m => ActionT exts prms m (Dict prms)+getParams :: Monad m => ActionT exts prms m (Dict.Dict prms) getParams = ActionT $ \d _ s c -> c d s+{-# INLINE getParams #-}  -- | get parameter. since 1.0.0. --@@ -380,17 +324,17 @@ -- -- > param [key|foo|] ---param :: (Member k v prms, Monad m) => proxy k -> ActionT exts prms m v-param p = liftM (get p) getParams+param :: (Dict.Member k v prms, Monad m) => proxy k -> ActionT exts prms m v+param p = liftM (Dict.get p) getParams -paramsE :: [String] -> ExpQ+paramsE :: [String] -> TH.ExpQ paramsE ps = do-    ns <- mapM (\p -> (,) <$> newName "x" <*> pure p) ps-    let bs  = map (\(v, k) -> bindS (varP v) (prm k)) ns-        tpl = noBindS [| return $(tupE $ map (varE . fst) ns) |]-    doE $ bs ++ [tpl]+    ns <- mapM (\p -> (,) <$> TH.newName "x" <*> pure p) ps+    let bs  = map (\(v, k) -> TH.bindS (TH.varP v) (prm k)) ns+        tpl = TH.noBindS [| return $(TH.tupE $ map (TH.varE . fst) ns) |]+    TH.doE $ bs ++ [tpl]   where-    prm  n = [| param (SProxy :: SProxy $(litT $ strTyLit n)) |]+    prm  n = [| param (SProxy :: SProxy $(TH.litT $ TH.strTyLit n)) |]  -- | get parameters. since 1.0.0. --@@ -417,8 +361,8 @@   where     convFile (p, P.FileInfo{..}) = File p fileName fileContentType fileContent -getQueryParams :: Monad m => ActionT exts prms m Http.Query-getQueryParams = queryString <$> getRequest+getQueryParams :: Monad m => ActionT exts prms m HTTP.Query+getQueryParams = Wai.queryString <$> getRequest  -- | parse request body and return params. since 1.0.0. getReqBodyParams :: MonadIO m => ActionT exts prms m [Param]@@ -428,41 +372,35 @@ getReqBodyFiles :: MonadIO m => ActionT exts prms m [File] getReqBodyFiles = snd <$> getRequestBody ---------------------------------------------------------------------------------+-- | get all request headers. since 0.6.0.0.+getHeaders :: Monad m => ActionT exts prms m HTTP.RequestHeaders+getHeaders = Wai.requestHeaders `liftM` getRequest -modifyState' :: Monad m => (ActionState -> ActionState) -> ActionT' exts m ()-modifyState' f = ActionT' $ \_ s c -> c () (f s)+--------------------------------------------------------------------------------  modifyState :: Monad m => (ActionState -> ActionState) -> ActionT exts prms m () modifyState f = ActionT $ \_ _ s c -> c () (f s) -getState :: ActionT exts prms m ActionState-getState = ActionT $ \_ _ s c -> c s s- -- | set status code. since 0.1.0.0.-status :: Monad m => Status -> ActionT exts prms m ()+status :: Monad m => HTTP.Status -> ActionT exts prms m () status st = modifyState (\s -> s { actionStatus = st } ) --- | get all request headers. since 0.6.0.0.-getHeaders :: Monad m => ActionT exts prms m RequestHeaders-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 :: Monad m => (HTTP.ResponseHeaders -> HTTP.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 :: Monad m => HTTP.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 :: Monad m => HTTP.ResponseHeaders -> ActionT exts prms m () setHeaders hs = modifyHeader (const hs)  type ContentType = S.ByteString@@ -473,6 +411,29 @@ contentType :: Monad m => ContentType -> ActionT exts prms m () contentType c = modifyState (\s -> s { actionContentType = c } ) +getState :: ActionT exts prms m ActionState+getState = ActionT $ \_ _ s c -> c s s++-- | lookup extensional state. since v1.2.0.+lookupVault :: V.Key a -> ActionT exts prms m (Maybe a)+lookupVault k = V.lookup k . actionVault <$> getState++-- | modify extensional state. since v1.2.0.+modifyVault :: (V.Vault -> V.Vault) -> ActionT exts prms m ()+modifyVault f = ActionT $ \_ _ s c -> c () (s {actionVault = f $ actionVault s})++-- | insert extensional state. since v1.2.0.+insertVault :: V.Key a -> a -> ActionT exts prms m ()+insertVault k i = modifyVault $ V.insert k i++-- | adjust extensional state. since v1.2.0.+adjustVault :: (a -> a) -> V.Key a -> ActionT exts prms m ()+adjustVault f k = modifyVault $ V.adjust f k++-- | delete extensional state. since v1.2.0.+deleteVault :: V.Key a -> ActionT exts prms m ()+deleteVault k = modifyVault $ V.delete k+ --------------------------------------------------------------------------------  -- | stop handler and send current state. since 0.3.3.0.@@ -480,7 +441,7 @@ stop = ActionT $ \_ _ s _ -> return $ Stop (toResponse s)  -- | stop with response. since 0.4.2.0.-stopWith :: Monad m => Response -> ActionT exts prms m a+stopWith :: Monad m => Wai.Response -> ActionT exts prms m a stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a  -- | redirect handler@@ -489,7 +450,7 @@ -- -- rename from redirect in 0.6.2.0. redirectWith :: Monad m-             => Status+             => HTTP.Status              -> S.ByteString -- ^ Location redirect to              -> ActionT exts prms m () redirectWith st url = do@@ -507,7 +468,7 @@  -- | redirect with 301 Moved Permanently. since 0.3.3.0. redirectPermanently :: Monad m => S.ByteString -> ActionT exts prms m ()-redirectPermanently = redirectWith movedPermanently301+redirectPermanently = redirectWith HTTP.movedPermanently301  -- | redirect with: --@@ -517,10 +478,10 @@ -- since 0.6.2.0. redirect :: Monad m => S.ByteString -> ActionT exts prms m () redirect to = do-    v <- httpVersion <$> getRequest-    if v == http11-        then redirectWith seeOther303 to-        else redirectWith status302   to+    v <- Wai.httpVersion <$> getRequest+    if v == HTTP.http11+        then redirectWith HTTP.seeOther303 to+        else redirectWith HTTP.status302   to  -- | redirect with: --@@ -530,10 +491,10 @@ -- since 0.3.3.0. redirectTemporary :: Monad m => S.ByteString -> ActionT exts prms m () redirectTemporary to = do-    v <- httpVersion <$> getRequest-    if v == http11-        then redirectWith temporaryRedirect307 to-        else redirectWith status302            to+    v <- Wai.httpVersion <$> getRequest+    if v == HTTP.http11+        then redirectWith HTTP.temporaryRedirect307 to+        else redirectWith HTTP.status302            to  -- | set raw response constructor. since 0.10. --@@ -544,7 +505,7 @@ -- producer = response (\s h -> responseProducer s h) -- @ ---rawResponse :: Monad m => (Status -> ResponseHeaders -> Response) -> ActionT exts prms m ()+rawResponse :: Monad m => (HTTP.Status -> HTTP.ResponseHeaders -> Wai.Response) -> ActionT exts prms m () rawResponse f = modifyState (\s -> s { actionResponse = ResponseFunc f } )  -- | reset response body to no response. since v0.15.2.@@ -552,74 +513,104 @@ reset = modifyState (\s -> s { actionResponse = mempty } )  -- | set response body file content, without set Content-Type. since 0.1.0.0.-file' :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m ()+file' :: MonadIO m => FilePath -> Maybe Wai.FilePart -> ActionT exts prms m () file' f p = modifyState (\s -> s { actionResponse = ResponseFile f p } )  -- | set response body file content and detect Content-Type by extension. since 0.1.0.0. -- -- file modification check since 0.17.2.-file :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m ()+file :: MonadIO m => FilePath -> Maybe Wai.FilePart -> ActionT exts prms m () file f p = do     mbims <- (>>= parseHTTPDate) . lookup "If-Modified-Since" <$> getHeaders-    e <- liftIO $ fileExist f+    e <- liftIO $ Files.fileExist f     t <- if e-         then liftIO $ Just . epochTimeToHTTPDate . modificationTime <$> getFileStatus f+         then liftIO $ Just . epochTimeToHTTPDate . Files.modificationTime <$> Files.getFileStatus f          else return Nothing     case mbims of-        Just ims | maybe False (ims >=) t -> reset >> status status304 >> stop+        Just ims | maybe False (ims >=) t -> reset >> status HTTP.status304 >> stop         _ -> do             mime <- mimeType <$> getConfig             contentType (mime f)             maybe (return ()) (addHeader "Last-Modified" . formatHTTPDate) t             file' f p -{-# WARNING devFile' "use file' in production." #-} devFile' :: MonadIO m => FilePath -> ActionT exts prms m ()-devFile' f = liftIO (fileExist f) >>= \e ->+devFile' f = liftIO (Files.fileExist f) >>= \e ->     if e     then liftIO (L.readFile f) >>= lazyBytes     else mzero  -- | send file contents as lazy bytestring response. since v1.1.4.-{-# WARNING devFile "use file in production." #-} devFile :: MonadIO m => FilePath -> ActionT exts prms m () devFile f = do     mime <- mimeType <$> getConfig     contentType (mime f)     devFile' f --- | append response body from builder. since 0.1.0.0.+-- | set response body from builder. since 0.1.0.0. builder :: Monad m => Builder -> ActionT exts prms m ()-builder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )+builder b = modifyState (\s -> s { actionResponse = ResponseBuilder b } ) --- | append response body from strict bytestring. since 0.15.2.+-- | set response body from strict bytestring. since 0.15.2. bytes :: Monad m => S.ByteString -> ActionT exts prms m () bytes = builder . B.fromByteString --- | append response body from lazy bytestring. since 0.15.2.+-- | set response body from lazy bytestring. since 0.15.2. lazyBytes :: Monad m => L.ByteString -> ActionT exts prms m () lazyBytes = builder . B.fromLazyByteString --- | append response body from strict text. encoding UTF-8. since 0.15.2.+-- | set response body from strict text. encoding UTF-8. since 0.15.2. text :: Monad m => T.Text -> ActionT exts prms m () text = builder . B.fromText --- | append response body from lazy text. encoding UTF-8. since 0.15.2.+-- | set response body from lazy text. encoding UTF-8. since 0.15.2. lazyText :: Monad m => TL.Text -> ActionT exts prms m () lazyText = builder . B.fromLazyText --- | append response body from show. encoding UTF-8. since 0.15.2.+-- | set response body from show. encoding UTF-8. since 0.15.2. showing :: (Monad m, Show a) => a -> ActionT exts prms m () showing = builder . B.fromShow --- | append response body from string. encoding UTF-8. since 0.15.2.+-- | set response body from string. encoding UTF-8. since 0.15.2. string :: Monad m => String -> ActionT exts prms m () string = builder . B.fromString --- | append response body from char. encoding UTF-8. since 0.15.2.+-- | set response body from char. encoding UTF-8. since 0.15.2. char :: Monad m => Char -> ActionT exts prms m () char = builder . B.fromChar +-- | append response body from builder. since 1.2.0.+appendBuilder :: Monad m => Builder -> ActionT exts prms m ()+appendBuilder b = modifyState (\s -> s { actionResponse = actionResponse s <> ResponseBuilder b } )++-- | append response body from strict bytestring. since 1.2.0.+appendBytes :: Monad m => S.ByteString -> ActionT exts prms m ()+appendBytes = appendBuilder . B.fromByteString++-- | append response body from lazy bytestring. since 1.2.0.+appendLazyBytes :: Monad m => L.ByteString -> ActionT exts prms m ()+appendLazyBytes = appendBuilder . B.fromLazyByteString++-- | append response body from strict text. encoding UTF-8. since 1.2.0.+appendText :: Monad m => T.Text -> ActionT exts prms m ()+appendText = appendBuilder . B.fromText++-- | append response body from lazy text. encoding UTF-8. since 1.2.0.+appendLazyText :: Monad m => TL.Text -> ActionT exts prms m ()+appendLazyText = appendBuilder . B.fromLazyText++-- | append response body from show. encoding UTF-8. since 1.2.0.+appendShowing :: (Monad m, Show a) => a -> ActionT exts prms m ()+appendShowing = appendBuilder . B.fromShow++-- | append response body from string. encoding UTF-8. since 1.2.0.+appendString :: Monad m => String -> ActionT exts prms m ()+appendString = appendBuilder . B.fromString++-- | append response body from char. encoding UTF-8. since 1.2.0.+appendChar :: Monad m => Char -> ActionT exts prms m ()+appendChar = appendBuilder . B.fromChar+ -- | set response body source. since 0.9.0.0.-stream :: Monad m => StreamingBody -> ActionT exts prms m ()+stream :: Monad m => Wai.StreamingBody -> ActionT exts prms m () stream str = modifyState (\s -> s { actionResponse = ResponseStream str })

@@ -1,16 +1,10 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}  module Control.Monad.Apiary.Filter (     -- * http method@@ -48,30 +42,38 @@     , Doc(..)     ) where -import Network.Wai as Wai+import qualified Network.Wai as Wai import Network.Wai.Parse (parseContentType, parseHttpAccept)-import qualified Network.HTTP.Types as Http+import qualified Network.HTTP.Types as HTTP -import Control.Applicative-import Control.Monad-import Control.Monad.Trans+import Control.Applicative((<$>))+import Control.Monad(mzero)+import Control.Monad.Trans(MonadIO)  import Control.Monad.Apiary.Action.Internal+    (getParams, getQueryParams, getRequestBody, getRequest, ContentType, contentType) import Control.Monad.Apiary.Filter.Internal-import Control.Monad.Apiary.Filter.Internal.Capture.TH-import Control.Monad.Apiary.Internal+    ( function, function', function_+    , 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+import Text.Blaze.Html(Html, toHtml) import qualified Data.ByteString.Char8 as SC-import qualified Data.Text          as T-import qualified Data.CaseInsensitive as CI-import Data.Monoid-import Data.Apiary.Compat-import Data.Apiary.Dict+import qualified Data.Text             as T+import qualified Data.CaseInsensitive  as CI+import Data.Monoid((<>))+import Data.Apiary.Compat(KnownSymbol, Symbol, symbolVal, Proxy(..), SProxy(..))+import Data.Apiary.Dict(NotMember, Elem((:=)))+import qualified Data.Apiary.Dict as Dict  import Data.Apiary.Param-import Data.Apiary.Method+    ( ReqParam, StrategyRep(..), QueryRep(NoValue)+    , Strategy(..), reqParamRep, reqParams+    , pFirst, pOne, pOption, pOptional, pMany, pSome+    )+import Data.Apiary.Method(Method)  -- | filter by HTTP method. since 0.1.0.0. --@@ -84,23 +86,23 @@  -- | filter by ssl accessed. since 0.1.0.0. ssl :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-ssl = function_ (DocPrecondition "SSL required") isSecure+ssl = function_ (DocPrecondition "SSL required") Wai.isSecure  -- | http version filter. since 0.5.0.0.-httpVersion :: Monad actM => Http.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()+httpVersion :: Monad actM => HTTP.HttpVersion -> Html -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () httpVersion v h = function_ (DocPrecondition h) $ (v ==) . Wai.httpVersion  -- | http/0.9 only accepted fiter. since 0.5.0.0. http09 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http09 = Control.Monad.Apiary.Filter.httpVersion Http.http09 "HTTP/0.9 only"+http09 = Control.Monad.Apiary.Filter.httpVersion HTTP.http09 "HTTP/0.9 only"  -- | http/1.0 only accepted fiter. since 0.5.0.0. http10 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http10 = Control.Monad.Apiary.Filter.httpVersion Http.http10 "HTTP/1.0 only"+http10 = Control.Monad.Apiary.Filter.httpVersion HTTP.http10 "HTTP/1.0 only"  -- | http/1.1 only accepted fiter. since 0.5.0.0. http11 :: Monad actM => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()-http11 = Control.Monad.Apiary.Filter.httpVersion Http.http11 "HTTP/1.1 only"+http11 = Control.Monad.Apiary.Filter.httpVersion HTTP.http11 "HTTP/1.1 only"  -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'. root :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()@@ -209,7 +211,7 @@     qs      <- getQueryParams     (ps,fs) <- getRequestBody     let n = maybe False id . fmap (maybe True id) . lookup (SC.pack $ symbolVal k) $ reqParams (Proxy :: Proxy Bool) qs ps fs-    insert k n <$> getParams+    Dict.insert k n <$> getParams  -------------------------------------------------------------------------------- @@ -217,21 +219,21 @@ header :: (KnownSymbol k, Monad actM, NotMember k prms)        => proxy k -> ApiaryT exts (k := SC.ByteString ': prms) actM m () -> ApiaryT exts prms actM m () header k = focus' (DocPrecondition $ "has header: " <> toHtml (symbolVal k)) Nothing id $ do-    n <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . requestHeaders =<< getRequest-    insert k n <$> getParams+    n <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . Wai.requestHeaders =<< getRequest+    Dict.insert k n <$> getParams  -- | check whether to exists specified valued header or not. since 0.6.0.0. eqHeader :: (KnownSymbol k, Monad actM)          => proxy k -> SC.ByteString -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () eqHeader k v = focus' (DocPrecondition $ "header: " <> toHtml (symbolVal k) <> " = " <> toHtml (show v)) Nothing id $ do-    v' <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . requestHeaders =<< getRequest+    v' <- maybe mzero return . lookup (CI.mk . SC.pack $ symbolVal k) . Wai.requestHeaders =<< getRequest     if v == v' then getParams else mzero   -- | require Accept header and set response Content-Type. since 0.16.0. accept :: Monad actM => ContentType -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () accept ect = focus (DocAccept ect) $-    (lookup "Accept" . requestHeaders <$> getRequest) >>= \case+    (lookup "Accept" . Wai.requestHeaders <$> getRequest) >>= \case         Nothing -> mzero         Just ac ->              let ex@(et, _) = parseContentType ect

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}@@ -7,29 +9,31 @@     , Doc(..)     ) where -import Network.Wai+import qualified Network.Wai as Wai -import Control.Monad-import Control.Monad.Apiary.Internal-import Control.Monad.Apiary.Action+import Control.Monad(mzero)+import Control.Monad.Apiary.Internal(ApiaryT, focus)+import Control.Monad.Apiary.Action(getParams, getRequest) -import Data.Apiary.Dict-import Data.Apiary.Document.Internal+import Data.Apiary.Compat(KnownSymbol)+import Data.Apiary.Dict(Dict, NotMember, Elem((:=)))+import qualified Data.Apiary.Dict as Dict+import Data.Apiary.Document.Internal(Doc(..))  -- | low level filter function. function :: Monad actM => (Doc -> Doc)-         -> (Dict prms -> Request -> Maybe (Dict prms'))+         -> (Dict prms -> Wai.Request -> Maybe (Dict prms'))          -> ApiaryT exts prms' actM m () -> ApiaryT exts prms actM m () function d f = focus d $ getParams >>= \p -> getRequest >>= \r -> case f p r of     Nothing -> mzero     Just c' -> return c'  -- | filter and append argument.-function' :: (Monad actM, NotMember key prms) => (Doc -> Doc) -> (Request -> Maybe (proxy key, prm))+function' :: (KnownSymbol key, Monad actM, NotMember key prms) => (Doc -> Doc) -> (Wai.Request -> Maybe (proxy key, prm))           -> ApiaryT exts (key := prm ': prms) actM m () -> ApiaryT exts prms actM m ()-function' d f = function d $ \c r -> f r >>= \(k, p) -> return $ insert k p c+function' d f = function d $ \c r -> f r >>= \(k, p) -> return $ Dict.insert k p c  -- | filter only(not modify arguments).-function_ :: Monad actM => (Doc -> Doc) -> (Request -> Bool) +function_ :: Monad actM => (Doc -> Doc) -> (Wai.Request -> Bool)            -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () function_ d f = function d $ \c r -> if f r then Just c else Nothing

@@ -1,31 +1,29 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}  module Control.Monad.Apiary.Filter.Internal.Capture where -import Control.Applicative-import Control.Monad+import Control.Applicative((<$>), (<$))+import Control.Monad(liftM, mzero) import Control.Monad.Apiary.Action.Internal+    (getParams, actionFetches, getState, modifyState) import Control.Monad.Apiary.Internal+    (ApiaryT, focus', PathElem(Exact, FetchPath, RestPath, EndPath)) import Control.Monad.Apiary.Filter.Internal+    (Doc(DocPath, DocFetch, DocAny, DocRest)) -import Data.Apiary.Compat-import Data.Apiary.Param-import Data.Apiary.Dict+import Data.Apiary.Compat(KnownSymbol, symbolVal, Proxy(..))+import Data.Apiary.Param(Path, pathRep, readPathAs)+import Data.Apiary.Dict(Elem((:=)))+import qualified Data.Apiary.Dict as Dict  import qualified Data.Text as T-import Text.Blaze.Html+import Text.Blaze.Html(Html)  -- | check first path and drill down. since 0.11.0. path :: Monad actM => T.Text -> ApiaryT exts prms actM m () -> ApiaryT exts prms actM m ()@@ -36,18 +34,18 @@ endPath = focus' id Nothing (EndPath:) getParams  -- | get first path and drill down. since 0.11.0.-fetch' :: (NotMember k prms, KnownSymbol k, Path p, Monad actM) => proxy k -> proxy' p -> Maybe Html+fetch' :: (Dict.NotMember k prms, KnownSymbol k, Path p, Monad actM) => proxy k -> proxy' p -> Maybe Html        -> ApiaryT exts (k := p ': prms) actM m () -> ApiaryT exts prms actM m () fetch' k p h = focus' (DocFetch (T.pack $ symbolVal k) (pathRep p) h) Nothing (FetchPath:) $ liftM actionFetches getState >>= \case     []   -> mzero     f:fs -> case readPathAs p f of         Just r  -> do             modifyState (\s -> s {actionFetches = fs})-            insert k r <$> getParams+            Dict.insert k r <$> getParams         Nothing -> mzero  -fetch :: forall proxy k p exts prms actM m. (NotMember k prms, KnownSymbol k, Path p, Monad actM)+fetch :: forall proxy k p exts prms actM m. (Dict.NotMember k prms, KnownSymbol k, Path p, Monad actM)       => proxy (k := p) -> Maybe Html       -> ApiaryT exts (k := p ': prms) actM m () -> ApiaryT exts prms actM m () fetch _ h = fetch' k p h@@ -58,8 +56,8 @@ anyPath :: (Monad m, Monad actM) => ApiaryT exts prms actM m () -> ApiaryT exts prms actM m () anyPath = focus' DocAny Nothing (RestPath:) getParams -restPath :: (NotMember k prms, KnownSymbol k, Monad m, Monad actM)+restPath :: (Dict.NotMember k prms, KnownSymbol k, Monad m, Monad actM)          => proxy k -> Maybe Html -> ApiaryT exts (k := [T.Text] ': prms) actM m () -> ApiaryT exts prms actM m () restPath k h = focus' (DocRest (T.pack $ symbolVal k) h) Nothing (RestPath:) $ getParams >>= \l -> liftM actionFetches getState >>= \case-    [] -> return $ insert k [] l-    fs -> insert k fs l <$ modifyState (\s -> s {actionFetches = []})+    [] -> return $ Dict.insert k [] l+    fs -> Dict.insert k fs l <$ modifyState (\s -> s {actionFetches = []})

@@ -1,22 +1,22 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} -module Control.Monad.Apiary.Filter.Internal.Capture.TH where+module Control.Monad.Apiary.Filter.Internal.Capture.TH(capture) where -import Control.Arrow-import Control.Applicative+import Control.Arrow(first)+import Control.Applicative((<$>)) -import Language.Haskell.TH-import Language.Haskell.TH.Quote+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote(QuasiQuoter(..))  import qualified Control.Monad.Apiary.Filter.Internal.Capture as Capture  import qualified Data.Text as T-import Data.String-import Data.List-import Data.Apiary.Compat+import Data.String(IsString(..))+import Data.List(isInfixOf)+import Data.Apiary.Compat(Proxy(..), SProxy(..))  preCap :: String -> [String] preCap ""  = []@@ -27,39 +27,37 @@ splitPath :: String -> [String] splitPath = map T.unpack . T.splitOn "/" . T.pack ---            S h  -> [|Just $(stringE h)|]---            N n  -> [|Just $(varE n)|]-description :: String -> Q (String, ExpQ)+description :: String -> TH.Q (String, TH.ExpQ) description s = case break (`elem` "([") s of     (t, []) -> return (t, [|Nothing|])     (t, st) -> case break (`elem` ")]") st of         (_:'$':b, ")") -> do-            reportWarning "DEPRECATED () description. use []."-            v <- lookupValueName b-            maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(varE n)|])) v+            TH.reportWarning "DEPRECATED () description. use []."+            v <- TH.lookupValueName b+            maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(TH.varE n)|])) v         (_:b,     ")") -> do-            reportWarning "DEPRECATED () description. use []."-            return (t, [|Just $(stringE b)|])-        (_:'$':b, "]") -> lookupValueName b >>=-            maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(varE n)|]))-        (_:b,     "]") -> return (t, [|Just $(stringE b)|])+            TH.reportWarning "DEPRECATED () description. use []."+            return (t, [|Just $(TH.stringE b)|])+        (_:'$':b, "]") -> TH.lookupValueName b >>=+            maybe (fail $ b ++ " not found.") (\n -> return (t, [|Just $(TH.varE n)|]))+        (_:b,     "]") -> return (t, [|Just $(TH.stringE b)|])         (_, _)         -> fail "capture: syntax error."  -mkCap :: [String] -> ExpQ+mkCap :: [String] -> TH.ExpQ mkCap [] = [|Capture.endPath|] mkCap (('*':'*':[]):as) = [|Capture.anyPath . $(mkCap as) |] mkCap (('*':'*':tS):as) = do     (k, d) <- description tS-    [|Capture.restPath (SProxy :: SProxy $(litT $ strTyLit k)) $d . $(mkCap as) |]+    [|Capture.restPath (SProxy :: SProxy $(TH.litT $ TH.strTyLit k)) $d . $(mkCap as) |] mkCap (str:as)     | "::" `isInfixOf` fst (break (`elem` "([") str) = do         (key, d) <- first T.pack <$> description str         let v = T.unpack . T.strip . fst $ T.breakOn    "::" key             t = T.unpack . T.strip . snd $ T.breakOnEnd "::" key-        ty <- lookupTypeName t >>= maybe (fail $ t ++ " not found.") return-        [|(Capture.fetch' (SProxy :: SProxy $(litT $ strTyLit v)) (Proxy :: Proxy $(conT ty)) $d) . $(mkCap as)|]+        ty <- TH.lookupTypeName t >>= maybe (fail $ t ++ " not found.") return+        [|(Capture.fetch' (SProxy :: SProxy $(TH.litT $ TH.strTyLit v)) (Proxy :: Proxy $(TH.conT ty)) $d) . $(mkCap as)|] -    | otherwise = [|(Capture.path (fromString $(stringE str))) . $(mkCap as) |]+    | otherwise = [|(Capture.path (fromString $(TH.stringE str))) . $(mkCap as) |]  -- | capture QuasiQuoter. since 0.1.0.0. --

@@ -1,40 +1,39 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ImpredicativeTypes #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE OverloadedStrings #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}  module Control.Monad.Apiary.Internal where -import Network.Wai+import qualified Network.Wai as Wai -import Control.Applicative-import Control.Monad-import Control.Monad.Trans+import Control.Applicative(Applicative(..), (<$>))+import Control.Monad(liftM, MonadPlus(..))+import Control.Monad.Trans(MonadIO(liftIO), MonadTrans(lift)) import Control.Monad.Trans.Control-import Control.Monad.Base+    ( MonadTransControl(..), MonadBaseControl(..)+    , ComposeSt, defaultLiftBaseWith, defaultRestoreM+    )+import Control.Monad.Base(MonadBase(..)) import Control.Monad.Apiary.Action.Internal+    (ActionT, ApiaryConfig, getRequest+    , modifyState, actionFetches, Extensions(NoExtension)+    , execActionT, hoistActionT, applyDict, rootPattern+    ) -import Data.List import qualified Data.Apiary.Dict as D-import Data.Apiary.Extension-import Data.Apiary.Extension.Internal-import Data.Apiary.Document.Internal-import Data.Monoid hiding (All)-import Text.Blaze.Html+import Data.Apiary.Method(Method, renderMethod)+import Data.Apiary.Extension ( Has, MonadExts(..), getExt, noExtension )+import Data.Apiary.Extension.Internal(Initializer(..), allMiddleware, allMiddleware')+import Data.Apiary.Document.Internal(Doc(..), docsToDocuments)+import Data.Monoid(Monoid(..), (<>))++import Data.List(foldl')+import Text.Blaze.Html(Html) import qualified Data.Text as T import qualified Data.ByteString as S-import Data.Apiary.Method import qualified Data.HashMap.Strict as H  data Router exts actM = Router@@ -44,6 +43,8 @@     , pathMethod :: PathMethod exts actM     } +type ActionT' exts actM a = ActionT exts '[] actM a+ data PathMethod exts actM = PathMethod     { methodMap :: H.HashMap S.ByteString (ActionT' exts actM ())     , anyMethod :: Maybe (ActionT' exts actM ())@@ -100,7 +101,7 @@ data ApiaryWriter exts actM = ApiaryWriter     { writerRouter :: Router exts actM -> Router exts actM     , writerDoc    :: [Doc] -> [Doc]-    , writerMw     :: Middleware+    , writerMw     :: Wai.Middleware     }  instance Monoid (ApiaryWriter exts actM) where@@ -121,18 +122,18 @@ 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+routerToAction router = getRequest >>= go   where-    go req = loop id router (pathInfo req)+    go req = loop id router (Wai.pathInfo req)       where-        method = requestMethod req+        method = Wai.requestMethod req          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 [] } )+            modifyState (\s -> s { actionFetches = fch [] } )             pmAction (maybe mzero (pmAction mzero) anp) pm           loop fch (Router c mbcp anp _) (p:ps) = case mbcp of@@ -140,7 +141,7 @@             Just cp -> cld $ loop (fch . (p:)) cp ps `mplus` ana           where             ana = do-                modifyState' (\s -> s {actionFetches = fch $ p:ps} ) +                modifyState (\s -> s {actionFetches = fch $ p:ps} )                  maybe mzero (pmAction mzero) anp             cld nxt = case H.lookup p c of                 Nothing -> nxt@@ -149,7 +150,7 @@ -- | run Apiary monad. runApiaryTWith :: (Monad actM, Monad m)                => (forall b. actM b -> IO b)-               -> (Application -> m a)+               -> (Wai.Application -> m a)                -> Initializer m '[] exts                -> ApiaryConfig                -> ApiaryT exts '[] actM m ()@@ -159,11 +160,12 @@     let doc = docsToDocuments $ writerDoc wtr []         rtr = writerRouter wtr emptyRouter         mw  = allMiddleware exts . writerMw wtr-        app = mw $ execActionT' conf exts doc (hoistActionT' runAct $ routerToAction rtr)+        mw' = allMiddleware' exts+        app = mw $ execActionT conf exts doc (mw' $ hoistActionT runAct $ routerToAction rtr)     run $! app  runApiaryWith :: Monad m-              => (Application -> m a)+              => (Wai.Application -> m a)               -> Initializer m '[] exts               -> ApiaryConfig               -> ApiaryT exts '[] IO m ()@@ -171,7 +173,7 @@ runApiaryWith = runApiaryTWith id  runApiary :: Monad m-          => (Application -> m a)+          => (Wai.Application -> m a)           -> ApiaryConfig           -> ApiaryT '[] '[] IO m ()           -> m a@@ -220,9 +222,9 @@     liftBaseWith = defaultLiftBaseWith StMApiary'     restoreM     = defaultRestoreM   unStMApiary' -instance (Has e exts, Monad actM) => MonadHas e (ApiaryT exts prms actM m) where-    getExt p = getExtension p . envExts <$> getApiaryEnv-    {-# INLINE getExt #-}+instance Monad actM => MonadExts exts (ApiaryT exts prms actM m) where+    getExts = envExts <$> getApiaryEnv+    {-# INLINE getExts #-}  -------------------------------------------------------------------------------- @@ -275,7 +277,7 @@         id  -- | add middleware.-middleware :: Monad actM => Middleware -> ApiaryT exts prms actM m ()+middleware :: Monad actM => Wai.Middleware -> ApiaryT exts prms actM m () middleware mw = addRoute (ApiaryWriter id id mw)  --------------------------------------------------------------------------------

@@ -1,11 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE CPP #-}  -- | compatibility module for ghc-7.8 & ghc-7.6. module Data.Apiary.Compat@@ -33,9 +33,10 @@  symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String symbolVal _ = fromSing (sing :: Sing n)+{-# INLINE symbolVal #-} -data Proxy a = Proxy+data Proxy (a :: k) = Proxy #endif --- | Symbol Proxy for ghc-7.6.+-- | Symbol Proxy for ghc-7.6 Template Haskell. data SProxy (a :: Symbol) = SProxy

@@ -1,18 +1,14 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}  -- | type sefe dictionaly. module Data.Apiary.Dict@@ -29,33 +25,35 @@     , Members     ) where -import Data.Apiary.Compat+import Data.Apiary.Compat(KnownSymbol, Symbol, symbolVal, SProxy(..)) -import Language.Haskell.TH-import Language.Haskell.TH.Quote-import GHC.Exts+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote(QuasiQuoter(..)) +import qualified Data.HashMap.Strict as H+import qualified Data.Text as T++import GHC.Exts(Any, Constraint)+import Unsafe.Coerce+ -- | (kind) Dict element. data Elem = forall a. Symbol := a -data Dict (ks :: [Elem]) where-    Empty :: Dict '[]-    Insert :: proxy (k :: Symbol) -> v -> Dict ks -> Dict (k := v ': ks)-+newtype Dict (ks :: [Elem]) = Dict (H.HashMap T.Text Any)  class Member (k :: Symbol) (v :: *) (kvs :: [Elem]) | k kvs -> v where      -- | get value of key.     ---    -- > ghci> get (SProxy :: SProxy "bar") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+    -- > ghci> get (Proxy :: Proxy "bar") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty     -- > 0.5     ---    -- > ghci> get (SProxy :: SProxy "foo") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+    -- > ghci> get (Proxy :: Proxy "foo") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty     -- > 12     --     -- ghc raise compile error when key is not exists.     ---    -- > ghci> get (SProxy :: SProxy "baz") $ insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+    -- > ghci> get (Proxy :: Proxy "baz") $ insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty     -- > <interactive>:15:1:     -- >     No instance for (Member "baz" a0 '[]) arising from a use of ‘it’     -- >     In the first argument of ‘print’, namely ‘it’@@ -63,12 +61,15 @@      get :: proxy k -> Dict kvs -> v -instance Member k v (k := v ': kvs) where-    get _ (Insert _ v _) = v+getImpl :: KnownSymbol k => proxy k -> Dict any -> b+getImpl p (Dict d) = maybe (error "Dict: no value.") unsafeCoerce $ H.lookup (T.pack $ symbolVal p) d -instance Member k v kvs => Member k v (k' := v' ': kvs) where-    get p (Insert _ _ d) = get p d+instance KnownSymbol k => Member k v (k := v ': kvs) where+    get = getImpl +instance (KnownSymbol k, Member k v kvs) => Member k v (k' := v' ': kvs) where+    get = getImpl+ -- | type family version Member for NotMember constraint. #if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 708 type family Member' (k::Symbol) (kvs :: [Elem]) :: Bool where@@ -92,42 +93,42 @@  -- | empty Dict. empty :: Dict '[]-empty = Empty+empty = Dict H.empty  -- | insert element. -- --- > ghci> :t insert (SProxy :: SProxy "foo") (12 :: Int) empty--- > insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > ghci> :t insert (Proxy :: Proxy "foo") (12 :: Int) empty+-- > insert (Proxy :: Proxy "foo") (12 :: Int) empty -- >   :: Dict '["foo" ':= Int] -- --- > ghci> :t insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty--- > insert (SProxy :: SProxy "bar") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > ghci> :t insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty+-- > insert (Proxy :: Proxy "bar") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty -- >   :: Dict '["bar" ':= Double, "foo" ':= Int] -- -- ghc raise compile error when insert duplicated key(> ghc-7.8 only). ----- > ghci> :t insert (SProxy :: SProxy "foo") (0.5 :: Double) $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- > ghci> :t insert (Proxy :: Proxy "foo") (0.5 :: Double) $ insert (Proxy :: Proxy "foo") (12 :: Int) empty -- >  -- > <interactive>:1:1: -- >     Couldn't match type ‘'True’ with ‘'False’ -- >     Expected type: 'False -- >       Actual type: Member' "foo" '["foo" ':= Int]--- >     In the expression: insert (SProxy :: SProxy "foo") (0.5 :: Double)+-- >     In the expression: insert (Proxy :: Proxy "foo") (0.5 :: Double) -- >     In the expression:--- >       insert (SProxy :: SProxy "foo") (0.5 :: Double)--- >       $ insert (SProxy :: SProxy "foo") (12 :: Int) empty+-- >       insert (Proxy :: Proxy "foo") (0.5 :: Double)+-- >       $ insert (Proxy :: Proxy "foo") (12 :: Int) empty -insert :: NotMember k kvs => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)-insert = Insert+insert :: (KnownSymbol k, NotMember k kvs) => proxy k -> v -> Dict kvs -> Dict (k := v ': kvs)+insert p v (Dict d) = Dict (H.insert (T.pack $ symbolVal p) (unsafeCoerce v) d)  -- | construct string literal proxy. ----- prop> [key|foo|] == (SProxy :: SProxy "foo")+-- prop> [key|foo|] == (Proxy :: Proxy "foo") -- key :: QuasiQuoter key = QuasiQuoter-    { quoteExp  = \s -> [| SProxy :: SProxy $(litT $ strTyLit s) |]+    { quoteExp  = \s -> [| SProxy :: SProxy $(TH.litT $ TH.strTyLit s) |]     , quotePat  = error "key qq only exp or type."-    , quoteType = \s -> [t| SProxy $(litT $ strTyLit s) |]+    , quoteType = \s -> [t| SProxy $(TH.litT $ TH.strTyLit s) |]     , quoteDec  = error "key qq only exp or type."     }

@@ -1,6 +1,6 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}  module Data.Apiary.Document.Html     ( defaultDocumentToHtml@@ -10,17 +10,20 @@     , rpHtml     ) where -import Language.Haskell.TH-import Language.Haskell.TH.Syntax(addDependentFile)+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH (addDependentFile) -import Data.Monoid hiding (Any)-import Data.Default.Class+import Data.Monoid(Monoid(..), (<>))+import Data.Default.Class(Default(..)) -import Data.Apiary.Param-import Data.Apiary.Method+import Data.Apiary.Param(QueryRep(Strict, Nullable, Check, NoValue), strategyInfo)+import Data.Apiary.Method(renderMethod) import Data.Apiary.Document+    ( Route(Path, Fetch, Rest, Any, End), Documents(..)+    , QueryDoc(..), MethodDoc(..), PathDoc(..)+    ) -import Text.Blaze.Html+import Text.Blaze.Html(Html, toHtml, (!), preEscapedToHtml, toValue) import Text.Blaze.Internal(attribute) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -78,8 +81,30 @@     def = DefaultDocumentConfig "API documentation" Nothing True Nothing  defaultDocumentToHtml :: DefaultDocumentConfig -> Documents -> Html-defaultDocumentToHtml DefaultDocumentConfig{..} docs =-    H.docTypeHtml $ H.head headH <> H.body body <> footer+defaultDocumentToHtml DefaultDocumentConfig{..} docs = H.docTypeHtml $ do+    H.head $ do+        H.title (toHtml documentTitle)+        if documentUseCDN then cdns else embeds+        $(TH.runIO (readFile "static/jquery.cookie-1.4.1.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|])+        -- , H.script "" ! A.src "/static/api-documentation.js"+        -- , H.link ! A.rel "stylesheet" ! A.href "/static/api-documentation.css"+        $(TH.addDependentFile "static/api-documentation.min.js"  >> TH.runIO (readFile "static/api-documentation.min.js")   >>= \c -> [|H.script $ preEscapedToHtml (c::String)|])+        $(TH.addDependentFile "static/api-documentation.min.css" >> TH.runIO (readFile "static/api-documentation.min.css")  >>= \c -> [|H.style  $ preEscapedToHtml (c::String)|])+        maybe mempty analytics documentGoogleAnalytics++    H.body $ do+        H.div ! A.class_ "container" $ do+            H.div ! A.class_ "page-header" $ H.h1 (toHtml documentTitle)+            maybe mempty (H.div ! A.class_ "description") documentDescription+            H.div ! A.id "no-group" $ do+                mcMap (pathH "") (noGroup docs)+                mcMap groupH     (groups docs)++    H.footer $ do+        ("This API documentation generated by " :: Html)+        H.a ! A.href "https://github.com/philopon/apiary" $ "apiary"+        (" web framework." :: Html)+   where     css u = H.link ! A.rel "stylesheet" ! A.href u     js  u = H.script ! A.src u $ mempty@@ -88,14 +113,13 @@      mcMap f = mconcat . map f -    cdns = mconcat-        [ css "http://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css"-        , js  "http://code.jquery.com/jquery-2.1.1.min.js"-        , js  "http://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js"-        ]+    cdns = do+        css "http://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/css/bootstrap.min.css"+        js  "http://code.jquery.com/jquery-2.1.1.min.js"+        js  "http://maxcdn.bootstrapcdn.com/bootstrap/3.2.0/js/bootstrap.min.js"      embeds = $( do-        let embed f p = runIO (readFile p) >>= \c -> [|$(varE f) $ preEscapedToHtml (c :: String)|]+        let embed f p = TH.runIO (readFile p) >>= \c -> [|$(TH.varE f) $ preEscapedToHtml (c :: String)|]         [| mconcat              [ $(embed 'H.style  "static/bootstrap.min.css")             , $(embed 'H.script "static/jquery-2.1.1.min.js")@@ -103,91 +127,66 @@             ]          |]) -    headH = mconcat-        [ H.title (toHtml documentTitle)-        , if documentUseCDN then cdns else embeds-        , $(runIO (readFile "static/jquery.cookie-1.4.1.min.js") >>= \c -> [|H.script $ preEscapedToHtml (c::String)|])-        , $(addDependentFile "static/api-documentation.min.js"  >> runIO (readFile "static/api-documentation.min.js")   >>= \c -> [|H.script $ preEscapedToHtml (c::String)|])-        , $(addDependentFile "static/api-documentation.min.css" >> 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     = "-"--    query (QueryDoc p s q t) = H.tr . mconcat $-        [ H.td (toHtml p)-        , H.td (toHtml $ strategyInfo s)-        , H.td (htmlQR q)-        , H.td $ maybe noDescription id t-        ]+    groupH (g, p) = H.div ! A.id (toValue $ T.append "group-" g) $ do+        H.h2 $ toHtml g+        mcMap (pathH g) p -    queriesH [] = mempty-    queriesH qs =-        H.div $-        H.table ! A.class_ "query-parameters table table-condensed" $ mconcat-        [ H.caption "Query parameters"-        , H.tr $ mconcat [ H.th ! A.class_ "col-sm-1 col-md-1" $ "name"-                         , H.th ! A.class_ "col-sm-1 col-md-1" $ "num"-                         , H.th ! A.class_ "col-sm-1 col-md-1" $ "type"-                         , H.th "description"-                         ]-        , mcMap query qs-        ]+    pathH grp (PathDoc r ms) = do+        let (idnt, route, rdoc) = routeToHtml r+        H.div ! A.class_ "panel panel-default" $ do+            H.div ! A.class_ "panel-heading clearfix"+                  ! dataToggle "collapse"+                  ! dataTarget (toValue $ T.concat ["[id='collapse-", grp, "-", idnt, "']"]) $ do+                H.h3  ! A.class_ "panel-title pull-left" $ route+                H.div ! A.class_ "methods" $+                    mcMap ( (\m -> H.div ! A.class_ "pull-right" $ toHtml (T.decodeUtf8 m))+                          . renderMethod . fst) (reverse ms) -    preconds [] = mempty-    preconds p  =-        H.div ! A.class_ "well well-sm precondition" $ mconcat-            [ H.p "Preconditions:"-            , H.ul $ mcMap (\h -> H.li h) p-            ]+            H.div ! A.id (toValue $ T.concat ["collapse-", grp, "-", idnt])+                  ! A.class_ "panel-collapse collapse" $ do+                rdoc+                H.div ! A.class_ "panel-body" $ mcMap method ms -    method (m, ms) = H.div ! A.class_ "method" $ mconcat-        [ H.h4 . toHtml $ T.decodeUtf8 $ renderMethod m-        , mcMap action ms-        ]+    method (m, ms) = H.div ! A.class_ "method" $ do+        H.h4 . toHtml $ T.decodeUtf8 $ renderMethod m+        mcMap action ms -    action (MethodDoc qs pc a d) = H.div ! A.class_ "action col-sm-offset-1 col-md-offset-1" $ mconcat-        [ preconds $ maybe pc (\ac -> H.span ("Accept: " <> H.span (toHtml $ T.decodeUtf8 ac)) ! A.class_ "precondition-accept" : pc) a-        , H.div (H.p $ toHtml d)-        , queriesH qs-        ]+    action (MethodDoc qs pc a d) =+        H.div ! A.class_ "action col-sm-offset-1 col-md-offset-1" $ do+            preconds $+                maybe pc +                (\ac -> H.span ("Accept: " <> H.span (toHtml $ T.decodeUtf8 ac))+                                          ! A.class_ "precondition-accept" : pc) a+            H.div (H.p $ toHtml d)+            queriesH qs -    pathH grp (PathDoc r ms) =-        let (idnt, route, rdoc) = routeToHtml r-        in H.div ! A.class_ "panel panel-default" $ mconcat-            [ H.div ! A.class_ "panel-heading clearfix"-                ! dataToggle "collapse" ! dataTarget (toValue $ T.concat ["[id='collapse-", grp, "-", idnt, "']"]) $ mconcat-                [ H.h3 ! A.class_ "panel-title pull-left" $ route-                , H.div ! A.class_ "methods" $-                    mcMap ((\m -> H.div ! A.class_ "pull-right" $ toHtml (T.decodeUtf8 m)) . renderMethod . fst) (reverse ms)-                ]-            , H.div ! A.id (toValue $ T.concat ["collapse-", grp, "-", idnt]) ! A.class_ "panel-collapse collapse" $-                rdoc <> (H.div ! A.class_ "panel-body" $ mcMap method ms)-            ]+    preconds [] = mempty+    preconds p  = H.div ! A.class_ "well well-sm precondition" $ do+            H.p "Preconditions:"+            H.ul $ mcMap (\h -> H.li h) p -    groupH (g, p) =-        let gs = mcMap (pathH g) p-        in H.div ! A.id (toValue $ T.append "group-" g) $ mconcat [H.h2 $ toHtml g, gs]+    queriesH [] = mempty+    queriesH qs = H.div $ do+        H.table ! A.class_ "query-parameters table table-condensed" $ do+            H.caption "Query parameters"+            H.tr $ do+                H.th ! A.class_ "col-sm-1 col-md-1" $ "name"+                H.th ! A.class_ "col-sm-1 col-md-1" $ "num"+                H.th ! A.class_ "col-sm-1 col-md-1" $ "type"+                H.th "description"+            mcMap query qs -    doc (Documents n g) =-        let ng = mcMap (pathH "") n-            gs = mcMap groupH g-        in (H.div ! A.id "no-group") ng <> gs+    query (QueryDoc p s q t) = H.tr $ do+        H.td (toHtml p)+        H.td (toHtml $ strategyInfo s)+        H.td (htmlQR q)+        H.td $ maybe noDescription id t -    body  = H.div ! A.class_ "container" $ mconcat-        [ H.div ! A.class_ "page-header" $ H.h1 (toHtml documentTitle)-        , maybe mempty (H.div ! A.class_ "description") documentDescription-        , doc docs-        ]+    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     = "-" -    footer = H.footer $ mconcat-        [ "This API documentation generated by "-        , H.a ! A.href "https://github.com/philopon/apiary" $ "apiary"-        , " web framework."-        ]  -- | construct Html as route parameter. since 0.13.0. rpHtml :: Html -> Html

@@ -1,23 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE LambdaCase #-}  module Data.Apiary.Document.Internal where -import Control.Applicative+import Control.Applicative((<$>)) -import Data.Typeable-import Data.Maybe-import Data.List-import Data.Function+import Data.Typeable(TypeRep)+import Data.Maybe(mapMaybe)+import Data.List(groupBy)+import Data.Function(on) -import Data.Apiary.Param-import Data.Apiary.Method+import Data.Apiary.Param(StrategyRep, QueryRep)+import Data.Apiary.Method(Method) -import Text.Blaze.Html+import Text.Blaze.Html(Html) import qualified Data.Text as T import qualified Data.ByteString as S 

@@ -1,12 +1,11 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}  module Data.Apiary.Extension     ( Has(getExtension)-    , MonadHas(..)+    , MonadExts(..), getExt+    , Middleware'     , Extension(..)     , Extensions     , noExtension@@ -20,10 +19,13 @@     , (+>)     ) where -import Data.Apiary.Extension.Internal+import Control.Monad(liftM)+import Data.Apiary.Extension.Internal(Has, getExtension, Initializer(Initializer))+import Control.Monad.Apiary.Action.Internal+    (MonadExts(getExts), Extension(..), Extensions(AddExtension), Middleware') -class MonadHas e m where-    getExt :: proxy e -> m e+getExt :: (MonadExts es m, Has e es) => proxy e -> m e+getExt p = getExtension p `liftM` getExts  type Initializer' m a = forall i. Initializer m i (a ': i) 

@@ -1,21 +1,21 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-}  module Data.Apiary.Extension.Internal where -import Network.Wai+#if __GLASGOW_HASKELL__ >= 708 import qualified Control.Category as Cat--data Extensions (es :: [*]) where-    NoExtension  :: Extensions '[]-    AddExtension :: Extension e => (e :: *) -> Extensions es -> Extensions (e ': es)+#endif+import qualified Network.Wai as Wai+import Control.Monad.Apiary.Action.Internal+    ( Extensions(AddExtension, NoExtension)+    , Extension(extMiddleware, extMiddleware'), Middleware')  class Has a (as :: [*]) where     getExtension :: proxy a -> Extensions as -> a@@ -29,12 +29,12 @@ 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 -allMiddleware :: Extensions es -> Middleware-allMiddleware NoExtension         = id+allMiddleware :: Extensions es -> Wai.Middleware+allMiddleware NoExtension = id allMiddleware (AddExtension e es) = extMiddleware e . allMiddleware es  #if __GLASGOW_HASKELL__ >= 708

@@ -1,11 +1,11 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}  module Data.Apiary.Method where -import Data.String+import Data.Hashable(Hashable(..))+import Data.String(IsString(..)) import qualified Data.ByteString.Char8 as S-import Data.Hashable import qualified Data.ByteString.Unsafe as U  data Method

@@ -1,20 +1,12 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}  module Data.Apiary.Param     ( -- * route path parameter@@ -57,21 +49,25 @@     , pOptional     ) where -import Control.Monad-import Control.Arrow+import Control.Monad(when, unless, MonadPlus(mzero))+import Control.Arrow(second) -import qualified Network.HTTP.Types as Http+import qualified Network.HTTP.Types as HTTP -import Data.Int-import Data.Maybe-import Data.Word+import Data.Int(Int8, Int16, Int32, Int64)+import Data.Word(Word, Word8, Word16, Word32, Word64)+import Data.Maybe(isJust, catMaybes)+import Data.Apiary.Dict(Elem((:=)), NotMember, Dict)+import qualified Data.Apiary.Dict as Dict import Data.Apiary.Compat-import Data.Apiary.Dict+    ( Typeable, mkTyConApp, typeRepTyCon, typeOf, TypeRep, typeRep, Proxy(..)+    , Symbol, KnownSymbol+    )  import Data.String(IsString)-import Data.Time.Calendar+import Data.Time.Calendar(Day, fromGregorian) import qualified Data.Text.Read as TR-import Data.Text.Encoding.Error+import           Data.Text.Encoding.Error(lenientDecode) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL@@ -316,7 +312,7 @@ pFile = Proxy  class ReqParam a where-    reqParams   :: proxy a -> Http.Query -> [Param] -> [File] -> [(S.ByteString, Maybe a)]+    reqParams   :: proxy a -> HTTP.Query -> [Param] -> [File] -> [(S.ByteString, Maybe a)]     reqParamRep :: proxy a -> QueryRep  instance ReqParam File where@@ -335,50 +331,50 @@  class Strategy (w :: * -> *) where     type SNext w (k::Symbol) a (prms :: [Elem]) :: [Elem]-    strategy :: (NotMember k prms, MonadPlus m) => w a -> proxy' k -> [Maybe a] -> Dict prms -> m (Dict (SNext w k a prms))+    strategy :: (KnownSymbol k, NotMember k prms, MonadPlus m) => w a -> proxy' k -> [Maybe a] -> Dict prms -> m (Dict (SNext w k a prms))     strategyRep :: w a -> StrategyRep  data First a = First instance Strategy First where     type SNext First k a ps = k := a ': ps-    strategy _ k (Just a:_) d = return $ insert k a d+    strategy _ k (Just a:_) d = return $ Dict.insert k a d     strategy _ _ _          _ = mzero     strategyRep _ = StrategyRep "first"  data One a = One instance Strategy One where     type SNext One k a ps = k := a ': ps-    strategy _ k [Just a] d = return $ insert k a d+    strategy _ k [Just a] d = return $ Dict.insert k a d     strategy _ _ _        _ = mzero     strategyRep _ = StrategyRep "one"  data Many a = Many instance Strategy Many where     type SNext Many k a ps = k := [a] ': ps-    strategy _ k as d = if all isJust as then return $ insert k (catMaybes as) d else mzero+    strategy _ k as d = if all isJust as then return $ Dict.insert k (catMaybes as) d else mzero     strategyRep _ = StrategyRep "many"  data Some a = Some instance Strategy Some where     type SNext Some k a ps = k := [a] ': ps     strategy _ _ [] _ = mzero-    strategy _ k as d = if all isJust as then return $ insert k (catMaybes as) d else mzero+    strategy _ k as d = if all isJust as then return $ Dict.insert k (catMaybes as) d else mzero     strategyRep _ = StrategyRep "some"  data Option a = Option instance Strategy Option where     type SNext Option k a ps = k := Maybe a ': ps-    strategy _ k (Just a:_)  d = return $ insert k (Just a) d+    strategy _ k (Just a:_)  d = return $ Dict.insert k (Just a) d     strategy _ _ (Nothing:_) _ = mzero-    strategy _ k []          d = return $ insert k Nothing d+    strategy _ k []          d = return $ Dict.insert k Nothing d     strategyRep _ = StrategyRep "option"  data Optional a = Optional T.Text a instance Strategy Optional where     type SNext Optional k a ps = k := a ': ps-    strategy _              k (Just a:_)  d = return $ insert k a d+    strategy _              k (Just a:_)  d = return $ Dict.insert k a d     strategy _              _ (Nothing:_) _ = mzero-    strategy (Optional _ a) k []          d = return $ insert k a d+    strategy (Optional _ a) k []          d = return $ Dict.insert k a d     strategyRep (Optional a _) = StrategyRep $ "default:" `T.append` a  pFirst :: proxy a -> First a

@@ -54,7 +54,12 @@     , text,  lazyText     , showing     , string, char-    , file, devFile+    , appendBuilder+    , appendBytes, appendLazyBytes+    , appendText, appendLazyText+    , appendShowing+    , appendString, appendChar+    , file, file'     , redirect, redirectPermanently, redirectTemporary     , defaultDocumentationAction     , DefaultDocumentConfig(..)@@ -82,7 +87,7 @@     )  import Data.Apiary.Method(Method(..))-import Data.Apiary.Extension(Has, MonadHas(..), Extensions, Initializer, Initializer', (+>))+import Data.Apiary.Extension(Has, MonadExts(..), getExt, Extensions, Initializer, Initializer', (+>)) import Data.Apiary.Dict(key, Member, Members, NotMember, Elem((:=)))  import Network.HTTP.Types.Status hiding (mkStatus)

@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++module Web.Apiary.Develop {-# WARNING "use Web.Apiary in production." #-}+    ( file, file'+    , module Web.Apiary+    ) where++import Web.Apiary hiding (file, file')+import Control.Monad.Apiary.Action (devFile, devFile')++-- | send file contents as lazy bytestring response with detect+-- Content-Type. since v1.2.0.+file :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m ()+file f _ = devFile f++-- | send file contents as lazy bytestring response. since v1.2.0.+file' :: MonadIO m => FilePath -> Maybe FilePart -> ActionT exts prms m ()+file' f _ = devFile' f

@@ -1,10 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}  module Web.Apiary.Heroku     ( Heroku@@ -14,32 +13,33 @@     , runHeroku, runHerokuWith, runHerokuTWith     -- * extension functions     , getHerokuEnv, getHerokuEnv'--    -- * reexports-    -- | exclude run* functions.-    , module Web.Apiary     ) where -import System.Environment+import System.Environment(getEnv) import System.Process-import System.Exit+    ( proc, CreateProcess(..), createProcess+    , StdStream(CreatePipe), waitForProcess)+import System.Exit (ExitCode(ExitSuccess)) -import Control.Exception-import Control.Arrow hiding (app)-import Control.Applicative-import Control.Monad.Trans+import qualified Network.Wai as Wai -import Data.IORef-import Data.Apiary.Compat-import Data.Default.Class+import Control.Exception(catch, try, SomeException)+import Control.Arrow(second)+import Control.Applicative((<$>), (<$), Applicative(..))+import Control.Monad.Trans(MonadIO(..))++import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import Data.Default.Class(Default(def)) 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 Control.Monad.Apiary(ApiaryT, runApiaryTWith, ApiaryConfig) import Data.Apiary.Extension-import Web.Apiary hiding (runApiary, runApiaryWith, runApiaryTWith)+    ( Has, Extension, Extensions, getExtension, noExtension+    , Initializer, Initializer', initializer', (+>)+    )+import Data.Apiary.Compat(Proxy(..))  data Heroku = Heroku      { herokuEnv    :: IORef (Maybe (H.HashMap T.Text T.Text))@@ -72,7 +72,7 @@ -- runHerokuTWith :: (MonadIO m, Monad actM)                => (forall b. actM b -> IO b)-               -> (Int -> Application -> m a)+               -> (Int -> Wai.Application -> m a)                -> Initializer m '[Heroku] exts                -> HerokuConfig                -> ApiaryT exts '[] actM m ()@@ -83,7 +83,7 @@     runApiaryTWith runAct (run port) (initHeroku conf +> ir) (herokuApiaryConfig conf) m  runHerokuWith :: MonadIO m-              => (Int -> Application -> m a)+              => (Int -> Wai.Application -> m a)               -> Initializer m '[Heroku] exts               -> HerokuConfig               -> ApiaryT exts '[] IO m ()@@ -97,7 +97,7 @@ -- * set port by PORT environment variable. -- * getHerokuEnv function(get config from environment variable or @ heroku config @ command). runHeroku :: MonadIO m-          => (Int -> Application -> m a)+          => (Int -> Wai.Application -> m a)           -> HerokuConfig           -> ApiaryT '[Heroku] '[] IO m ()           -> m a

@@ -1,6 +0,0 @@--- | reexporting Network.Wai to reduce dependencies from apiary-* packages.-module Web.Apiary.Wai-    ( module Network.Wai-    ) where--import Network.Wai

@@ -133,10 +133,10 @@ captureApp :: Application captureApp = runApp $ do     [capture|/foo|]  . action $ contentType "text/plain" >> bytes "foo"-    [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= showing-    [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= showing-    [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> char ' ' >> param [key|i|] >>= showing-    [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= lazyBytes+    [capture|/int::Int|] . method GET . action $ contentType "text/plain" >> bytes "Int " >> param [key|int|] >>= appendShowing+    [capture|/d::Double|] . action $ contentType "text/plain" >> bytes "Double " >> param [key|d|] >>= appendShowing+    [capture|/bar/s::L.ByteString/i::Int|] . action $ contentType "text/plain" >> param [key|s|] >>= lazyBytes >> appendChar ' ' >> param [key|i|] >>= appendShowing+    [capture|/s::L.ByteString|] . action $ contentType "text/plain" >> bytes "fall " >> param [key|s|] >>= appendLazyBytes  captureTest :: Test captureTest = testGroup "capture" $ map ($ captureApp)@@ -153,15 +153,15 @@ --------------------------------------------------------------------------------  queryApp f g h = runApp $ do-    _ <- (f [key|foo|] pInt)    . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= showing-    _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= showing-    (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= showing+    _ <- (f [key|foo|] pInt)    . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing+    _ <- (g [key|foo|] pString) . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing+    (h [key|foo|] (pMaybe pString)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing  queryOptionalApp :: Application queryOptionalApp = runApp $ do-    ([key|foo|] =?!: (5 :: Int))                   . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= showing-    ([key|foo|] =?!: ("bar" :: String))            . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= showing-    ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= showing+    ([key|foo|] =?!: (5 :: Int))                   . action $ contentType "text/plain" >> bytes "foo Int " >> param [key|foo|] >>= appendShowing+    ([key|foo|] =?!: ("bar" :: String))            . action $ contentType "text/plain" >> bytes "foo String " >> param [key|foo|] >>= appendShowing+    ([key|foo|] =?!: (Just "baz" :: Maybe String)) . action $ contentType "text/plain" >> bytes "foo Maybe String " >> param [key|foo|] >>= appendShowing  queryFirstTest :: Test queryFirstTest = testGroup "First" $ map ($ queryApp (=:) (=:) (=:))@@ -234,7 +234,7 @@     switchQuery [key|foo|] . switchQuery [key|bar|] . action $ do         contentType "text/plain"         param [key|foo|] >>= showing-        param [key|bar|] >>= showing+        param [key|bar|] >>= appendShowing  switchQueryTest :: Test switchQueryTest = testGroup "switch" $ map ($ switchQueryApp)@@ -266,9 +266,9 @@         i <- param [key|i|]         contentType "text/plain"         when (i == 1) $ bytes "one\n"-        if i `mod` 2 == 0 then bytes "even\n" else bytes "odd\n"+        if i `mod` 2 == 0 then appendBytes "even\n" else appendBytes "odd\n"         when (i == 2) stop-        bytes "after stop"+        appendBytes "after stop"  stopTest :: Test stopTest = testGroup "stop" $ map ($ stopApp)