apiary 0.3.2.0 → 0.4.0.0

raw patch · 8 files changed

+165/−42 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• apiary.cabal +6/−5
• src/Control/Monad/Apiary.hs +4/−0
• src/Control/Monad/Apiary/Action.hs +8/−0
• src/Control/Monad/Apiary/Action/Internal.hs +56/−15
• src/Control/Monad/Apiary/Filter.hs +49/−10
• src/Control/Monad/Apiary/Internal.hs +37/−9
• src/Web/Apiary/TH.hs +2/−1
• src/Web/Apiary/TH/Capture.hs +3/−2

@@ -1,5 +1,5 @@ name:                apiary-version:             0.3.2.0+version:             0.4.0.0 x-revision:          1 synopsis:            Simple web framework inspired by scotty. description:@@ -12,18 +12,19 @@   import Web.Apiary   import Network.Wai.Handler.Warp   import qualified Data.ByteString.Lazy.Char8 as L+  import Control.Monad   .   main :: IO ()   main = run 3000 . runApiary def $ do-  &#32;&#32;[capture|/:String|] $ do-  &#32;&#32;&#32;&#32;stdMethod GET . action $ \\name -> do+  &#32;&#32;[capture|/:Int|] . queryFirst' "name" . stdMethod GET . action $ \\age name -> do+  &#32;&#32;&#32;&#32;&#32;&#32;guard (age >= 18)   &#32;&#32;&#32;&#32;&#32;&#32;contentType &#34;text/html&#34;-  &#32;&#32;&#32;&#32;&#32;&#32;lbs . L.concat $ [&#34;&#60;h1&#62;Hello, &#34;, L.pack name, &#34;!&#60;/h1&#62;&#34;]+  &#32;&#32;&#32;&#32;&#32;&#32;lbs . L.concat $ [&#34;&#60;h1&#62;Hello, &#34;, L.fromStrict name, &#34;!&#60;/h1&#62;&#34;]   @   .     * Nestable route handling(ApiaryT Monad; capture, stdMethod and more.).   .-    * type safe path capture.+    * type safe route filter.   .   full example & tutorial: <https://github.com/philopon/apiary/blob/master/examples/main.lhs> 

@@ -7,6 +7,10 @@     , apiaryConfig     -- * execute action     , action, action_+    -- * Singletons+    , SList(..)+    , Fn, Snoc+    , sSnoc     -- * Reexport     , module Control.Monad.Apiary.Filter     ) where

@@ -3,10 +3,13 @@       ActionT     , ApiaryConfig(..)     -- * actions+    , stop+     -- ** getter     , getRequest     , getQuery, getQuery'     , getRequestHeader, getRequestHeader'+     -- ** setter     , status     -- *** response header@@ -18,6 +21,11 @@     , builder     , lbs     , source++    -- ** monolithic action+    -- *** redirect+    , redirect+    , redirectPermanently, redirectFound, redirectSeeOther, redirectTemporary     -- * Reexport     , def     ) where

