{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.DO.Droplets.Net(dropletCommandsInterpreter) where
import Control.Applicative
import Control.Comonad.Env.Class (ComonadEnv, ask)
import Control.Exception (IOException)
import Control.Monad.Trans (MonadIO)
import Data.Aeson as A hiding (Result)
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as H
import Data.Maybe
import Data.Monoid ((<>))
import Data.Proxy
import Network.DO.Droplets.Commands
import Network.DO.Droplets.Utils
import Network.DO.Net.Common
import Network.DO.Types as DO hiding (URI)
import Network.REST
import Network.Wreq hiding (Proxy)
import Prelude as P hiding (error)
dropletsURI :: String
dropletsURI = "droplets"
dropletsEndpoint :: String
dropletsEndpoint = rootURI </> apiVersion </> dropletsURI
instance Listable Droplet where
listEndpoint _ = dropletsEndpoint
listField _ = "droplets"
doListSnapshots :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m [Image], w a)
doListSnapshots w dropletId =
maybe (return [], w)
(\ t -> let snapshots = toList "snapshots" <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "snapshots")
in (snapshots, w))
(authToken (ask w))
dropletFromResponse :: Either String Value -> Result Droplet
dropletFromResponse (Right (Object b)) = either error (Right . id) $ A.parseEither parseJSON (b H.! "droplet")
dropletFromResponse v = error $ "cannot decode JSON value to a droplet " ++ show v
doCreate :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> BoxConfiguration -> (RESTT m (Result Droplet), w a)
doCreate w config = maybe (return $ error "no authentication token defined", w)
runQuery
(authToken (ask w))
where
runQuery t = let opts = authorisation t
droplets = postJSONWith opts (toURI dropletsEndpoint) (toJSON config) >>= handleResponse
handleResponse d = case dropletFromResponse d of
Right b -> if (not $ backgroundCreate config)
then waitForBoxToBeUp opts 60 b
else return (Right b)
err -> return err
in (droplets, w)
doDestroyDroplet :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Maybe String), w a)
doDestroyDroplet w dropletId = maybe (return $ Just "no authentication token defined", w)
(\ t -> let r = deleteJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId) >> return Nothing
in (r, w))
(authToken (ask w))
actionResult :: Either String Value -> Result ActionResult
actionResult (Right (Object r)) = either error (Right . id) $ A.parseEither parseJSON (r H.! "action")
actionResult e = error $ "cannot extract action result from " ++ show e
doAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Action -> (RESTT m (Result ActionResult), w a)
doAction w dropletId action = maybe (return $ error "no authentication token defined", w)
(\ t -> let r = postJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions") (toJSON action)
>>= return . actionResult
in (r, w))
(authToken (ask w))
doGetAction :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> Id -> (RESTT m (Result ActionResult), w a)
doGetAction w dropletId actionId = maybe (return $ error "no authentication token defined", w)
(\ t -> let r = getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId </> "actions" </> show actionId)
>>= return . actionResult . Right
in (r, w))
(authToken (ask w))
doShowDroplet :: (ComonadEnv ToolConfiguration w, Monad m) => w a -> Id -> (RESTT m (Result Droplet), w a)
doShowDroplet w dropletId = maybe (return $ error "no authentication token defined", w)
(\ t -> let r = dropletFromResponse . Right <$> getJSONWith (authorisation t) (toURI $ dropletsEndpoint </> show dropletId)
in (r, w))
(authToken (ask w))
doSshInDroplet :: (MonadIO m) => w a -> Droplet -> (RESTT m (Result ()), w a)
doSshInDroplet w droplet = let r = maybe (return $ error ("droplet " <> show droplet <> " has no public IP"))
(\ip -> do
s <- ssh ["root@" <> show ip ]
case s of
Left (e :: IOException) -> return $ error (show e)
Right () -> return $ Right ()
)
(publicIP droplet)
in (r, w)
waitForBoxToBeUp :: (Monad m) => Options -> Int -> Droplet -> RESTT m (Result Droplet)
waitForBoxToBeUp _ 0 box = return (Right box)
waitForBoxToBeUp opts n box = do
waitFor 1000000 ("waiting for droplet " ++ name box ++ " to become Active: " ++ show (n) ++ "s")
b <- getJSONWith opts (toURI $ dropletsEndpoint </> show (dropletId box))
case dropletFromResponse (Right b) of
Right box'-> if status box' == Active
then return (Right box')
else waitForBoxToBeUp opts (n-1) box'
err -> return err
dropletCommandsInterpreter :: (MonadIO m, ComonadEnv ToolConfiguration w) => w a -> CoDropletCommands (RESTT m) (w a)
dropletCommandsInterpreter = CoDropletCommands
<$> queryList (Proxy :: Proxy Droplet)
<*> doCreate
<*> doDestroyDroplet
<*> doAction
<*> doGetAction
<*> doListSnapshots
<*> doSshInDroplet
<*> doShowDroplet