apiary 0.1.0.1 → 0.2.0.0

raw patch · 5 files changed

+69/−54 lines, 5 filesdep −aesonPVP ok

version bump matches the API change (PVP)

Dependencies removed: aeson

API changes (from Hackage documentation)

Files

• apiary.cabal +3/−4
• src/Control/Monad/Apiary.hs +2/−0
• src/Control/Monad/Apiary/Action.hs +2/−2
• src/Control/Monad/Apiary/Action/Internal.hs +34/−34
• src/Control/Monad/Apiary/Internal.hs +28/−14

@@ -1,5 +1,5 @@ name:                apiary-version:             0.1.0.1+version:             0.2.0.0 x-revision:          1 synopsis:            Simple web framework inspired by scotty. description:@@ -14,10 +14,10 @@   import qualified Data.ByteString.Lazy.Char8 as L   .   main :: IO ()-  main = run 3000 . runApiaryT def $ do+  main = run 3000 . runApiary def $ do   &#32;&#32;[capture|/:String|] $ do   &#32;&#32;&#32;&#32;stdMethod GET . action $ \\name -> do-  &#32;&#32;&#32;&#32;&#32;&#32;contentType "text/html"+  &#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;]   @   .@@ -69,7 +69,6 @@                      , blaze-builder     >=0.3 && <0.4                      , conduit           >=1.1 && <1.2                      , data-default      >=0.5 && <0.6-                     , aeson             >=0.7 && <0.8                       , http-types        >=0.8 && <0.9                      , mime-types        >=0.1 && <0.2