@@ -5,6 +5,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE NoMonomorphismRestriction #-}  module Control.Monad.Apiary.Action.Internal where @@ -71,12 +72,17 @@     st = actionStatus  as     hd = actionHeaders as +data Action a +    = Continue a+    | Pass+    | Stop ActionState+ newtype ActionT m a = ActionT { unActionT :: forall b.      ApiaryConfig     -> Request     -> ActionState-    -> (a -> ActionState -> m (Maybe b))-    -> m (Maybe b)+    -> (a -> ActionState -> m (Action b))+    -> m (Action b)     }  instance Functor (ActionT m) where@@ -95,7 +101,7 @@     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 Nothing+    fail _ = ActionT $ \_ _ _ _ -> return Pass  instance MonadIO m => MonadIO (ActionT m) where     liftIO m = ActionT $ \_ _ st cont ->@@ -107,16 +113,17 @@  runActionT :: Monad m => ActionT m a            -> ApiaryConfig -> Request -> ActionState-           -> m (Maybe (a, ActionState))+           -> m (Action (a, ActionState)) runActionT m conf req st = unActionT m conf req st $ \a st' ->-    st' `seq` return (Just (a, st'))+    st' `seq` return (Continue (a, st'))  actionT :: Monad m -        => (ApiaryConfig -> Request -> ActionState -> m (Maybe (a, ActionState)))+        => (ApiaryConfig -> Request -> ActionState -> m (Action (a, ActionState)))         -> ActionT m a actionT f = ActionT $ \conf req st cont -> f conf req st >>= \case-    Nothing      -> return Nothing-    Just (a,st') -> st' `seq` cont a st'+    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@@ -124,8 +131,9 @@  execActionT :: ApiaryConfig -> ActionT IO () -> Application execActionT config m request = runActionT m config request resp >>= \case-        Nothing    -> notFound config request-        Just (_,r) -> return $ actionStateToResponse r+        Pass           -> notFound config request+        Stop s         -> return $ actionStateToResponse s+        Continue (_,r) -> return $ actionStateToResponse r   where     resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "") @@ -134,10 +142,11 @@     (<|>) = mplus  instance Monad m => MonadPlus (ActionT m) where-    mzero = actionT $ \_ _ _ -> return Nothing+    mzero = actionT $ \_ _ _ -> return Pass     mplus m n = actionT $ \c r s -> runActionT m c r s >>= \case-        Just a  -> return $ Just a-        Nothing -> runActionT n c r s+        Continue a -> return $ Continue a+        Stop stp   -> return $ Stop stp+        Pass       -> runActionT n c r s  instance Monad m => Monoid (ActionT m ()) where     mempty  = mzero@@ -147,9 +156,9 @@     liftBase = liftBaseDefault  instance MonadTransControl ActionT where-    newtype StT ActionT a = StActionT { unStActionT :: Maybe (a, ActionState) }+    newtype StT ActionT a = StActionT { unStActionT :: Action (a, ActionState) }     liftWith f = actionT $ \c r s -> -        liftM (\a -> Just (a,s)) (f $ \t -> liftM StActionT $ runActionT t 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@@ -164,6 +173,10 @@ instance Logger.MonadLogger m => Logger.MonadLogger (ActionT m) where     monadLoggerLog loc src lv msg = lift $ Logger.monadLoggerLog loc src lv msg +-- | stop handler and send current state. since 0.3.3.0.+stop :: Monad m => ActionT m a+stop = ActionT $ \_ _ s _ -> return $ Stop s+ getRequest :: Monad m => ActionT m Request getRequest = ActionT $ \_ r s c -> c r s @@ -202,6 +215,34 @@ contentType :: Monad m => S.ByteString -> ActionT m () 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+    status st+    setHeaders [("location", url)]+    stop++-- | redirect with 301 Moved Permanently. since 0.3.3.0.+redirectPermanently :: Monad m => S.ByteString -> ActionT m a+redirectPermanently = redirect movedPermanently301++-- | redirect with 302 Found. since 0.3.3.0.+redirectFound       :: Monad m => S.ByteString -> ActionT m a+redirectFound       = redirect found302++-- | redirect with 303 See Other. since 0.3.3.0.+redirectSeeOther    :: Monad m => S.ByteString -> ActionT m a+redirectSeeOther    = redirect seeOther303++-- | redirect with 307 Temporary Redirect. since 0.3.3.0.+redirectTemporary   :: Monad m => S.ByteString -> ActionT m a+redirectTemporary   = redirect temporaryRedirect307  -- | set body to file content and detect Content-Type by extension. file :: Monad m => FilePath -> Maybe FilePart -> ActionT m ()

