diff --git a/apiary.cabal b/apiary.cabal --- a/apiary.cabal +++ b/apiary.cabal @@ -1,5 +1,5 @@ name: apiary -version: 0.6.1.0 +version: 0.7.0.0 synopsis: Simple web framework inspired by scotty. description: Simple web framework inspired by scotty. @@ -31,11 +31,11 @@ 404 Page Notfound. @ . - * Nestable route handling(ApiaryT Monad; capture, stdMethod and more.). + * Nestable route handling(Apiary Monad; capture, stdMethod and more.). . * type safe route filter. . - full example & tutorial: + more examples: license: MIT license-file: LICENSE @@ -86,7 +86,6 @@ , bytestring >=0.10 && <0.11 , blaze-builder >=0.3 && <0.4 , conduit >=1.1 && <1.2 - , monad-logger >=0.3 && <0.4 , data-default-class >=0.0 && <0.1 , tagged >=0.7 && <0.8 , reflection >=1.4 && <1.5 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,8 +1,6 @@ module Control.Monad.Apiary - ( ApiaryT - , Apiary + ( Apiary , runApiary - , runApiaryT -- * getter , apiaryConfig -- * execute action diff --git a/src/Control/Monad/Apiary/Action.hs b/src/Control/Monad/Apiary/Action.hs --- a/src/Control/Monad/Apiary/Action.hs +++ b/src/Control/Monad/Apiary/Action.hs @@ -1,6 +1,6 @@ module Control.Monad.Apiary.Action ( - ActionT + Action , ApiaryConfig(..) -- * actions , stop, stopWith @@ -23,10 +23,13 @@ -- ** monolithic action -- *** redirect - , redirect - , redirectPermanently, redirectFound, redirectSeeOther, redirectTemporary + , redirect, redirectPermanently, redirectTemporary + , redirectWith -- * Reexport , module Data.Default.Class + + -- * deprecated + , redirectFound, redirectSeeOther ) where import Control.Monad.Apiary.Action.Internal diff --git a/src/Control/Monad/Apiary/Action/Internal.hs b/src/Control/Monad/Apiary/Action/Internal.hs --- a/src/Control/Monad/Apiary/Action/Internal.hs +++ b/src/Control/Monad/Apiary/Action/Internal.hs @@ -13,7 +13,6 @@ import Control.Monad import Control.Monad.Trans import Control.Monad.Base -import Control.Monad.Reader import Control.Monad.Trans.Control import Network.Wai import Network.Mime @@ -25,7 +24,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Data.Conduit -import qualified Control.Monad.Logger as Logger data ApiaryConfig = ApiaryConfig { -- | call when no handler matched. @@ -72,198 +70,209 @@ st = actionStatus as hd = actionHeaders as -data Action a +data Act a = Continue a | Pass | Stop Response -newtype ActionT m a = ActionT { unActionT :: forall b. +newtype Action a = Action { unAction :: forall b. ApiaryConfig -> Request -> ActionState - -> (a -> ActionState -> m (Action b)) - -> m (Action b) + -> (a -> ActionState -> IO (Act b)) + -> IO (Act b) } -instance Functor (ActionT m) where - fmap f m = ActionT $ \conf req st cont -> - unActionT m conf req st (\a s' -> s' `seq` cont (f a) s') +instance Functor Action where + fmap f m = Action $ \conf req st cont -> + unAction m conf req st (\a s' -> s' `seq` cont (f a) s') -instance Applicative (ActionT m) where - pure x = ActionT $ \_ _ st cont -> cont x st - mf <*> ma = ActionT $ \conf req st cont -> - unActionT mf conf req st $ \f st' -> - unActionT ma conf req st' $ \a st'' -> +instance Applicative Action where + pure x = Action $ \_ _ st cont -> cont x st + mf <*> ma = Action $ \conf req st cont -> + unAction mf conf req st $ \f st' -> + unAction ma conf req st' $ \a st'' -> st' `seq` st'' `seq` cont (f a) st'' -instance Monad m => Monad (ActionT m) where - return x = ActionT $ \_ _ st cont -> cont x st - m >>= k = ActionT $ \conf req st cont -> - unActionT m conf req st $ \a st' -> - st' `seq` unActionT (k a) conf req st' cont - fail _ = ActionT $ \_ _ _ _ -> return Pass +instance Monad Action where + return x = Action $ \_ _ st cont -> cont x st + m >>= k = Action $ \conf req st cont -> + unAction m conf req st $ \a st' -> + st' `seq` unAction (k a) conf req st' cont + fail _ = Action $ \_ _ _ _ -> return Pass -instance MonadIO m => MonadIO (ActionT m) where - liftIO m = ActionT $ \_ _ st cont -> +instance MonadIO Action where + liftIO m = Action $ \_ _ st cont -> liftIO m >>= \a -> cont a st -instance MonadTrans ActionT where - lift m = ActionT $ \_ _ st cont -> - m >>= \a -> cont a st - -runActionT :: Monad m => ActionT m a +runAction :: Action a -> ApiaryConfig -> Request -> ActionState - -> m (Action (a, ActionState)) -runActionT m conf req st = unActionT m conf req st $ \a st' -> + -> IO (Act (a, ActionState)) +runAction m conf req st = unAction m conf req st $ \a st' -> st' `seq` return (Continue (a, st')) -actionT :: Monad m - => (ApiaryConfig -> Request -> ActionState -> m (Action (a, ActionState))) - -> ActionT m a -actionT f = ActionT $ \conf req st cont -> f conf req st >>= \case +action :: (ApiaryConfig -> Request -> ActionState -> IO (Act (a, ActionState))) + -> Action a +action f = Action $ \conf req st cont -> f conf req st >>= \case Pass -> return Pass Stop s -> return $ Stop s Continue (a,st') -> st' `seq` cont a st' -hoistActionT :: (Monad m, Monad n) - => (forall b. m b -> n b) -> ActionT m a -> ActionT n a -hoistActionT run m = actionT $ \c r s -> run (runActionT m c r s) - -execActionT :: ApiaryConfig -> ActionT IO () -> Application -execActionT config m request = runActionT m config request resp >>= \case +execAction :: ApiaryConfig -> Action () -> Application +execAction config m request = runAction m config request resp >>= \case Pass -> notFound config request Stop s -> return s Continue (_,r) -> return $ actionStateToResponse r where resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "") -instance (Monad m, Functor m) => Alternative (ActionT m) where +instance Alternative Action where empty = mzero (<|>) = mplus -instance Monad m => MonadPlus (ActionT m) where - mzero = actionT $ \_ _ _ -> return Pass - mplus m n = actionT $ \c r s -> runActionT m c r s >>= \case +instance MonadPlus Action where + mzero = action $ \_ _ _ -> return Pass + mplus m n = action $ \c r s -> runAction m c r s >>= \case Continue a -> return $ Continue a Stop stp -> return $ Stop stp - Pass -> runActionT n c r s + Pass -> runAction n c r s -instance Monad m => Monoid (ActionT m ()) where +instance Monoid (Action ()) where mempty = mzero mappend = mplus -instance MonadBase b m => MonadBase b (ActionT m) where - liftBase = liftBaseDefault - -instance MonadTransControl ActionT where - newtype StT ActionT a = StActionT { unStActionT :: Action (a, ActionState) } - liftWith f = actionT $ \c r s -> - liftM (\a -> Continue (a,s)) (f $ \t -> liftM StActionT $ runActionT t c r s) - restoreT m = actionT $ \_ _ _ -> liftM unStActionT m - -instance MonadBaseControl b m => MonadBaseControl b (ActionT m) where - newtype StM (ActionT m) a = StMT { unStMT :: ComposeSt ActionT m a } - liftBaseWith = defaultLiftBaseWith StMT - restoreM = defaultRestoreM unStMT - -instance MonadReader r m => MonadReader r (ActionT m) where - ask = lift ask - local f = hoistActionT $ local f +instance MonadBase IO Action where + liftBase = liftIO -instance Logger.MonadLogger m => Logger.MonadLogger (ActionT m) where - monadLoggerLog loc src lv msg = lift $ Logger.monadLoggerLog loc src lv msg +instance MonadBaseControl IO Action where + newtype StM Action a = StMAction { unStMAction :: Act (a, ActionState) } + liftBaseWith f = action $ \c r s -> + liftM (\a -> Continue (a, s)) (f $ \t -> liftM StMAction $ runAction t c r s) + restoreM m = action $ \_ _ _ -> return (unStMAction m) -- | stop handler and send current state. since 0.3.3.0. -stop :: Monad m => ActionT m a -stop = ActionT $ \_ _ s _ -> return $ Stop (actionStateToResponse s) +stop :: Action a +stop = Action $ \_ _ s _ -> return $ Stop (actionStateToResponse s) -- | stop with response. since 0.4.2.0. -stopWith :: Monad m => Response -> ActionT m a -stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a +stopWith :: Response -> Action a +stopWith a = Action $ \_ _ _ _ -> return $ Stop a -- | get raw request. since 0.1.0.0. -getRequest :: Monad m => ActionT m Request -getRequest = ActionT $ \_ r s c -> c r s +getRequest :: Action Request +getRequest = Action $ \_ r s c -> c r s -getConfig :: Monad m => ActionT m ApiaryConfig -getConfig = ActionT $ \c _ s cont -> cont c s +getConfig :: Action ApiaryConfig +getConfig = Action $ \c _ s cont -> cont c s -modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m () -modifyState f = ActionT $ \_ _ s c -> c () (f s) +modifyState :: (ActionState -> ActionState) -> Action () +modifyState f = Action $ \_ _ s c -> c () (f s) -- | get all request headers. since 0.6.0.0. -getHeaders :: Monad m => ActionT m RequestHeaders +getHeaders :: Action RequestHeaders getHeaders = requestHeaders `liftM` getRequest -- | set status code. since 0.1.0.0. -status :: Monad m => Status -> ActionT m () +status :: Status -> Action () status st = modifyState (\s -> s { actionStatus = st } ) -- | modify response header. since 0.1.0.0. -modifyHeader :: Monad m => (ResponseHeaders -> ResponseHeaders) -> ActionT m () +modifyHeader :: (ResponseHeaders -> ResponseHeaders) -> Action () modifyHeader f = modifyState (\s -> s {actionHeaders = f $ actionHeaders s } ) -- | add response header. since 0.1.0.0. -addHeader :: Monad m => HeaderName -> S.ByteString -> ActionT m () +addHeader :: HeaderName -> S.ByteString -> Action () addHeader h v = modifyHeader ((h,v):) -- | set response headers. since 0.1.0.0. -setHeaders :: Monad m => ResponseHeaders -> ActionT m () +setHeaders :: ResponseHeaders -> Action () setHeaders hs = modifyHeader (const hs) -- | set content-type header. -- if content-type header already exists, replace it. since 0.1.0.0. -contentType :: Monad m => S.ByteString -> ActionT m () +contentType :: S.ByteString -> Action () contentType c = modifyHeader (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h) -- | redirect handler -- --- set status, location header and stop. since 0.3.3.0. -redirect :: Monad m - => Status - -> S.ByteString -- ^ Location redirect to - -> ActionT m a -redirect st url = do +-- set status, add location header. since 0.3.3.0. +-- +-- rename from redirect in 0.6.2.0. +redirectWith :: Status + -> S.ByteString -- ^ Location redirect to + -> Action () +redirectWith st url = do status st - setHeaders [("location", url)] - stop + addHeader "location" url --- | redirect with 301 Moved Permanently. since 0.3.3.0. -redirectPermanently :: Monad m => S.ByteString -> ActionT m a -redirectPermanently = redirect movedPermanently301 +-- HTTP/1.0 HTTP/1.1 +-- 300 MultipleChoices +-- 301 MovedPermanently MovedPermanently +-- 302 MovedTemporarily Found +-- 303 SeeOther +-- 304 NotModified NotModified +-- 305 UseProxy +-- 307 TemporaryRedirect --- | redirect with 302 Found. since 0.3.3.0. -redirectFound :: Monad m => S.ByteString -> ActionT m a -redirectFound = redirect found302 +-- | redirect with 301 Moved Permanently. since 0.3.3.0. +redirectPermanently :: S.ByteString -> Action () +redirectPermanently = redirectWith movedPermanently301 --- | redirect with 303 See Other. since 0.3.3.0. -redirectSeeOther :: Monad m => S.ByteString -> ActionT m a -redirectSeeOther = redirect seeOther303 +-- | redirect with: +-- +-- 303 See Other (HTTP/1.1) or +-- 302 Moved Temporarily (Other) +-- +-- since 0.6.2.0. +redirect :: S.ByteString -> Action () +redirect to = do + v <- httpVersion <$> getRequest + if v == http11 + then redirectWith seeOther303 to + else redirectWith status302 to --- | redirect with 307 Temporary Redirect. since 0.3.3.0. -redirectTemporary :: Monad m => S.ByteString -> ActionT m a -redirectTemporary = redirect temporaryRedirect307 +-- | redirect with: +-- +-- 307 Temporary Redirect (HTTP/1.1) or +-- 302 Moved Temporarily (Other) +-- +-- since 0.3.3.0. +redirectTemporary :: S.ByteString -> Action () +redirectTemporary to = do + v <- httpVersion <$> getRequest + if v == http11 + then redirectWith temporaryRedirect307 to + else redirectWith status302 to -- | set response body file content and detect Content-Type by extension. since 0.1.0.0. -file :: Monad m => FilePath -> Maybe FilePart -> ActionT m () +file :: FilePath -> Maybe FilePart -> Action () file f p = do mime <- mimeType <$> getConfig contentType (mime f) file' f p -- | set response body file content, without set Content-Type. since 0.1.0.0. -file' :: Monad m => FilePath -> Maybe FilePart -> ActionT m () +file' :: FilePath -> Maybe FilePart -> Action () file' f p = modifyState (\s -> s { actionBody = File f p } ) -- | set response body builder. since 0.1.0.0. -builder :: Monad m => Builder -> ActionT m () +builder :: Builder -> Action () builder b = modifyState (\s -> s { actionBody = Builder b } ) -- | set response body lazy bytestring. since 0.1.0.0. -lbs :: Monad m => L.ByteString -> ActionT m () +lbs :: L.ByteString -> Action () lbs l = modifyState (\s -> s { actionBody = LBS l } ) -- | set response body source. since 0.1.0.0. -source :: Monad m => Source IO (Flush Builder) -> ActionT m () +source :: Source IO (Flush Builder) -> Action () source src = modifyState (\s -> s { actionBody = SRC src } ) + +{-# DEPRECATED redirectFound, redirectSeeOther "use redirect" #-} +-- | redirect with 302 Found. since 0.3.3.0. +redirectFound :: S.ByteString -> Action () +redirectFound = redirectWith found302 + +-- | redirect with 303 See Other. since 0.3.3.0. +redirectSeeOther :: S.ByteString -> Action () +redirectSeeOther = redirectWith seeOther303 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 @@ -60,35 +60,35 @@ import Control.Monad.Apiary.Internal -- | filter by HTTP method. since 0.1.0.0. -method :: Monad m => HT.Method -> ApiaryT c m a -> ApiaryT c m a +method :: HT.Method -> Apiary c a -> Apiary c a method m = function_ ((m ==) . requestMethod) -- | filter by HTTP method using StdMethod. since 0.1.0.0. -stdMethod :: Monad m => StdMethod -> ApiaryT c m a -> ApiaryT c m a +stdMethod :: StdMethod -> Apiary c a -> Apiary c a stdMethod = method . HT.renderStdMethod -- | filter by ssl accessed. since 0.1.0.0. -ssl :: Monad m => ApiaryT c m a -> ApiaryT c m a +ssl :: Apiary c a -> Apiary c a ssl = function_ isSecure -- | http version filter. since 0.5.0.0. -httpVersion :: Monad m => HT.HttpVersion -> ApiaryT c m b -> ApiaryT c m b +httpVersion :: HT.HttpVersion -> Apiary c b -> Apiary c b httpVersion v = function_ $ (v ==) . Wai.httpVersion -- | http/0.9 only accepted fiter. since 0.5.0.0. -http09 :: Monad m => ApiaryT c m b -> ApiaryT c m b +http09 :: Apiary c b -> Apiary c b http09 = Control.Monad.Apiary.Filter.httpVersion HT.http09 -- | http/1.0 only accepted fiter. since 0.5.0.0. -http10 :: Monad m => ApiaryT c m b -> ApiaryT c m b +http10 :: Apiary c b -> Apiary c b http10 = Control.Monad.Apiary.Filter.httpVersion HT.http10 -- | http/1.1 only accepted fiter. since 0.5.0.0. -http11 :: Monad m => ApiaryT c m b -> ApiaryT c m b +http11 :: Apiary c b -> Apiary c b http11 = Control.Monad.Apiary.Filter.httpVersion HT.http11 -- | filter by 'Control.Monad.Apiary.Action.rootPattern' of 'Control.Monad.Apiary.Action.ApiaryConfig'. -root :: Monad m => ApiaryT c m b -> ApiaryT c m b +root :: Apiary c b -> Apiary c b root m = do rs <- rootPattern `liftM` apiaryConfig function_ (\r -> rawPathInfo r `elem` rs) m @@ -107,11 +107,11 @@ -- query "key" (Proxy :: Proxy ('Many' String) -- get all \'key\' query parameter as String. -- @ -- -query :: (Query a, Strategy.Strategy w, Monad m) +query :: (Query a, Strategy.Strategy w) => S.ByteString -> Proxy (w a) - -> ApiaryT (Strategy.SNext w as a) m b - -> ApiaryT as m b + -> Apiary (Strategy.SNext w as a) b + -> Apiary as b query k p = function $ \l r -> Strategy.readStrategy readQuery ((k ==) . fst) p (queryString r) l -- | get first matched paramerer. since 0.5.0.0. @@ -119,8 +119,7 @@ -- @ -- "key" =: pInt == query "key" (pFirst pInt) == query "key" (Proxy :: Proxy (First Int)) -- @ -(=:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT (Snoc as a) m b -> ApiaryT as m b +(=:) :: Query a => S.ByteString -> Proxy a -> Apiary (Snoc as a) b -> Apiary as b k =: t = query k (pFirst t) -- | get one matched paramerer. since 0.5.0.0. @@ -130,8 +129,7 @@ -- @ -- "key" =: pInt == query "key" (pOne pInt) == query "key" (Proxy :: Proxy (One Int)) -- @ -(=!:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT (Snoc as a) m b -> ApiaryT as m b +(=!:) :: Query a => S.ByteString -> Proxy a -> Apiary (Snoc as a) b -> Apiary as b k =!: t = query k (pOne t) -- | get optional first paramerer. since 0.5.0.0. @@ -141,8 +139,7 @@ -- @ -- "key" =: pInt == query "key" (pOption pInt) == query "key" (Proxy :: Proxy (Option Int)) -- @ -(=?:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT (Snoc as (Maybe a)) m b -> ApiaryT as m b +(=?:) :: Query a => S.ByteString -> Proxy a -> Apiary (Snoc as (Maybe a)) b -> Apiary as b k =?: t = query k (pOption t) -- | check parameger given and type. since 0.5.0.0. @@ -152,8 +149,7 @@ -- @ -- "key" =: pInt == query "key" (pCheck pInt) == query "key" (Proxy :: Proxy (Check Int)) -- @ -(?:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT as m b -> ApiaryT as m b +(?:) :: Query a => S.ByteString -> Proxy a -> Apiary as b -> Apiary as b k ?: t = query k (pCheck t) -- | get many paramerer. since 0.5.0.0. @@ -161,8 +157,7 @@ -- @ -- "key" =: pInt == query "key" (pMany pInt) == query "key" (Proxy :: Proxy (Many Int)) -- @ -(=*:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT (Snoc as [a]) m b -> ApiaryT as m b +(=*:) :: Query a => S.ByteString -> Proxy a -> Apiary (Snoc as [a]) b -> Apiary as b k =*: t = query k (pMany t) -- | get some paramerer. since 0.5.0.0. @@ -170,8 +165,7 @@ -- @ -- "key" =: pInt == query "key" (pSome pInt) == query "key" (Proxy :: Proxy (Some Int)) -- @ -(=+:) :: (Query a, Monad m) - => S.ByteString -> Proxy a -> ApiaryT (Snoc as [a]) m b -> ApiaryT as m b +(=+:) :: Query a => S.ByteString -> Proxy a -> Apiary (Snoc as [a]) b -> Apiary as b k =+: t = query k (pSome t) -- | query exists checker. @@ -180,42 +174,40 @@ -- hasQuery q = 'query' q (Proxy :: Proxy ('Check' ())) -- @ -- -hasQuery :: Monad m => S.ByteString -> ApiaryT c m a -> ApiaryT c m a +hasQuery :: S.ByteString -> Apiary c a -> Apiary c a hasQuery q = query q (Proxy :: Proxy (Strategy.Check ())) -------------------------------------------------------------------------------- -- | check whether to exists specified header or not. since 0.6.0.0. -hasHeader :: Monad m => HT.HeaderName - -> ApiaryT as m b -> ApiaryT as m b +hasHeader :: HT.HeaderName -> Apiary as b -> Apiary as b hasHeader n = header' pCheck ((n ==) . fst) -- | check whether to exists specified valued header or not. since 0.6.0.0. -eqHeader :: Monad m => HT.HeaderName +eqHeader :: HT.HeaderName -> S.ByteString -- ^ header value - -> ApiaryT as m b - -> ApiaryT as m b + -> Apiary as b + -> Apiary as b eqHeader k v = header' pCheck (\(k',v') -> k == k' && v == v') -- | filter by header and get first. since 0.6.0.0. -header :: Monad m => HT.HeaderName - -> ApiaryT (Snoc as S.ByteString) m b -> ApiaryT as m b +header :: HT.HeaderName + -> Apiary (Snoc as S.ByteString) b -> Apiary as b header n = header' pFirst ((n ==) . fst) -- | filter by headers up to 100 entries. since 0.6.0.0. -headers :: Monad m => HT.HeaderName - -> ApiaryT (Snoc as [S.ByteString]) m b -> ApiaryT as m b +headers :: HT.HeaderName -> Apiary (Snoc as [S.ByteString]) b -> Apiary as b headers n = header' limit100 ((n ==) . fst) where limit100 :: Proxy x -> Proxy (Strategy.LimitSome $(int 100) x) limit100 _ = Proxy -- | low level header filter. since 0.6.0.0. -header' :: (Strategy.Strategy w, Monad m) +header' :: (Strategy.Strategy w) => (forall x. Proxy x -> Proxy (w x)) -> (HT.Header -> Bool) - -> ApiaryT (Strategy.SNext w as S.ByteString) m b - -> ApiaryT as m b + -> Apiary (Strategy.SNext w as S.ByteString) b + -> Apiary as b header' pf kf = function $ \l r -> Strategy.readStrategy Just kf (pf pByteString) (requestHeaders r) l diff --git a/src/Control/Monad/Apiary/Filter/Internal.hs b/src/Control/Monad/Apiary/Filter/Internal.hs --- a/src/Control/Monad/Apiary/Filter/Internal.hs +++ b/src/Control/Monad/Apiary/Filter/Internal.hs @@ -9,15 +9,15 @@ import Data.Apiary.SList -- | low level filter function. -function :: Monad m => (SList c -> Request -> Maybe (SList c')) -> ApiaryT c' m b -> ApiaryT c m b +function :: (SList c -> Request -> Maybe (SList c')) -> Apiary c' b -> Apiary c b function f = focus $ \c -> getRequest >>= \r -> case f c r of Nothing -> mzero Just c' -> return c' -- | filter and append argument. -function' :: Monad m => (Request -> Maybe a) -> ApiaryT (Snoc as a) m b -> ApiaryT as m b +function' :: (Request -> Maybe a) -> Apiary (Snoc as a) b -> Apiary as b function' f = function $ \c r -> sSnoc c `fmap` f r -- | filter only(not modify arguments). -function_ :: Monad m => (Request -> Bool) -> ApiaryT c m b -> ApiaryT c m b +function_ :: (Request -> Bool) -> Apiary c b -> Apiary c b function_ f = function $ \c r -> if f r then Just c else Nothing 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 @@ -60,5 +60,5 @@ -- capture myCapture . stdMethod GET . action $ \age name -> do -- yourAction -- @ -capture :: (Capture as, Monad m) => SList as -> ApiaryT (CaptureResult xs as) m b -> ApiaryT xs m b +capture :: Capture as => SList as -> Apiary (CaptureResult xs as) b -> Apiary xs b capture cap = function $ \bf req -> capture' cap (pathInfo req) bf 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 @@ -2,6 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} @@ -13,73 +16,85 @@ import Network.Wai import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Control +import Control.Monad.Base import Data.Monoid import Data.Apiary.SList import Control.Monad.Apiary.Action.Internal -newtype ApiaryT c m a = ApiaryT { unApiaryT :: forall b. - (forall x . m x -> IO x) - -> ActionT IO (SList c) +newtype Apiary c a = Apiary { unApiary :: forall b. + Action (SList c) -> ApiaryConfig - -> (a -> ActionT IO () -> m b) - -> m b + -> (a -> Action () -> IO b) + -> IO b } -instance Functor (ApiaryT c m) where - fmap f m = ApiaryT $ \run grd conf cont -> - unApiaryT m run grd conf $ \a hdr -> hdr `seq` cont (f a) hdr +instance Functor (Apiary c) where + fmap f m = Apiary $ \grd conf cont -> + unApiary m grd conf $ \a hdr -> hdr `seq` cont (f a) hdr -instance Applicative (ApiaryT c m) where - pure x = ApiaryT $ \_ _ _ cont -> cont x mempty - mf <*> ma = ApiaryT $ \run grd conf cont -> - unApiaryT mf run grd conf $ \f hdr -> - unApiaryT ma run grd conf $ \a hdr' -> +instance Applicative (Apiary c) where + pure x = Apiary $ \_ _ cont -> cont x mempty + mf <*> ma = Apiary $ \grd conf cont -> + unApiary mf grd conf $ \f hdr -> + unApiary ma grd conf $ \a hdr' -> let hdr'' = hdr <> hdr' in hdr'' `seq` cont (f a) hdr'' -instance Monad (ApiaryT c m) where - return x = ApiaryT $ \_ _ _ cont -> cont x mempty - m >>= k = ApiaryT $ \run grd conf cont -> - unApiaryT m run grd conf $ \a hdr -> - unApiaryT (k a) run grd conf $ \b hdr' -> +instance Monad (Apiary c) where + return x = Apiary $ \_ _ cont -> cont x mempty + m >>= k = Apiary $ \grd conf cont -> + unApiary m grd conf $ \a hdr -> + unApiary (k a) grd conf $ \b hdr' -> let hdr'' = hdr <> hdr' in hdr'' `seq` cont b hdr'' -runApiaryT :: Monad m => ApiaryConfig -> (forall x. m x -> IO x) -> ApiaryT '[] m a -> Application -runApiaryT conf run m req = run (unApiaryT m run (return SNil) conf (\_ w -> return w)) >>= \a -> - execActionT conf a req +instance MonadIO (Apiary c) where + liftIO m = Apiary $ \_ _ c -> m >>= \a -> c a mempty -type Apiary c = ApiaryT c IO +instance MonadBase IO (Apiary c) where + liftBase = liftIO -runApiary :: ApiaryConfig -> Apiary '[] a -> Application -runApiary conf = runApiaryT conf id +apiary :: (Action (SList c) -> ApiaryConfig -> IO (a,Action ())) -> Apiary c a +apiary f = Apiary $ \grd conf cont -> f grd conf >>= \(a,w) -> cont a w -getRunner :: Monad m => ApiaryT c m (ActionT m a -> ActionT IO a) -getRunner = ApiaryT $ \run _ _ c -> c (hoistActionT run) mempty +run :: Apiary c a -> Action (SList c) -> ApiaryConfig -> IO (a, Action ()) +run m grd conf = unApiary m grd conf $ \a w -> return (a,w) -getGuard :: ApiaryT c m (ActionT IO (SList c)) -getGuard = ApiaryT $ \_ grd _ c -> c grd mempty +instance MonadBaseControl IO (Apiary c) where + newtype StM (Apiary c) a = StMApiary { unStMApiary :: (a, Action ()) } + liftBaseWith f = apiary $ \g c -> + liftM (\a -> (a, mempty)) (f $ \t -> liftM StMApiary $ run t g c) + restoreM m = apiary $ \_ _ -> return (unStMApiary m) -apiaryConfig :: ApiaryT c m ApiaryConfig -apiaryConfig = ApiaryT $ \_ _ c cont -> cont c mempty +runApiary :: ApiaryConfig -> Apiary '[] a -> Application +runApiary conf m req = unApiary m (return SNil) conf (\_ w -> return w) >>= \a -> + execAction conf a req -addRoute :: ActionT IO () -> ApiaryT c m () -addRoute r = ApiaryT $ \_ _ _ cont -> cont () r +getGuard :: Apiary c (Action (SList c)) +getGuard = Apiary $ \grd _ c -> c grd mempty +apiaryConfig :: Apiary c ApiaryConfig +apiaryConfig = Apiary $ \_ c cont -> cont c mempty + +addRoute :: Action () -> Apiary c () +addRoute r = Apiary $ \_ _ cont -> cont () r + -- | filter by action. since 0.6.1.0. -focus :: (SList c -> ActionT IO (SList c')) -> ApiaryT c' m a -> ApiaryT c m a +focus :: (SList c -> Action (SList c')) -> Apiary c' a -> Apiary c a focus g m = do - ApiaryT $ \run grd cfg cont -> - unApiaryT m run (grd >>= g) cfg cont + Apiary $ \grd cfg cont -> + unApiary m (grd >>= g) cfg cont -action :: Monad m => Fn c (ActionT m ()) -> ApiaryT c m () +action :: Fn c (Action ()) -> Apiary c () action = actionWithPreAction (const $ return ()) -- | execute action before main action. since v0.4.2.0 -actionWithPreAction :: Monad m => (SList xs -> ActionT IO a) - -> Fn xs (ActionT m ()) -> ApiaryT xs m () +actionWithPreAction :: (SList xs -> Action a) + -> Fn xs (Action ()) -> Apiary xs () actionWithPreAction pa a = do - tr <- getRunner grd <- getGuard - addRoute $ grd >>= \c -> (pa c) >> tr (apply a c) + addRoute $ grd >>= \c -> (pa c) >> apply a c