apiary 0.3.1.0 → 0.3.2.0

raw patch · 4 files changed

+120/−61 lines, 4 filesdep −mmorphPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: mmorph

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• apiary.cabal +1/−2
• src/Control/Monad/Apiary/Action/Internal.hs +61/−31
• src/Control/Monad/Apiary/Internal.hs +57/−27

@@ -1,4 +1,4 @@-Copyright (c) 2014 philopon+Copyright (c) 2014 Hirotomo Moriwaki  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the

@@ -1,5 +1,5 @@ name:                apiary-version:             0.3.1.0+version:             0.3.2.0 x-revision:          1 synopsis:            Simple web framework inspired by scotty. description:@@ -57,7 +57,6 @@                      , transformers      >=0.3 && <0.5                      , mtl               >=2.1 && <2.3                      , monad-control     >=0.3 && <0.4-                     , mmorph            >=1.0 && <1.1                      , transformers-base >=0.4 && <0.5                       , text               >=1.1 && <1.2

@@ -1,11 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE Rank2Types #-}  module Control.Monad.Apiary.Action.Internal where@@ -14,9 +12,7 @@ import Control.Monad import Control.Monad.Trans import Control.Monad.Base-import Control.Monad.Trans.State.Strict import Control.Monad.Reader-import Control.Monad.Trans.Maybe import Control.Monad.Trans.Control import Network.Wai import Network.Mime@@ -28,7 +24,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import Data.Conduit-import Control.Monad.Morph import qualified Control.Monad.Logger as Logger  data ApiaryConfig = ApiaryConfig@@ -76,21 +71,56 @@     st = actionStatus  as     hd = actionHeaders as -newtype ActionT m a = ActionT-    { unActionT :: ReaderT ApiaryConfig (ReaderT Request (StateT ActionState (MaybeT m))) a -    } deriving (Functor, Applicative, Monad, MonadIO)+newtype ActionT m a = ActionT { unActionT :: forall b. +    ApiaryConfig+    -> Request+    -> ActionState+    -> (a -> ActionState -> m (Maybe b))+    -> m (Maybe 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 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'' ->+        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 Nothing++instance MonadIO m => MonadIO (ActionT m) where+    liftIO m = ActionT $ \_ _ st cont ->+        liftIO m >>= \a -> cont a st+ instance MonadTrans ActionT where-    lift = ActionT . lift . lift . lift . lift+    lift m = ActionT $ \_ _ st cont ->+        m >>= \a -> cont a st -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)+runActionT :: Monad m => ActionT m a+           -> ApiaryConfig -> Request -> ActionState+           -> m (Maybe (a, ActionState))+runActionT m conf req st = unActionT m conf req st $ \a st' ->+    st' `seq` return (Just (a, st')) -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+actionT :: Monad m +        => (ApiaryConfig -> Request -> ActionState -> m (Maybe (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' -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)+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@@ -117,30 +147,32 @@     liftBase = liftBaseDefault  instance MonadTransControl ActionT where-    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+    newtype StT ActionT a = StActionT { unStActionT :: Maybe (a, ActionState) }+    liftWith f = actionT $ \c r s -> +        liftM (\a -> Just (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 MFunctor ActionT where-    hoist nat m = actionT $ \c r s ->-        nat $ runActionT m c r s+    restoreM     = defaultRestoreM unStMT  instance MonadReader r m => MonadReader r (ActionT m) where     ask     = lift ask-    local f = hoist $ local f+    local f = hoistActionT $ local f  instance Logger.MonadLogger m => Logger.MonadLogger (ActionT m) where     monadLoggerLog loc src lv msg = lift $ Logger.monadLoggerLog loc src lv msg  getRequest :: Monad m => ActionT m Request-getRequest = ActionT $ lift ask+getRequest = ActionT $ \_ r s c -> c r s +getConfig :: Monad m => ActionT m ApiaryConfig+getConfig = ActionT $ \c _ s cont -> cont c s++modifyState :: Monad m => (ActionState -> ActionState) -> ActionT m ()+modifyState f = ActionT $ \_ _ s c -> c () (f s)+ -- | 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@@ -155,9 +187,6 @@ 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- status :: Monad m => Status -> ActionT m () status st = modifyState (\s -> s { actionStatus = st } ) @@ -171,12 +200,13 @@ setHeaders hs = modifyHeader (const hs)  contentType :: Monad m => S.ByteString -> ActionT m ()-contentType c = modifyHeader (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)+contentType c = modifyHeader+    (\h -> ("Content-Type", c) : filter (("Content-Type" /=) . fst) h)  -- | 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 <- mimeType <$> getConfig     contentType (mime f)     file' f p 

@@ -1,46 +1,76 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE NoMonomorphismRestriction #-}  module Control.Monad.Apiary.Internal where  import Network.Wai import Control.Applicative-import Control.Monad.Trans-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Reader+import Data.Monoid  import Control.Monad.Apiary.Action.Internal -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)+newtype ApiaryT c m a = ApiaryT { unApiaryT :: forall b.+    (forall x . m x -> IO x)+    -> ActionT IO c+    -> ApiaryConfig+    -> (a -> ActionT IO () -> m b)+    -> m b +    } -type Apiary c = ApiaryT c IO+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 --- TODO: error when add signature-runApiaryT config run (ApiaryT m) =-    execActionT config . execWriter . flip runReaderT config $ runReaderT (runReaderT m run) (return ())+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' ->+        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' -> +        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 ->+    execActionT conf a req++type Apiary c = ApiaryT c IO+ runApiary :: ApiaryConfig -> Apiary () a -> Application-runApiary config = runApiaryT config id+runApiary conf = runApiaryT conf id -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))+getRunner :: Monad m => ApiaryT c m (ActionT m a -> ActionT IO a)+getRunner = ApiaryT $ \run _ _ c -> c (hoistActionT run) mempty -action_ :: ActionT m () -> ApiaryT c m ()-action_ = action . const+getGuard :: ApiaryT c m (ActionT IO c)+getGuard = ApiaryT $ \_ grd _ c -> c grd mempty -action :: (c -> ActionT m ()) -> ApiaryT c m ()+apiaryConfig :: ApiaryT c m ApiaryConfig+apiaryConfig = ApiaryT $ \_ _ c cont -> cont c mempty++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 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 a = do-    tr   <- transActionT `fmap` ApiaryT ask-    ApiaryT $ lift ask >>= \g -> (lift . lift . lift) (tell $ g >>= \c -> tr (a c))+    tr  <- getRunner+    grd <- getGuard+    addRoute (grd >>= tr . a) -apiaryConfig :: ApiaryT c m ApiaryConfig-apiaryConfig = ApiaryT . lift $ lift ask+action_ :: Monad m => ActionT m () -> ApiaryT c m ()+action_ = action . const