@@ -1,9 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}  module Control.Monad.Apiary.Filter     ( method, stdMethod, root-    , ssl, hasQuery+    , ssl+    , hasQuery+    , queryAll, queryAll', queryFirst, queryFirst'     , function, function'     -- * Reexport     , StdMethod(..)@@ -13,27 +17,63 @@ import Network.Wai import Network.HTTP.Types import qualified Data.ByteString as S+import Data.Maybe  import Control.Monad.Apiary.Action.Internal import Control.Monad.Apiary.Internal --- | raw filter function.-function :: Monad m => (c -> Request -> Maybe c') -> ApiaryT c' m a -> ApiaryT c m a+-- | raw and most generic filter function.+function :: Monad m => (SList c -> Request -> Maybe (SList c')) -> ApiaryT c' m b -> ApiaryT c m b function f = focus $ \c -> getRequest >>= \r -> case f c r of     Nothing -> mzero     Just c' -> return c' -function' :: Monad m => (Request -> Bool) -> ApiaryT c m a -> ApiaryT c m a-function' f = function $ \c r -> if f r then Just c else Nothing+-- | filter and append argument.+function' :: Monad m => (Request -> Maybe a) -> ApiaryT (Snoc as a) m b -> ApiaryT as m 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_ f = function $ \c r -> if f r then Just c else Nothing+ ssl :: Monad m => ApiaryT c m a -> ApiaryT c m a-ssl = function' isSecure+ssl = function_ isSecure +-- | filter by query parameter. since 0.4.0.0.+queryAll :: Monad m => S.ByteString+         -> ApiaryT (Snoc as [Maybe S.ByteString]) m b -- ^ Nothing == no value paramator.+         -> ApiaryT as m b+queryAll q = function' $ \r -> case filter ((q ==) . fst) $ queryString r of+    [] -> Nothing+    as -> Just $ map snd as++-- | filter by query parameter. since 0.4.0.0.+queryAll' :: Monad m => S.ByteString+          -> ApiaryT (Snoc as [S.ByteString]) m b +          -> ApiaryT as m b+queryAll' q = function' $ \r -> case mapMaybe snd . filter ((q ==) . fst) $ queryString r of+    [] -> Nothing+    as -> Just as++-- | filter by query parameter. since 0.4.0.0.+queryFirst :: Monad m => S.ByteString+           -> ApiaryT (Snoc as (Maybe S.ByteString)) m b+           -> ApiaryT as m b+queryFirst q = function' (lookup q . queryString)++-- | filter by query parameter. since 0.4.0.0.+queryFirst' :: Monad m => S.ByteString+            -> ApiaryT (Snoc as S.ByteString) m b+            -> ApiaryT as m b+queryFirst' q = function' $ \r -> case mapMaybe snd . filter ((q ==) . fst) $ queryString r of+    []  -> Nothing+    a:_ -> Just a+ hasQuery :: Monad m => S.ByteString -> ApiaryT c m a -> ApiaryT c m a-hasQuery q = function' (any ((q ==) . fst) . queryString)+hasQuery q = function_ (any ((q ==) . fst) . queryString)  method :: Monad m => Method -> ApiaryT c m a -> ApiaryT c m a-method m = function' $ ((m ==) . requestMethod)+method m = function_ ((m ==) . requestMethod)  stdMethod :: Monad m => StdMethod -> ApiaryT c m a -> ApiaryT c m a stdMethod = method . renderStdMethod@@ -42,5 +82,4 @@ root :: Monad m => ApiaryT c m b -> ApiaryT c m b root m = do     rs <- rootPattern `liftM` apiaryConfig-    function (\c r -> if rawPathInfo r `elem` rs then Just c else Nothing) m-+    function_ (\r -> rawPathInfo r `elem` rs) m

