refresht (empty) → 0.1.0.0
raw patch · 6 files changed
+352/−0 lines, 6 filesdep +basedep +data-defaultdep +exceptionssetup-changed
Dependencies added: base, data-default, exceptions, lens, mtl, refresht
Files
- LICENSE +30/−0
- README.md +70/−0
- Setup.hs +2/−0
- app/Main.hs +28/−0
- refresht.cabal +50/−0
- src/Control/Monad/Refresh.hs +172/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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 ())
+ refresht.cabal view
@@ -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
+ src/Control/Monad/Refresh.hs view
@@ -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' }