module Web.Apiary.Heroku
( Heroku, HerokuConfig(..)
, heroku, herokuWith
, getHerokuEnv, getHerokuEnv'
) where
import System.Environment
import System.Process
import System.Exit
import Control.Exception
import Control.Arrow hiding (app)
import Control.Applicative
import Control.Monad.Trans
import Data.IORef
import Data.Proxy
import Data.Default.Class
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Network.Wai
import Control.Monad.Apiary
import Data.Apiary.Extension
import Data.Apiary.Extension.Internal
data Heroku = Heroku
{ herokuEnv :: IORef (Maybe (H.HashMap T.Text T.Text))
, herokuConfig :: HerokuConfig
}
data HerokuConfig = HerokuConfig
{ defaultPort :: Int
, herokuExecutableName :: String
, herokuAppName :: Maybe String
}
instance Default HerokuConfig where
def = HerokuConfig 3000 "heroku" Nothing
initHeroku :: MonadIO m => HerokuConfig -> Initializer' m Heroku
initHeroku conf = initializer' . liftIO $
Heroku <$> newIORef Nothing <*> pure conf
herokuWith :: MonadIO m => Initializer m '[Heroku] exts
-> (Int -> Application -> m a)
-> HerokuConfig -> EApplication exts m -> m a
herokuWith ir run conf eapp = ir' NoExtension $ \exts -> do
port <- liftIO $ fmap read (getEnv "PORT")
`catch` (\(_::IOError) -> return $ defaultPort conf)
app <- eapp exts
run port app
where
Initializer ir' = initHeroku conf +> ir
heroku :: MonadIO m => (Int -> Application -> m a)
-> HerokuConfig -> EApplication '[Heroku] m -> m a
heroku = herokuWith noExtension
getHerokuEnv' :: T.Text -> Heroku -> IO (Maybe T.Text)
getHerokuEnv' key Heroku{..} = try (getEnv $ T.unpack key) >>= \case
Right e -> return (Just $ T.pack e)
Left (_::SomeException) -> readIORef herokuEnv >>= \case
Just hm -> return $ H.lookup key hm
Nothing -> do
let args = ["config", "-s"] ++
maybe [] (\n -> ["--app", n]) (herokuAppName herokuConfig)
cp = proc (herokuExecutableName herokuConfig) args
(_, Just hout, _, h) <- createProcess cp {std_out = CreatePipe}
xc <- waitForProcess h
if xc == ExitSuccess
then do
hm <- H.fromList . map (second T.tail . T.break (== '=')) . T.lines
<$> T.hGetContents hout
writeIORef herokuEnv (Just hm)
return $ H.lookup key hm
else Nothing <$ writeIORef herokuEnv (Just H.empty)
getHerokuEnv :: Has Heroku exts => T.Text -> Extensions exts -> IO (Maybe T.Text)
getHerokuEnv key exts = getHerokuEnv' key (getExtension Proxy exts)