@@ -1,5 +1,7 @@ module Control.Monad.Apiary     ( ApiaryT+    , Apiary+    , runApiary     , runApiaryT     -- * getter     , apiaryConfig

@@ -1,11 +1,12 @@ module Control.Monad.Apiary.Action      (       ActionT-    , ApplicationM     , ApiaryConfig(..)     -- * actions     -- ** getter     , getRequest+    , getQuery, getQuery'+    , getRequestHeader, getRequestHeader'     -- ** setter     , status     -- *** response header@@ -17,7 +18,6 @@     , builder     , lbs     , source-    , json     -- * Reexport     , def     ) where

@@ -6,6 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE CPP #-}  module Control.Monad.Apiary.Action.Internal where@@ -28,16 +29,15 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Data.Conduit-import Data.Aeson import Control.Monad.Morph  #ifdef DefineMonadLoggerInstance import qualified Control.Monad.Logger as Logger #endif -data ApiaryConfig m = ApiaryConfig+data ApiaryConfig = ApiaryConfig     { -- | call when no handler matched.-      notFound      :: ApplicationM m +      notFound      :: Application       -- | used unless call 'status' function.     , defaultStatus :: Status       -- | initial headers.@@ -47,17 +47,7 @@     , mimeType      :: FilePath -> S.ByteString     } -data ApiaryConfig' = ApiaryConfig'-    { defaultStatus' :: Status-    , defaultHeader' :: ResponseHeaders-    , rootPattern'   :: [S.ByteString]-    , mimeType'      :: FilePath -> S.ByteString-    }--subConfig :: ApiaryConfig m -> ApiaryConfig'-subConfig (ApiaryConfig _ a b c d) = ApiaryConfig' a b c d--instance Monad m => Default (ApiaryConfig m) where+instance Default ApiaryConfig where     def = ApiaryConfig          { notFound = \_ -> return $ responseLBS status404              [("Content-Type", "text/plain")] "404 Page Notfound."@@ -67,13 +57,12 @@         , mimeType      = defaultMimeLookup . T.pack         } -type ApplicationM m = Request -> m Response--data ActionState = ActionState-    { actionStatus  :: Status-    , actionHeaders :: ResponseHeaders-    , actionBody    :: Body-    }+data ActionState +    = ActionState+        { actionStatus  :: Status+        , actionHeaders :: ResponseHeaders+        , actionBody    :: Body+        }  data Body      = File FilePath (Maybe FilePart)@@ -92,20 +81,23 @@     hd = actionHeaders as  newtype ActionT m a = ActionT-    { unActionT :: ReaderT ApiaryConfig' (ReaderT Request (StateT ActionState (MaybeT m))) a +    { unActionT :: ReaderT ApiaryConfig (ReaderT Request (StateT ActionState (MaybeT m))) a      } deriving (Functor, Applicative, Monad, MonadIO)  instance MonadTrans ActionT where     lift = ActionT . lift . lift . lift . lift -runActionT :: ActionT m a -> ApiaryConfig' -> Request -> ActionState -> m (Maybe (a, ActionState))+runActionT :: ActionT m a -> ApiaryConfig -> Request -> ActionState -> m (Maybe (a, ActionState)) runActionT (ActionT m) config request st = runMaybeT (runStateT (runReaderT (runReaderT m config) request) st) -actionT :: (ApiaryConfig' -> Request -> ActionState -> m (Maybe (a, ActionState))) -> ActionT m a+actionT :: (ApiaryConfig -> Request -> ActionState -> m (Maybe (a, ActionState))) -> ActionT m a actionT f = ActionT . ReaderT $ \c -> ReaderT $ \r -> StateT $ \s -> MaybeT $ f c r s -execActionT :: Monad m => ApiaryConfig m -> ActionT m () -> (ApplicationM m)-execActionT config m request = runActionT m (subConfig config) request resp >>= \case+transActionT :: (forall b. m b -> IO b) -> ActionT m a -> ActionT IO a+transActionT 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         Nothing    -> notFound config request         Just (_,r) -> return $ actionStateToResponse r   where@@ -129,7 +121,7 @@     liftBase = liftBaseDefault  instance MonadTransControl ActionT where-    newtype StT ActionT a = StAction { unStAction :: StT MaybeT (StT (StateT ActionState) (StT (ReaderT Request) (StT (ReaderT ApiaryConfig') a))) }+    newtype StT ActionT a = StAction { unStAction :: StT MaybeT (StT (StateT ActionState) (StT (ReaderT Request) (StT (ReaderT ApiaryConfig) a))) }     liftWith f = ActionT $ liftWith $ \run -> liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' ->          f $ liftM StAction . run''' . run'' . run' . run . unActionT     restoreT = ActionT . restoreT . restoreT . restoreT . restoreT . liftM unStAction@@ -155,6 +147,20 @@ getRequest :: Monad m => ActionT m Request getRequest = ActionT $ lift ask +-- | when request header is not found, mzero(pass next handler).+getRequestHeader' :: Monad m => HeaderName -> ActionT m S.ByteString+getRequestHeader' h = getRequestHeader h >>= maybe mzero return++getRequestHeader :: Monad m => HeaderName -> ActionT m (Maybe S.ByteString)+getRequestHeader h = (lookup h . requestHeaders) `liftM` getRequest++-- | when query parameter is not found, mzero(pass next handler).+getQuery' :: Monad m => S.ByteString -> ActionT m (Maybe S.ByteString)+getQuery' q = getQuery q >>= maybe mzero return++getQuery :: Monad m => S.ByteString -> ActionT m (Maybe (Maybe S.ByteString))+getQuery q = (lookup q . queryString) `liftM` getRequest+ modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m () modifyState f = ActionT . lift . lift $ modify f @@ -176,7 +182,7 @@ -- | set body to file content and detect Content-Type by extension. file :: Monad m => FilePath -> Maybe FilePart -> ActionT m () file f p = do-    mime <- ActionT $ asks mimeType'+    mime <- ActionT $ asks mimeType     contentType (mime f)     file' f p @@ -191,9 +197,3 @@  source :: Monad m => Source IO (Flush Builder) -> ActionT m () source src = modifyState (\s -> s { actionBody = SRC src } )---- | set body to j and set Content-Type to \"application/json\"-json :: (ToJSON j, Monad m) => j -> ActionT m ()-json j = do-    contentType "application/json"-    lbs $ encode j

@@ -1,7 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Control.Monad.Apiary.Internal where +import Network.Wai import Control.Applicative import Control.Monad.Trans import Control.Monad.Trans.Writer@@ -9,24 +13,34 @@  import Control.Monad.Apiary.Action.Internal -newtype ApiaryT c m a = ApiaryT { unApiaryT :: ReaderT (ActionT m c) (ReaderT (ApiaryConfig m) (Writer (ActionT m ()))) a }-    deriving (Functor, Applicative, Monad)+newtype ApiaryT c m a = ApiaryT { unApiaryT ::+         ReaderT (forall b. m b -> IO b) +        (ReaderT (ActionT IO c) +        (ReaderT ApiaryConfig+        (Writer  (ActionT IO ())))) a +    } deriving (Functor, Applicative, Monad) -runApiaryT' :: Monad m => ApiaryConfig m -> ApiaryT c m a -> ActionT m c -> ApplicationM m-runApiaryT' config (ApiaryT m) = execActionT config . execWriter . flip runReaderT config . runReaderT m+type Apiary c = ApiaryT c IO -runApiaryT :: Monad m => ApiaryConfig m -> ApiaryT () m a -> ApplicationM m-runApiaryT conf m = runApiaryT' conf m $ return ()+-- TODO: error when add signature+runApiaryT config run (ApiaryT m) =+    execActionT config . execWriter . flip runReaderT config $ runReaderT (runReaderT m run) (return ()) -apiaryConfig :: Monad m => ApiaryT c m (ApiaryConfig m)-apiaryConfig = ApiaryT $ lift ask+runApiary :: ApiaryConfig -> Apiary () a -> Application+runApiary config = runApiaryT config id -focus :: Monad m => (c -> ActionT m c') -> ApiaryT c' m a -> ApiaryT c m a-focus f (ApiaryT m) = ApiaryT . ReaderT $ \c -> runReaderT m (c >>= f)+focus :: (c -> ActionT m c') -> ApiaryT c' m b -> ApiaryT c m b+focus f (ApiaryT m) = do+    tr <- transActionT `fmap` ApiaryT ask+    ApiaryT . ReaderT $ \r -> ReaderT $ \c -> runReaderT (runReaderT m r) (c >>= \a -> tr (f a)) -action_ :: Monad m => ActionT m () -> ApiaryT c m ()-action_ a = action (const a)+action_ :: ActionT m () -> ApiaryT c m ()+action_ = action . const -action :: Monad m => (c -> ActionT m ()) -> ApiaryT c m ()-action a = ApiaryT $ ask >>= \g -> (lift . lift) (tell $ g >>= a)+action :: (c -> ActionT m ()) -> ApiaryT c m ()+action a = do+    tr   <- transActionT `fmap` ApiaryT ask+    ApiaryT $ lift ask >>= \g -> (lift . lift . lift) (tell $ g >>= \c -> tr (a c)) +apiaryConfig :: ApiaryT c m ApiaryConfig+apiaryConfig = ApiaryT . lift $ lift ask