diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Hiromi ISHII (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hiromi ISHII nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,70 @@ +RefreshT -- Environment Monad with automatic resource refreshment +================================================================== + +Overview +-------- +`refresht` package provides similar interface as `ReaderT`-monad, +but it comes with *automatic refreshment* mechanism. +In other words, the `RefreshT` monad transformer provides the +general way to maintain the *freshness* of the external environment, +with respoec to the specified condition or exceptions. + +The typical usage is to communicate with the server which requires +periodic refreshment of access tokens, such as Google API. + +Usage +----- +The following pseudo-code illustrates the typical usage: + +```haskell +import Control.Monad.Refresh + +import Network.Wreq (getWith, defaults) +import Control.Lens ((&), (.~), (^.)) +import Data.Time (addUTCTime, getCurrentTime, UTCTime) +import Data.ByetString.Lazy.Char8 (unpack) +import Control.Exception (fromException) + +data User = User { expiration :: UTCTime + , accessToken :: String + } + +main :: IO () +main = do + time <- getCurrentTime + evalRefreshT conf (User (3600 `addUTCTime` time) "initialtoken") $ do + rsc <- withEnv $ \User{..} -> + getWith (defaults & auth .~ oauth2Bearer accessToken) + "https://example.com/api/resource" + putStrLn $ print rsc + +conf :: RefreshSetting User IO +conf = defaultRefreshSetting + & refresher .~ update + & shouldRefresh .~ checkExpr + & isRefreshingError .~ isRefreshing + where + shouldRefresh usr = do -- checks expiration + now <- getCurrentTime + return $ now <= expiration usr + + update usr = do + -- Refreshed token for the service + bdy <- getWith + (defaults & param "token" .~ [accessToken usr]) + "https://example.com/api/refresh_token" + let token = unpack $ bdy ^. responseBody + usr' = usr { accessToken = token + , expiration = ... + } + + -- Save updates in local file, or db. + writeFile "database" (show usr') + return usr' + + -- 401 Unauthorized exception should cause refreshment + isRefreshing e = + case fromException e of + Just Error401 -> True + _ -> False +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveAnyClass #-} +module Main where +import Control.Exception +import Control.Lens +import Control.Monad +import Control.Monad.Refresh +import Data.Default +import Data.IORef +import Data.Typeable + +data RefreshNow = RefreshNow + deriving (Eq, Show, Typeable, Exception) + +conf :: RefreshSetting Int IO +conf = def & isRefreshingError .~ ((== Just RefreshNow) . fromException) + & shouldRefresh .~ const (return False) + & refresher .~ (return . succ) + & refreshDelay .~ (10 ^ 5) + +main :: IO () +main = do + ref <- newIORef True + let conf' = conf & refresher .~ \a -> do + writeIORef ref False + return (succ a) + print =<< runRefreshT conf 0 (return ()) + print =<< runRefreshT conf 0 (atomicLift $ return ()) + print =<< runRefreshT conf' 0 (atomicLift $ do (throw RefreshNow); return ()) diff --git a/refresht.cabal b/refresht.cabal new file mode 100644 --- /dev/null +++ b/refresht.cabal @@ -0,0 +1,50 @@ +name: refresht +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/konn/refresht#readme +license: BSD3 +license-file: LICENSE +author: Hiromi ISHII +maintainer: konn.jinro _at_ gmail.com +copyright: 2015 (c) Hiromi ISHII +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Control.Monad.Refresh + build-depends: base >= 4.7 && < 5 + , mtl + , data-default + , lens + , exceptions + default-language: Haskell2010 + +executable example + buildable: False + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , refresht + , mtl + , data-default + , lens + , exceptions + default-language: Haskell2010 + +-- test-suite refresht-test +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Spec.hs +-- build-depends: base +-- , refresht +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N +-- default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/konn/refresht diff --git a/src/Control/Monad/Refresh.hs b/src/Control/Monad/Refresh.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Refresh.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-} +module Control.Monad.Refresh + ( -- * @'RefreshT'@ type and settings + RefreshT, runRefreshT, evalRefreshT + , -- ** Settings for Refreshing + RefreshSetting + , defaultRefreshSetting + , refresher + -- | Environment refreshing function (default: @return@). + -- + -- Since 0.1.0.0 + , refreshDelay + -- | Delay in microseconds before environmental refreshment (default: @100ms@). + -- + -- Since 0.1.0.0 + , shouldRefresh + -- | Condition to determine if environment should be refreshed (default: @const True@). + -- + -- Since 0.1.0.0 + , isRefreshingError + -- | If this exception should occur an envionment refreshment? (default: refresh for any exception). + -- + -- Since 0.1.0.0 + , -- * Transaction Combinators + atomic + , atomicLift + , atomicLiftIO + , withEnv + , refresh + ) where +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException (..)) +import Control.Lens (makeLenses, view, (^.)) +import Control.Monad.Catch (MonadCatch (..), catchIf) +import Control.Monad.RWS (MonadTrans (..), RWST (..), ask, evalRWST, get, + gets) +import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), modify, runRWST) +import Data.Default (Default (..)) +import Data.Typeable (Typeable) + +-- | Settings for Refreshment +-- +-- Since 0.1.0.0 +data RefreshSetting s m = + RefreshSetting { _refresher :: s -> m s + , _refreshDelay :: Int + , _isRefreshingError :: SomeException -> Bool + , _shouldRefresh :: s -> m Bool + } + deriving (Typeable) + +-- | Since 0.1.0.0 +instance Monad m => Default (RefreshSetting s m) where + def = RefreshSetting return (10 ^ 5) (const True) (const $ return True) + +defaultRefreshSetting :: Monad m => RefreshSetting s m +defaultRefreshSetting = def + +makeLenses ''RefreshSetting + +data Localed a = Localed { modifier :: !(a -> a) + , original :: !a + } + +runLocaled :: forall t. Localed t -> t +runLocaled (Localed f a) = f a + +-- | Reader monad transformer with an automatic environment refreshment. +-- +-- Since 0.1.0.0 +newtype RefreshT s m a = + RefreshT { runRefreshT_ :: RWST (RefreshSetting s m) () (Localed s) m a } + deriving (Functor, Applicative, Monad) + +-- | N.B. The @'lift'@ combinator doesn't care about exceptions; +-- this is the intended behaviour, because @'lift'@ doesn't +-- come with any atomicity meaning. +-- If you want to trigger refresh after exceptions, use @'atomicLift'@. +-- +-- Since 0.1.0.0 +instance MonadTrans (RefreshT s) where + lift = RefreshT . lift + +-- | N.B. The @'liftIO'@ combinator doesn't care about exceptions; +-- this is the intended behaviour, because @'liftIO'@ doesn't +-- come with any atomicity meaning. +-- If you want to trigger refresh after exceptions, use @'atomicLiftIO'@. +-- +-- Since 0.1.0.0 +instance (MonadIO m) => MonadIO (RefreshT s m) where + liftIO = RefreshT . liftIO + +-- | Try an atomic transaction and, +-- if exceptions specified by @'isRefreshingError'@ has been raised, +-- refreshes the environment and redo the entire transaction. +-- +-- Since 0.1.0.0 +atomic :: (MonadIO m, MonadCatch m) => RefreshT s m a -> RefreshT s m a +atomic (RefreshT act) = RefreshT $ view isRefreshingError >>= loop + where + loop chk = + catchIf + chk act $ const $ runRefreshT_ refresh >> loop chk + +-- | @'atomicLift' = 'atomic' . 'lift'@. +-- +-- Since 0.1.0.0 +atomicLift :: (MonadIO m, MonadCatch m) => m a -> RefreshT s m a +atomicLift = atomic . lift + +-- | @'atomicLiftIO' = 'atomic' . 'liftIO'@. +-- +-- Since 0.1.0.0 +atomicLiftIO :: (MonadIO m, MonadCatch m) => IO a -> RefreshT s m a +atomicLiftIO = atomic . liftIO + +-- | @'atomicLift'@ composed with @'Control.Monad.Reader.ask'@. +-- +-- Since 0.1.0.0 +withEnv :: (MonadIO m, MonadCatch m) => (s -> m a) -> RefreshT s m a +withEnv act = atomic $ lift . act =<< ask + +-- | Excecute environmental computation and returns the result with the final environment. +-- +-- Since 0.1.0.0 +runRefreshT :: MonadCatch m => RefreshSetting s m -> s -> RefreshT s m a -> m (a, s) +runRefreshT st s act = do + (a, s', _) <- runRWST (runRefreshT_ act) st (Localed id s) + return (a, original s') + +-- | Excecute environmental computation and returns the result, discarding the final environment. +-- +-- Since 0.1.0.0 +evalRefreshT :: MonadCatch m => RefreshSetting s m -> s -> RefreshT s m a -> m a +evalRefreshT st s act = fst <$> evalRWST (runRefreshT_ act) st (Localed id s) + +-- | N.B. The refreshed result took place inside @'local'@ +-- will be reflected outside. +-- +-- Since 0.1.0.0 +instance MonadIO m => MonadReader s (RefreshT s m) where + local f (RefreshT act) = RefreshT $ do + old <- gets modifier + modify $ \ls -> ls { modifier = f . old } + a <- act + modify (\ls -> ls {modifier = old}) + return a + ask = RefreshT $ do + test <- view shouldRefresh + goRefl <- lift . test =<< gets runLocaled + if goRefl + then do + st <- ask + liftIO $ threadDelay (st ^. refreshDelay) + s' <- lift . (st ^. refresher) =<< gets original + modify $ \ls -> ls { original = s' } + f <- gets modifier + return $! f s' + else gets runLocaled + +-- | Forces environmental refreshment, regardless of @'shouldRefresh'@ condition. +-- +-- Since 0.1.0.0 +refresh :: MonadIO m => RefreshT s m () +refresh = RefreshT $ do + st <- ask + liftIO $ threadDelay (st ^. refreshDelay) + s' <- lift . (st ^. refresher) =<< gets original + modify $ \ls -> ls { original = s' }