@@ -2,6 +2,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}  module Control.Monad.Apiary.Internal where @@ -13,12 +18,32 @@  newtype ApiaryT c m a = ApiaryT { unApiaryT :: forall b.     (forall x . m x -> IO x)-    -> ActionT IO c+    -> ActionT IO (SList c)     -> ApiaryConfig     -> (a -> ActionT IO () -> m b)     -> m b      } +data SList (as :: [*]) where+    SNil  :: SList '[]+    SCons :: a -> SList xs -> SList (a ': xs)++type family Fn (as :: [*]) r+type instance Fn '[] r = r+type instance Fn (x ': xs) r = x -> Fn xs r++type family Snoc (as :: [*]) a :: [*]+type instance Snoc '[] a = '[a]+type instance Snoc (x ': xs) a = x ': Snoc xs a++apply :: Fn xs r -> SList xs -> r+apply v SNil = v+apply f (SCons a as) = apply (f a) as++sSnoc :: SList as -> a -> SList (Snoc as a)+sSnoc SNil         a = SCons a SNil+sSnoc (SCons x xs) a = SCons x $ sSnoc xs a+ 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@@ -39,19 +64,19 @@         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 ()) conf (\_ w -> return w)) >>= \a ->+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  type Apiary c = ApiaryT c IO -runApiary :: ApiaryConfig -> Apiary () a -> Application+runApiary :: ApiaryConfig -> Apiary '[] a -> Application runApiary conf = runApiaryT conf id  getRunner :: Monad m => ApiaryT c m (ActionT m a -> ActionT IO a) getRunner = ApiaryT $ \run _ _ c -> c (hoistActionT run) mempty -getGuard :: ApiaryT c m (ActionT IO c)+getGuard :: ApiaryT c m (ActionT IO (SList c)) getGuard = ApiaryT $ \_ grd _ c -> c grd mempty  apiaryConfig :: ApiaryT c m ApiaryConfig@@ -60,17 +85,20 @@ addRoute :: ActionT IO () -> ApiaryT c m () addRoute r = ApiaryT $ \_ _ _ cont -> cont () r -focus :: Monad m => (c -> ActionT m c') -> ApiaryT c' m b -> ApiaryT c m b+focus :: Monad m => (SList c -> ActionT m (SList c')) -> ApiaryT c' m b -> ApiaryT c m b focus g m = do     tr <- getRunner     ApiaryT $ \run grd cfg cont ->         unApiaryT m run (grd >>= tr . g) cfg cont -action :: Monad m => (c -> ActionT m ()) -> ApiaryT c m ()+action :: Monad m => Fn c (ActionT m ()) -> ApiaryT c m () action a = do     tr  <- getRunner     grd <- getGuard-    addRoute (grd >>= tr . a)+    addRoute $ grd >>= tr . apply a  action_ :: Monad m => ActionT m () -> ApiaryT c m ()-action_ = action . const+action_ a = do+    tr <- getRunner+    grd <- getGuard+    addRoute $ grd >> tr a

@@ -1,5 +1,6 @@ module Web.Apiary.TH-    (capture+    ( capture+    , Param(..)     ) where  import Web.Apiary.TH.Capture

@@ -66,7 +66,7 @@ integralE = litE . integerL . fromIntegral  capture' :: [T.Text] -> ExpQ-capture' cap = [| function $ \_ request -> +capture' cap = [| function $ \ $(varP $ mkName "cont") request ->      $(caseE [|pathInfo request|]          [ match pat   (guards >>= \g -> body >>= \b -> normalB (doE $ g ++ b)) []         , match wildP (normalB  [|mzero|]) []@@ -87,7 +87,8 @@                 bindS (varP . mkName $ v ++ "'")                     [| (readParam $(varE $ mkName v) :: Maybe $(conT ty) ) |])                     $ filter (isType . fst) varNames-            rt = tupE $ map (\(_,v) -> varE $ mkName (v ++ "'")) $ filter (isType . fst) varNames+            rt = foldr (\i b -> varE 'sSnoc `appE` b `appE` i) (varE $ mkName "cont") . reverse .+                map (varE . mkName . (++ "'") . snd) $ filter (isType . fst) varNames         return $ ss ++ [noBindS [| return $rt |]]     lookupType n =  lookupTypeName (T.unpack $ T.tail n) >>= \case         Nothing -> fail $ "capture': type not found: " ++ T.unpack (T.tail n)