module Network.Goggles.Cloud (
Cloud(..)
, evalCloudIO
, liftCloudIO
, HasCredentials(..)
, Token(..)
, accessToken
, refreshToken
, Handle(..)
, createHandle
) where
import Control.Applicative (Alternative(..))
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Reader
import qualified Control.Monad.Trans.Reader as RT (ask, local)
import Crypto.Random.Types (MonadRandom(..))
import Crypto.Random.Entropy (getEntropy)
import Control.Exception (AsyncException, fromException)
import Control.Concurrent.STM
import Data.Time
import Network.Goggles.Control.Exceptions
class HasCredentials c where
type Credentials c
type Options c
type TokenContent c
tokenFetch :: Cloud c (Token c)
data Token c = Token {
tToken :: TokenContent c
, tTime :: UTCTime
}
data Handle c = Handle {
credentials :: Credentials c
, token :: TVar (Maybe (Token c))
, options :: Options c
}
cacheToken ::
HasCredentials c => Token c -> Cloud c (Token c)
cacheToken tok = do
tv <- asks token
liftCloudIO $ atomically $ do
current <- readTVar tv
let new = case current of
Nothing -> tok
Just t -> if tTime t > tTime tok then t else tok
writeTVar tv (Just new)
return new
refreshToken :: HasCredentials c => Cloud c (Token c)
refreshToken = tokenFetch >>= cacheToken
accessToken :: HasCredentials c => Cloud c (TokenContent c)
accessToken = do
tokenTVar <- asks token
mbToken <- liftCloudIO $ atomically $ readTVar tokenTVar
tToken <$> case mbToken of
Nothing -> refreshToken
Just t -> do
now <- liftCloudIO $ getCurrentTime
if now > addUTCTime ( 60) (tTime t)
then refreshToken
else return t
createHandle :: HasCredentials c => Credentials c -> Options c -> IO (Handle c)
createHandle sa opts = Handle <$> pure sa <*> newTVarIO Nothing <*> pure opts
newtype Cloud c a = Cloud {
runCloud :: ReaderT (Handle c) IO a
} deriving (Functor, Applicative, Monad)
instance HasCredentials c => Alternative (Cloud c) where
empty = throwM $ UnknownError "empty"
a1 <|> a2 = do
ra <- try a1
case ra of
Right x -> pure x
Left e -> case (fromException e) :: Maybe CloudException of
Just _ -> a2
Nothing -> throwM (UnknownError "Uncaught exception (not a CloudException)")
liftCloudIO_ :: IO a -> Cloud c a
liftCloudIO_ m = Cloud $ ReaderT (const m)
liftCloudIO :: HasCredentials c => IO a -> Cloud c a
liftCloudIO m = do
liftCloudIO_ m `catch` \e -> case fromException e of
Just asy -> throwM (asy :: AsyncException)
Nothing -> throwM $ IOError (show e)
evalCloudIO :: Handle c -> Cloud c a -> IO a
evalCloudIO r (Cloud b) = runReaderT b r `catch` \e -> case (e :: CloudException) of
ex -> throwM ex
instance HasCredentials c => MonadIO (Cloud c) where
liftIO = liftCloudIO
instance HasCredentials c => MonadThrow (Cloud c) where
throwM = liftIO . throwM
instance HasCredentials c => MonadCatch (Cloud c) where
catch (Cloud (ReaderT m)) c =
Cloud $ ReaderT $ \r -> m r `catch` \e -> runReaderT (runCloud $ c e) r
instance HasCredentials c => MonadRandom (Cloud c) where
getRandomBytes = liftIO . getEntropy
instance HasCredentials c => MonadReader (Handle c) (Cloud c) where
ask = Cloud RT.ask
local f m = Cloud $ RT.local f (runCloud m)