module Network.Goggles.Cloud (
WebApiM(..)
, evalWebApiIO
, liftWebApiIO
, HasCredentials(..)
, HasToken(..)
, 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
class HasToken c where
type TokenContent c
type Options c
tokenFetch :: WebApiM 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
}
newtype WebApiM c a = WebApiM {
runWebApiM :: ReaderT (Handle c) IO a
} deriving (Functor, Applicative, Monad)
instance HasCredentials c => Alternative (WebApiM 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)")
liftWebApiIO_ :: IO a -> WebApiM c a
liftWebApiIO_ m = WebApiM $ ReaderT (const m)
liftWebApiIO :: IO a -> WebApiM c a
liftWebApiIO m =
liftWebApiIO_ m `catch` \e -> case fromException e of
Just asy -> throwM (asy :: AsyncException)
Nothing -> throwM $ IOError (show e)
evalWebApiIO :: Handle c -> WebApiM c a -> IO a
evalWebApiIO r (WebApiM b) = runReaderT b r `catch` \e -> case (e :: CloudException) of
ex -> throwM ex
instance MonadIO (WebApiM c) where
liftIO = liftWebApiIO
instance MonadThrow (WebApiM c) where
throwM = liftIO . throwM
instance MonadCatch (WebApiM c) where
catch (WebApiM (ReaderT m)) c =
WebApiM $ ReaderT $ \r -> m r `catch` \e -> runReaderT (runWebApiM $ c e) r
instance MonadRandom (WebApiM c) where
getRandomBytes = liftIO . getEntropy
instance MonadReader (Handle c) (WebApiM c) where
ask = WebApiM RT.ask
local f m = WebApiM $ RT.local f (runWebApiM m)
cacheToken ::
HasToken c => Token c -> WebApiM c (Token c)
cacheToken tok = do
tv <- asks token
liftWebApiIO $ 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 :: HasToken c => WebApiM c (Token c)
refreshToken = tokenFetch >>= cacheToken
accessToken :: (HasToken c) => WebApiM c (TokenContent c)
accessToken = do
tokenTVar <- asks token
mbToken <- liftWebApiIO $ atomically $ readTVar tokenTVar
tToken <$> case mbToken of
Nothing -> refreshToken
Just t -> do
now <- liftWebApiIO 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