hdo (empty) → 0.1
raw patch · 20 files changed
+1735/−0 lines, 20 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, comonad, data-default, free, hdo, iproute, lens, mtl, network-uri, optparse-applicative, pretty, process, random, tagged, text, time, transformers, unix, unordered-containers, vector, wreq
Files
- LICENSE +21/−0
- README.md +8/−0
- Setup.hs +2/−0
- hdo.cabal +72/−0
- main/hdo.hs +128/−0
- src/Network/DO/Commands.hs +44/−0
- src/Network/DO/Droplets/Commands.hs +80/−0
- src/Network/DO/Droplets/Net.hs +127/−0
- src/Network/DO/Droplets/Utils.hs +26/−0
- src/Network/DO/Names.hs +317/−0
- src/Network/DO/Net.hs +73/−0
- src/Network/DO/Net/Common.hs +53/−0
- src/Network/DO/Pairing.hs +79/−0
- src/Network/DO/Pretty.hs +89/−0
- src/Network/DO/Types.hs +493/−0
- src/Network/REST.hs +11/−0
- src/Network/REST/Commands.hs +44/−0
- src/Network/REST/Wreq.hs +54/−0
- src/Network/SSH.hs +10/−0
- stack.yaml +4/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 Capital Match Platform Pte. Ltd.++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,8 @@+## HDO: A HAskell Digital Ocean Client ##++[](https://travis-ci.org/capital-match/hdo)++**WARNING** This implementation still covers only a small subset of DO API++This is a [Digital Ocean](https://www.digitalocean.com/) client written in [Haskell](http://haskell.org). It can be used either as a+library or as command-line utility.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdo.cabal view
@@ -0,0 +1,72 @@+Name: hdo+Version: 0.1+Cabal-Version: >= 1.18+Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com>+Author: Arnaud Bailly+Build-Type: Simple+Category: Cloud+License: MIT+License-File: LICENSE+Description:++ HDO is a client to <https://www.digitalocean.com/ Digital Ocean> API. It can either+ be used as a library embedded in other tools or as a command-line client (@docean@).++Synopsis: A Digital Ocean client in Haskell+Extra-Source-Files:+ README.md, stack.yaml, LICENSE++Library+ Default-Language: Haskell2010+ GHC-Options: -Wall -fno-warn-orphans+ Hs-Source-Dirs: src+ Other-Modules: Network.REST.Commands, Network.REST.Wreq, Network.SSH+ exposed-modules: Network.DO.Commands+ , Network.DO.Types+ , Network.DO.Net, Network.DO.Net.Common+ , Network.DO.Droplets.Commands, Network.DO.Droplets.Net, Network.DO.Droplets.Utils+ , Network.DO.Names, Network.DO.Pairing+ , Network.REST, Network.DO.Pretty+ Build-Depends: aeson+ , base < 5+ , bytestring+ , comonad+ , data-default+ , free+ , iproute+ , lens+ , pretty+ , mtl+ , network-uri+ , random+ , text+ , tagged+ , time+ , transformers+ , unix, process+ , unordered-containers+ , vector+ , wreq++Executable docean+ Default-Language: Haskell2010+ Main-Is: hdo.hs+ GHC-Options: -Wall -fno-warn-orphans -rtsopts -threaded+ Hs-Source-Dirs: main+ Build-depends: base < 5+ , hdo+ , comonad+ , iproute+ , pretty+ , unordered-containers+ , optparse-applicative+ , bytestring+ , vector+ , network-uri+ , aeson+ , time+ , transformers+ , free+ , data-default+ , random+ , text
+ main/hdo.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Exception (catch, throw)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Free (FreeT)+import Data.Functor.Coproduct+import Data.Maybe+import Data.Monoid ((<>))+import Prelude as P hiding (error)+import System.Console.GetOpt+import System.Environment+import System.IO+import System.IO.Error (isDoesNotExistError)++import Network.DO.Commands+import Network.DO.Droplets.Commands+import Network.DO.Droplets.Utils+import Network.DO.Names+import Network.DO.Net+import Network.DO.Pairing+import Network.DO.Pretty (outputResult)+import Network.DO.Types as DO+import Network.REST++generalOptions :: [OptDescr (ToolConfiguration -> ToolConfiguration)]+generalOptions = [ Option ['t'] ["auth-token"]+ (ReqArg ( \ t config -> config { authToken = Just t}) "STRING")+ "Authentication token used for communicating with server (default: <extracted from $AUTH_TOKEN environment)"+ , Option ['q'] ["quiet"]+ (NoArg ( \ config -> config { quiet = True}))+ "Don't send notifications of operations to Slack (default: False)"+ ]++createDropletOptions :: [OptDescr (BoxConfiguration -> BoxConfiguration)]+createDropletOptions = [ Option ['n'] ["name"]+ (ReqArg ( \ n config -> config { configName = n }) "STRING")+ "name of the box to create (default: <randomly generated name>)"+ , Option ['r'] ["region"]+ (ReqArg ( \ r config -> config { boxRegion = RegionSlug r}) "REGION")+ "region where the instance is to be deployed (default: 'ams2')"+ , Option ['b'] ["background"]+ (NoArg ( \ config -> config { backgroundCreate = True}))+ "create droplet in the background, returning immediately (default: 'false')"+ , Option ['s'] ["size"]+ (ReqArg ( \ s config -> config { size = read s}) "SIZE")+ "size of instance to deploy (default: '4gb')"+ , Option ['i'] ["image-slug"]+ (ReqArg ( \ i config -> config { configImageSlug = i}) "IMAGE")+ "slug of image to deploy (default: 'ubuntu-14-04-x64')"+ , Option ['k'] ["key"]+ (ReqArg ( \ k config -> config { keys = read k ++ keys config}) "[KEY1,..]")+ "add a key to access box (default: '[]')"+ ]++getAuthFromEnv :: IO (Maybe AuthToken)+getAuthFromEnv = (Just `fmap` getEnv "AUTH_TOKEN") `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)++getSlackUriFromEnv :: IO (Maybe URI)+getSlackUriFromEnv = (Just `fmap` getEnv "SLACK_URI") `catch` (\ (e :: IOError) -> if isDoesNotExistError e then return Nothing else throw e)++defaultBox :: IO BoxConfiguration+defaultBox = do+ name <- generateName+ return $ BoxConfiguration name (RegionSlug "ams2") G4 defaultImage [429079] False++defaultTool :: IO ToolConfiguration+defaultTool = do+ uri <- getSlackUriFromEnv+ tok <- getAuthFromEnv+ return $ Tool uri tok False++usage :: String+usage = usageInfo (banner ++ "\n" ++ usageInfo "General options:" generalOptions ++ "\nCommands options:") createDropletOptions+ where+ banner = "Usage: toolbox [OPTIONS..] COMMAND [CMD OPTIONS...]"++parseOptions :: [String] -> IO (ToolConfiguration, [String])+parseOptions args = do+ d <- defaultTool+ case getOpt RequireOrder generalOptions args of+ (opts, coms, []) -> return ((foldl (flip P.id) d opts), coms)+ (_,_,errs) -> ioError(userError (concat errs ++ usage))++main :: IO ()+main = do+ hSetBuffering stdin NoBuffering+ args <- getArgs+ (opts, cmds) <- parseOptions args+ runWreq $ pairEffectM (\ _ b -> return b) (mkDOClient opts) (parseCommandOptions cmds)++parseCommandOptions :: (MonadIO m) => [String] -> FreeT (Coproduct DO DropletCommands) (RESTT m) ()+parseCommandOptions ("droplets":"create":args) = do+ b <- liftIO defaultBox+ case getOpt Permute createDropletOptions args of+ (c,[],[]) -> injr (createDroplet (foldl (flip P.id) b c)) >>= outputResult+ (_,_,errs) -> liftIO $ ioError (userError (concat errs ++ usage))+parseCommandOptions ("droplets":"destroy":dropletId:[]) = injr ( destroyDroplet (P.read dropletId) ) >>= outputResult+parseCommandOptions ("droplets":"list":_) = injr ( listDroplets ) >>= outputResult+parseCommandOptions ("droplets":"power_off":dropletId:[])+ = injr ( dropletAction (P.read dropletId) DoPowerOff) >>= outputResult+parseCommandOptions ("droplets":"power_on":dropletId:[])+ = injr ( dropletAction (P.read dropletId) DoPowerOn) >>= outputResult+parseCommandOptions ("droplets":"snapshot":dropletId:snapshotName:[])+ = injr ( dropletAction (P.read dropletId) (CreateSnapshot snapshotName)) >>= outputResult+parseCommandOptions ("droplets":"action":dropletId:actionId:[])+ = injr ( getAction (P.read dropletId) (P.read actionId)) >>= outputResult+parseCommandOptions ("droplets":dropletId:"snapshots":[])+ = injr ( listDropletSnapshots (P.read dropletId)) >>= outputResult+parseCommandOptions ("droplets":dropletId:[])+ = injr ( showDroplet (P.read dropletId)) >>= outputResult+parseCommandOptions ("droplets":"ssh":dropletIdOrName:[])+ = (do+ droplets <- injr $ (findByIdOrName dropletIdOrName) <$> listDroplets+ case droplets of+ (did:_) -> injr $ dropletConsole did+ [] -> return (error $ "no droplet with id or name " <> dropletIdOrName)+ ) >>= outputResult+parseCommandOptions ("images":"list":_) = injl listImages >>= outputResult+parseCommandOptions ("keys":"list":_) = injl listKeys >>= outputResult+parseCommandOptions ("sizes":"list":_) = injl listSizes >>= outputResult+parseCommandOptions e = fail $ "I don't know how to interpret commands " ++ unwords e++
+ src/Network/DO/Commands.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.DO.Commands where++import Control.Comonad.Trans.Cofree+import Control.Monad.Trans.Free+import Network.DO.Pairing+import Network.DO.Types+import Prelude as P++-- functor for DO DSL+data DO a = ListKeys ([Key] -> a)+ | ListSizes ([Size] -> a)+ | ListImages ([Image] -> a)+ deriving (Functor)++-- free transformer to embed effects+type DOT = FreeT DO++-- smart constructors+listKeys :: DO [Key]+listKeys = ListKeys P.id++listSizes :: DO [Size]+listSizes = ListSizes P.id++listImages :: DO [Image]+listImages = ListImages P.id++-- dual type, for creating interpreters+data CoDO m k = CoDO { listKeysH :: (m [Key], k)+ , listSizesH :: (m [Size], k)+ , listImagesH :: (m [Image], k)+ } deriving Functor++-- Cofree closure of CoDO functor+type CoDOT m = CofreeT (CoDO m)++-- pair DSL with interpreter within some monadic context+instance (Monad m) => PairingM (CoDO m) DO m where+ pairM f (CoDO ks _ _) (ListKeys k) = pairM f ks k+ pairM f (CoDO _ szs _) (ListSizes k) = pairM f szs k+ pairM f (CoDO _ _ imgs) (ListImages k) = pairM f imgs k
+ src/Network/DO/Droplets/Commands.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Network.DO.Droplets.Commands(DropletCommands,+ DropletCommandsT,CoDropletCommandsT,+ CoDropletCommands(..),+ listDroplets, createDroplet, destroyDroplet, dropletAction,+ showDroplet, getAction, listDropletSnapshots,+ dropletConsole) where++import Control.Comonad.Trans.Cofree+import Control.Monad.Trans.Free+import Network.DO.Pairing+import Network.DO.Types+import Prelude as P++-- | Available commands for droplets+data DropletCommands a = ListDroplets ([Droplet] -> a)+ | CreateDroplet BoxConfiguration (Result Droplet -> a)+ | DestroyDroplet Id (Maybe String -> a)+ | DropletAction Id Action (Result ActionResult -> a)+ | GetAction Id Id (Result ActionResult -> a)+ | ListSnapshots Id ([Image] -> a)+ | Console Droplet (Result () -> a)+ | ShowDroplet Id (Result Droplet -> a)+ deriving (Functor)++-- free transformer to embed effects+type DropletCommandsT = FreeT DropletCommands++-- smart constructors+listDroplets :: DropletCommands [Droplet]+listDroplets = ListDroplets P.id++createDroplet :: BoxConfiguration -> DropletCommands (Result Droplet)+createDroplet conf = CreateDroplet conf P.id++showDroplet :: Id -> DropletCommands (Result Droplet)+showDroplet did = ShowDroplet did P.id++destroyDroplet :: Id -> DropletCommands (Maybe String)+destroyDroplet did = DestroyDroplet did P.id++dropletAction :: Id -> Action -> DropletCommands (Result ActionResult)+dropletAction did action = DropletAction did action P.id++dropletConsole :: Droplet -> DropletCommands (Result ())+dropletConsole droplet = Console droplet P.id++getAction :: Id -> Id -> DropletCommands (Result ActionResult)+getAction did actId = GetAction did actId P.id++listDropletSnapshots :: Id -> DropletCommands [Image]+listDropletSnapshots did = ListSnapshots did P.id+++-- | Comonadic interpreter for @DropletCommands@+data CoDropletCommands m k = CoDropletCommands { listDropletsH :: (m [Droplet], k)+ , createDropletH :: BoxConfiguration -> (m (Result Droplet), k)+ , destroyDropletH :: Id -> (m (Maybe String), k)+ , actionDropletH :: Id -> Action -> (m (Result ActionResult), k)+ , getActionH :: Id -> Id -> (m (Result ActionResult), k)+ , listSnapshotsH :: Id -> (m [Image], k)+ , consoleH :: Droplet -> (m (Result ()), k)+ , showDropletH :: Id -> (m (Result Droplet), k)+ } deriving Functor++-- Cofree closure of CoDO functor+type CoDropletCommandsT m = CofreeT (CoDropletCommands m)++-- pair DSL with interpreter within some monadic context+instance (Monad m) => PairingM (CoDropletCommands m) DropletCommands m where+ pairM f (CoDropletCommands list _ _ _ _ _ _ _) (ListDroplets k) = pairM f list k+ pairM f (CoDropletCommands _ create _ _ _ _ _ _) (CreateDroplet conf k) = pairM f (create conf) k+ pairM f (CoDropletCommands _ _ destroy _ _ _ _ _) (DestroyDroplet i k) = pairM f (destroy i) k+ pairM f (CoDropletCommands _ _ _ action _ _ _ _) (DropletAction i a k) = pairM f (action i a) k+ pairM f (CoDropletCommands _ _ _ _ getA _ _ _) (GetAction i i' k) = pairM f (getA i i') k+ pairM f (CoDropletCommands _ _ _ _ _ snapshots _ _) (ListSnapshots i k) = pairM f (snapshots i) k+ pairM f (CoDropletCommands _ _ _ _ _ _ console _) (Console i k) = pairM f (console i) k+ pairM f (CoDropletCommands _ _ _ _ _ _ _ showD) (ShowDroplet i k) = pairM f (showD i) k
+ src/Network/DO/Droplets/Net.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Network interpreter for Droplets specific API+module Network.DO.Droplets.Net(dropletCommandsInterpreter) where++import Control.Applicative+import Control.Comonad.Env.Class (ComonadEnv, ask)+import Control.Exception (IOException)+import Control.Monad (when)+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 :: (ComonadEnv ToolConfiguration w, 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+
+ src/Network/DO/Droplets/Utils.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+module Network.DO.Droplets.Utils+ (publicIP, findByIdOrName)+ where++import Data.IP+import Data.Maybe+import Network.DO.Types++-- |Lookup (first) public IP for given @Droplet@, if any.+publicIP :: Droplet -> Maybe IP+publicIP (networks -> NoNetworks) = Nothing+publicIP (networks -> Networks{..}) = ip_address <$> (listToMaybe $ filter ((== Public) . netType) v4)+++-- |Find the first droplet that matches given Id or name+findByIdOrName :: String -> [ Droplet ] -> [ Droplet ]+findByIdOrName label = filter (matchIdOrName idOrName)+ where+ idOrName = case readsPrec 10 label of+ (did,""):_ -> Left did+ _ -> Right label+ matchIdOrName (Left did) d = dropletId d == did+ matchIdOrName (Right dname) d = name d == dname+
+ src/Network/DO/Names.hs view
@@ -0,0 +1,317 @@+-- |Generate random names+-- shamelessly stolen from https://raw.githubusercontent.com/docker/docker/master/pkg/namesgenerator/names-generator.go+module Network.DO.Names(generateName) where++import Data.Monoid+import System.Random++left :: [ String ]+left = [+ "admiring",+ "adoring",+ "agitated",+ "angry",+ "backstabbing",+ "berserk",+ "boring",+ "clever",+ "cocky",+ "compassionate",+ "condescending",+ "cranky",+ "desperate",+ "determined",+ "distracted",+ "dreamy",+ "drunk",+ "ecstatic",+ "elated",+ "elegant",+ "evil",+ "fervent",+ "focused",+ "furious",+ "gloomy",+ "goofy",+ "grave",+ "happy",+ "high",+ "hopeful",+ "hungry",+ "insane",+ "jolly",+ "jovial",+ "kickass",+ "lonely",+ "loving",+ "mad",+ "modest",+ "naughty",+ "nostalgic",+ "pensive",+ "prickly",+ "reverent",+ "romantic",+ "sad",+ "serene",+ "sharp",+ "sick",+ "silly",+ "sleepy",+ "stoic",+ "stupefied",+ "suspicious",+ "tender",+ "thirsty",+ "trusting"+ ]+++right :: [ String ]+right = [+ -- Muhammad ibn Jābir al-Ḥarrānī al-Battānī was a founding father of astronomy. https:--en.wikipedia.org/wiki/Mu%E1%B8%A5ammad_ibn_J%C4%81bir_al-%E1%B8%A4arr%C4%81n%C4%AB_al-Batt%C4%81n%C4%AB+ "albattani",++ -- June Almeida - Scottish virologist who took the first pictures of the rubella virus - https:--en.wikipedia.org/wiki/June_Almeida+ "almeida",++ -- Archimedes was a physicist, engineer and mathematician who invented too many things to list them here. https:--en.wikipedia.org/wiki/Archimedes+ "archimedes",++ -- Maria Ardinghelli - Italian translator, mathematician and physicist - https:--en.wikipedia.org/wiki/Maria_Ardinghelli+ "ardinghelli",++ -- Charles Babbage invented the concept of a programmable computer. https:--en.wikipedia.org/wiki/Charles_Babbage.+ "babbage",++ -- Stefan Banach - Polish mathematician, was one of the founders of modern functional analysis. https:--en.wikipedia.org/wiki/Stefan_Banach+ "banach",++ -- William Shockley, Walter Houser Brattain and John Bardeen co-invented the transistor (thanks Brian Goff).+ -- - https:--en.wikipedia.org/wiki/John_Bardeen+ -- - https:--en.wikipedia.org/wiki/Walter_Houser_Brattain+ -- - https:--en.wikipedia.org/wiki/William_Shockley+ "bardeen",+ "brattain",+ "shockley",++ -- Jean Bartik, born Betty Jean Jennings, was one of the original programmers for the ENIAC computer. https:--en.wikipedia.org/wiki/Jean_Bartik+ "bartik",++ -- Alexander Graham Bell - an eminent Scottish-born scientist, inventor, engineer and innovator who is credited with inventing the first practical telephone - https:--en.wikipedia.org/wiki/Alexander_Graham_Bell+ "bell",++ -- Elizabeth Blackwell - American doctor and first American woman to receive a medical degree - https:--en.wikipedia.org/wiki/Elizabeth_Blackwell+ "blackwell",++ -- Niels Bohr is the father of quantum theory. https:--en.wikipedia.org/wiki/Niels_Bohr.+ "bohr",++ -- Emmett Brown invented time travel. https:--en.wikipedia.org/wiki/Emmett_Brown (thanks Brian Goff)+ "brown",++ -- Rachel Carson - American marine biologist and conservationist, her book Silent Spring and other writings are credited with advancing the global environmental movement. https:--en.wikipedia.org/wiki/Rachel_Carson+ "carson",++ -- Jane Colden - American botanist widely considered the first female American botanist - https:--en.wikipedia.org/wiki/Jane_Colden+ "colden",++ -- Gerty Theresa Cori - American biochemist who became the third woman—and first American woman—to win a Nobel Prize in science, and the first woman to be awarded the Nobel Prize in Physiology or Medicine. Cori was born in Prague. https:--en.wikipedia.org/wiki/Gerty_Cori+ "cori",++ -- Seymour Roger Cray was an American electrical engineer and supercomputer architect who designed a series of computers that were the fastest in the world for decades. https:--en.wikipedia.org/wiki/Seymour_Cray+ "cray",++ -- Marie Curie discovered radioactivity. https:--en.wikipedia.org/wiki/Marie_Curie.+ "curie",++ -- Charles Darwin established the principles of natural evolution. https:--en.wikipedia.org/wiki/Charles_Darwin.+ "darwin",++ -- Leonardo Da Vinci invented too many things to list here. https:--en.wikipedia.org/wiki/Leonardo_da_Vinci.+ "davinci",++ -- Albert Einstein invented the general theory of relativity. https:--en.wikipedia.org/wiki/Albert_Einstein+ "einstein",++ -- Gertrude Elion - American biochemist, pharmacologist and the 1988 recipient of the Nobel Prize in Medicine - https:--en.wikipedia.org/wiki/Gertrude_Elion+ "elion",++ -- Douglas Engelbart gave the mother of all demos: https:--en.wikipedia.org/wiki/Douglas_Engelbart+ "engelbart",++ -- Euclid invented geometry. https:--en.wikipedia.org/wiki/Euclid+ "euclid",++ -- Pierre de Fermat pioneered several aspects of modern mathematics. https:--en.wikipedia.org/wiki/Pierre_de_Fermat+ "fermat",++ -- Enrico Fermi invented the first nuclear reactor. https:--en.wikipedia.org/wiki/Enrico_Fermi.+ "fermi",++ -- Richard Feynman was a key contributor to quantum mechanics and particle physics. https:--en.wikipedia.org/wiki/Richard_Feynman+ "feynman",++ -- Benjamin Franklin is famous for his experiments in electricity and the invention of the lightning rod.+ "franklin",++ -- Galileo was a founding father of modern astronomy, and faced politics and obscurantism to establish scientific truth. https:--en.wikipedia.org/wiki/Galileo_Galilei+ "galileo",++ -- Adele Goldstine, born Adele Katz, wrote the complete technical description for the first electronic digital computer, ENIAC. https:--en.wikipedia.org/wiki/Adele_Goldstine+ "goldstine",++ -- Jane Goodall - British primatologist, ethologist, and anthropologist who is considered to be the world's foremost expert on chimpanzees - https:--en.wikipedia.org/wiki/Jane_Goodall+ "goodall",++ -- Stephen Hawking pioneered the field of cosmology by combining general relativity and quantum mechanics. https:--en.wikipedia.org/wiki/Stephen_Hawking+ "hawking",++ -- Werner Heisenberg was a founding father of quantum mechanics. https:--en.wikipedia.org/wiki/Werner_Heisenberg+ "heisenberg",++ -- Dorothy Hodgkin was a British biochemist, credited with the development of protein crystallography. She was awarded the Nobel Prize in Chemistry in 1964. https:--en.wikipedia.org/wiki/Dorothy_Hodgkin+ "hodgkin",++ -- Erna Schneider Hoover revolutionized modern communication by inventing a computerized telephon switching method. https:--en.wikipedia.org/wiki/Erna_Schneider_Hoover+ "hoover",++ -- Grace Hopper developed the first compiler for a computer programming language and is credited with popularizing the term "debugging" for fixing computer glitches. https:--en.wikipedia.org/wiki/Grace_Hopper+ "hopper",++ -- Hypatia - Greek Alexandrine Neoplatonist philosopher in Egypt who was one of the earliest mothers of mathematics - https:--en.wikipedia.org/wiki/Hypatia+ "hypatia",++ -- Yeong-Sil Jang was a Korean scientist and astronomer during the Joseon Dynasty; he invented the first metal printing press and water gauge. https:--en.wikipedia.org/wiki/Jang_Yeong-sil+ "jang",++ -- Karen Spärck Jones came up with the concept of inverse document frequency, which is used in most search engines today. https:--en.wikipedia.org/wiki/Karen_Sp%C3%A4rck_Jones+ "jones",++ -- Jack Kilby and Robert Noyce have invented silicone integrated circuits and gave Silicon Valley its name.+ -- - https:--en.wikipedia.org/wiki/Jack_Kilby+ -- - https:--en.wikipedia.org/wiki/Robert_Noyce+ "kilby",+ "noyce",++ -- Maria Kirch - German astronomer and first woman to discover a comet - https:--en.wikipedia.org/wiki/Maria_Margarethe_Kirch+ "kirch",++ -- Sophie Kowalevski - Russian mathematician responsible for important original contributions to analysis, differential equations and mechanics - https:--en.wikipedia.org/wiki/Sofia_Kovalevskaya+ "kowalevski",++ -- Marie-Jeanne de Lalande - French astronomer, mathematician and cataloguer of stars - https:--en.wikipedia.org/wiki/Marie-Jeanne_de_Lalande+ "lalande",++ -- Mary Leakey - British paleoanthropologist who discovered the first fossilized Proconsul skull - https:--en.wikipedia.org/wiki/Mary_Leakey+ "leakey",++ -- Ada Lovelace invented the first algorithm. https:--en.wikipedia.org/wiki/Ada_Lovelace (thanks James Turnbull)+ "lovelace",++ -- Auguste and Louis Lumière - the first filmmakers in history - https:--en.wikipedia.org/wiki/Auguste_and_Louis_Lumi%C3%A8re+ "lumiere",++ -- Maria Mayer - American theoretical physicist and Nobel laureate in Physics for proposing the nuclear shell model of the atomic nucleus - https:--en.wikipedia.org/wiki/Maria_Mayer+ "mayer",++ -- John McCarthy invented LISP: https:--en.wikipedia.org/wiki/John_McCarthy_(computer_scientist)+ "mccarthy",++ -- Barbara McClintock - a distinguished American cytogeneticist, 1983 Nobel Laureate in Physiology or Medicine for discovering transposons. https:--en.wikipedia.org/wiki/Barbara_McClintock+ "mcclintock",++ -- Malcolm McLean invented the modern shipping container: https:--en.wikipedia.org/wiki/Malcom_McLean+ "mclean",++ -- Lise Meitner - Austrian/Swedish physicist who was involved in the discovery of nuclear fission. The element meitnerium is named after her - https:--en.wikipedia.org/wiki/Lise_Meitner+ "meitner",++ -- Johanna Mestorf - German prehistoric archaeologist and first female museum director in Germany - https:--en.wikipedia.org/wiki/Johanna_Mestorf+ "mestorf",++ -- Samuel Morse - contributed to the invention of a single-wire telegraph system based on European telegraphs and was a co-developer of the Morse code - https:--en.wikipedia.org/wiki/Samuel_Morse+ "morse",++ -- Isaac Newton invented classic mechanics and modern optics. https:--en.wikipedia.org/wiki/Isaac_Newton+ "newton",++ -- Alfred Nobel - a Swedish chemist, engineer, innovator, and armaments manufacturer (inventor of dynamite) - https:--en.wikipedia.org/wiki/Alfred_Nobel+ "nobel",++ -- Cecilia Payne-Gaposchkin was an astronomer and astrophysicist who, in 1925, proposed in her Ph.D. thesis an explanation for the composition of stars in terms of the relative abundances of hydrogen and helium. https:--en.wikipedia.org/wiki/Cecilia_Payne-Gaposchkin+ "payne",++ -- Ambroise Pare invented modern surgery. https:--en.wikipedia.org/wiki/Ambroise_Par%C3%A9+ "pare",++ -- Louis Pasteur discovered vaccination, fermentation and pasteurization. https:--en.wikipedia.org/wiki/Louis_Pasteur.+ "pasteur",++ -- Radia Perlman is a software designer and network engineer and most famous for her invention of the spanning-tree protocol (STP). https:--en.wikipedia.org/wiki/Radia_Perlman+ "perlman",++ -- Rob Pike was a key contributor to Unix, Plan 9, the X graphic system, utf-8, and the Go programming language. https:--en.wikipedia.org/wiki/Rob_Pike+ "pike",++ -- Henri Poincaré made fundamental contributions in several fields of mathematics. https:--en.wikipedia.org/wiki/Henri_Poincar%C3%A9+ "poincare",++ -- Laura Poitras is a director and producer whose work, made possible by open source crypto tools, advances the causes of truth and freedom of information by reporting disclosures by whistleblowers such as Edward Snowden. https:--en.wikipedia.org/wiki/Laura_Poitras+ "poitras",++ -- Claudius Ptolemy - a Greco-Egyptian writer of Alexandria, known as a mathematician, astronomer, geographer, astrologer, and poet of a single epigram in the Greek Anthology - https:--en.wikipedia.org/wiki/Ptolemy+ "ptolemy",++ -- Dennis Ritchie and Ken Thompson created UNIX and the C programming language.+ -- - https:--en.wikipedia.org/wiki/Dennis_Ritchie+ -- - https:--en.wikipedia.org/wiki/Ken_Thompson+ "ritchie",+ "thompson",++ -- Rosalind Franklin - British biophysicist and X-ray crystallographer whose research was critical to the understanding of DNA - https:--en.wikipedia.org/wiki/Rosalind_Franklin+ "rosalind",++ -- Jean E. Sammet developed FORMAC, the first widely used computer language for symbolic manipulation of mathematical formulas. https:--en.wikipedia.org/wiki/Jean_E._Sammet+ "sammet",++ -- Françoise Barré-Sinoussi - French virologist and Nobel Prize Laureate in Physiology or Medicine; her work was fundamental in identifying HIV as the cause of AIDS. https:--en.wikipedia.org/wiki/Fran%C3%A7oise_Barr%C3%A9-Sinoussi+ "sinoussi",++ -- Richard Matthew Stallman - the founder of the Free Software movement, the GNU project, the Free Software Foundation, and the League for Programming Freedom. He also invented the concept of copyleft to protect the ideals of this movement, and enshrined this concept in the widely-used GPL (General Public License) for software. https:--en.wikiquote.org/wiki/Richard_Stallman+ "stallman",++ -- Aaron Swartz was influential in creating RSS, Markdown, Creative Commons, Reddit, and much of the internet as we know it today. He was devoted to freedom of information on the web. https:--en.wikiquote.org/wiki/Aaron_Swartz+ "swartz",++ -- Nikola Tesla invented the AC electric system and every gadget ever used by a James Bond villain. https:--en.wikipedia.org/wiki/Nikola_Tesla+ "tesla",++ -- Linus Torvalds invented Linux and Git. https:--en.wikipedia.org/wiki/Linus_Torvalds+ "torvalds",++ -- Alan Turing was a founding father of computer science. https:--en.wikipedia.org/wiki/Alan_Turing.+ "turing",++ -- Sophie Wilson designed the first Acorn Micro-Computer and the instruction set for ARM processors. https:--en.wikipedia.org/wiki/Sophie_Wilson+ "wilson",++ -- Steve Wozniak invented the Apple I and Apple II. https:--en.wikipedia.org/wiki/Steve_Wozniak+ "wozniak",++ -- The Wright brothers, Orville and Wilbur - credited with inventing and building the world's first successful airplane and making the first controlled, powered and sustained heavier-than-air human flight - https:--en.wikipedia.org/wiki/Wright_brothers+ "wright",++ -- Rosalyn Sussman Yalow - Rosalyn Sussman Yalow was an American medical physicist, and a co-winner of the 1977 Nobel Prize in Physiology or Medicine for development of the radioimmunoassay technique. https:--en.wikipedia.org/wiki/Rosalyn_Sussman_Yalow+ "yalow",++ -- Ada Yonath - an Israeli crystallographer, the first woman from the Middle East to win a Nobel prize in the sciences. https:--en.wikipedia.org/wiki/Ada_Yonath+ "yonath"+ ]++generateName :: IO String+generateName = do+ l <- randomRIO (0, length left)+ r <- randomRIO (0, length right)+ return $ left !! l <> "-" <> right !! r+
+ src/Network/DO/Net.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Interpreter for accessing DO API through the web using [wreq http://www.serpentine.com/wreq].+module Network.DO.Net(mkDOClient) where++import Control.Applicative+import Control.Comonad.Env.Class (ComonadEnv)+import Control.Comonad.Trans.Cofree (CofreeT, coiterT)+import Control.Comonad.Trans.Env (Env, env)+import Control.Monad.Trans (MonadIO)+import Data.Functor.Product+import Data.Proxy+import Prelude as P++import Network.DO.Commands+import Network.DO.Droplets.Commands+import Network.DO.Droplets.Net+import Network.DO.Net.Common+import Network.DO.Types as DO hiding (URI)+import Network.REST++imagesURI :: String+imagesURI = "images"++keysURI :: String+keysURI = "keys"++sizesURI :: String+sizesURI = "sizes"++accountURI :: String+accountURI = "account"++keysEndpoint :: String+keysEndpoint = rootURI </> apiVersion </> accountURI </> keysURI++sizesEndpoint :: String+sizesEndpoint = rootURI </> apiVersion </> sizesURI++imagesEndpoint :: String+imagesEndpoint = rootURI </> apiVersion </> imagesURI+++instance Listable Key where+ listEndpoint _ = keysEndpoint+ listField _ = "ssh_keys"++instance Listable Size where+ listEndpoint _ = sizesEndpoint+ listField _ = "sizes"++instance Listable Image where+ listEndpoint _ = imagesEndpoint+ listField _ = "images"++genericCommands :: (Monad m, ComonadEnv ToolConfiguration w) => w a -> CoDO (RESTT m) (w a)+genericCommands = CoDO+ <$> queryList (Proxy :: Proxy Key)+ <*> queryList (Proxy :: Proxy Size)+ <*> queryList (Proxy :: Proxy Image)++mkDOClient :: (MonadIO m) => ToolConfiguration -> CofreeT (Product (CoDO (RESTT m)) (CoDropletCommands (RESTT m))) (Env ToolConfiguration) (RESTT m ())+mkDOClient config = coiterT next start+ where+ next = Pair+ <$> genericCommands+ <*> dropletCommandsInterpreter+ start = env config (return ())
+ src/Network/DO/Net/Common.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.DO.Net.Common where++import Control.Comonad.Env.Class (ComonadEnv, ask)+import Control.Lens ((&), (.~))+import Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.ByteString.Char8 (pack)+import qualified Data.HashMap.Strict as H+import Data.Maybe+import Data.Monoid+import Data.Proxy+import Data.Text (Text)+import qualified Data.Vector as V+import Network.DO.Types as DO hiding (URI)+import Network.REST+import Network.URI (URI, parseURI)+import Network.Wreq hiding (Proxy)+import Prelude as P++rootURI :: String+rootURI = "https://api.digitalocean.com"++apiVersion :: String+apiVersion = "v2"++(</>) :: String -> String -> String+s </> ('/': s') = s ++ s'+s </> s' = s ++ "/" ++ s'++toURI :: String -> URI+toURI = fromJust . parseURI++toList :: (FromJSON a) => Text -> Value -> [a]+toList k (Object o) = let Array boxes = o H.! k+ in mapMaybe (A.parseMaybe parseJSON) (V.toList boxes)+toList _ _ = []++authorisation :: String -> Options+authorisation t = defaults & header "Authorization" .~ ["Bearer " <> pack t]++class Listable a where+ listEndpoint :: Proxy a -> String+ listField :: Proxy a -> Text++queryList :: (ComonadEnv ToolConfiguration w, Monad m, Listable b, FromJSON b) => Proxy b -> w a -> (RESTT m [b], w a)+queryList p w = maybe (return [], w)+ (\ t -> let droplets = toList (listField p) <$> getJSONWith (authorisation t) (toURI (listEndpoint p))+ in (droplets, w))+ (authToken (ask w))+
+ src/Network/DO/Pairing.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+module Network.DO.Pairing (Pairing(..)+ , PairingM(..)+ , pairEffect+ , pairEffectM+ , pairEffect'+ , injr, injl+ ) where++import Control.Comonad (Comonad, extract)+import Control.Comonad.Trans.Cofree (CofreeT, unwrap)+import Control.Monad.Trans.Free (FreeF (..), FreeT, liftF,+ runFreeT)+import Data.Functor.Coproduct+import Data.Functor.Identity (Identity (..))+import Data.Functor.Product++class (Functor f, Functor g) => Pairing f g where+ pair :: (a -> b -> r) -> f a -> g b -> r++instance Pairing Identity Identity where+ pair f (Identity a) (Identity b) = f a b++instance Pairing ((->) a) ((,) a) where+ pair p f = uncurry (p . f)++instance Pairing ((,) a) ((->) a) where+ pair p f g = p (snd f) (g (fst f))++class (Functor f, Functor g, Monad m) => PairingM f g m where+ pairM :: (a -> b -> m r) -> f a -> g b -> m r++instance (Monad m) => PairingM ((,) (m a)) ((->) a) m where+ pairM p (ma, b) g = ma >>= \ a -> p b (g a)++instance (Monad m, PairingM f h m, PairingM g k m) => PairingM (Coproduct f g) (Product h k) m where+ pairM p (Coproduct (Left f)) (Pair h _) = pairM p f h+ pairM p (Coproduct (Right g)) (Pair _ k) = pairM p g k++instance (Monad m, PairingM h f m, PairingM k g m) => PairingM (Product h k) (Coproduct f g) m where+ pairM p (Pair h _) (Coproduct (Left f)) = pairM p h f+ pairM p (Pair _ k) (Coproduct (Right g)) = pairM p k g++injl :: (Monad m, Functor f, Functor g) => f a -> FreeT (Coproduct f g) m a+injl = liftF . Coproduct . Left++injr :: (Monad m, Functor f, Functor g) => g a -> FreeT (Coproduct f g) m a+injr = liftF . Coproduct . Right++pairEffect :: (Pairing f g, Comonad w, Monad m)+ => (a -> b -> r) -> CofreeT f w a -> FreeT g m b -> m r+pairEffect p s c = do+ mb <- runFreeT c+ case mb of+ Pure x -> return $ p (extract s) x+ Free gs -> pair (pairEffect p) (unwrap s) gs++pairEffect' :: (Pairing f g, Comonad w, Monad m)+ => (a -> b -> m r) -> CofreeT f w a -> FreeT g m b -> m r+pairEffect' p s c = do+ mb <- runFreeT c+ case mb of+ Pure x -> p (extract s) x+ Free gs -> pair (pairEffect' p) (unwrap s) gs++pairEffectM :: (PairingM f g m, Comonad w, Monad m)+ => (a -> b -> m r) -> CofreeT f w (m a) -> FreeT g m b -> m r+pairEffectM p s c = do+ ma <- extract s+ mb <- runFreeT c+ case mb of+ Pure x -> p ma x+ Free gs -> pairM (pairEffectM p) (unwrap s) gs+
+ src/Network/DO/Pretty.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Network.DO.Pretty where++import Control.Monad.IO.Class (MonadIO (..))+import Data.IP (IP)+import Network.DO.Types+import Text.PrettyPrint++class (Show a) => Pretty a where+ pretty :: a -> Doc+ pretty = text . show++instance Pretty () where+ pretty () = text ""++instance (Pretty a, Pretty b) => Pretty (Either a b) where+ pretty (Left a) = text "Error:" <+> pretty a+ pretty (Right a) = pretty a++instance (Pretty a) => Pretty (Maybe a) where+ pretty (Just a) = pretty a+ pretty Nothing = text "-"++instance Pretty Char where+ pretty = char++instance Pretty Error where+ pretty (Error m) = text m++instance Pretty Date where+ pretty (Date d) = text $ show d++instance Pretty Droplet where+ pretty Droplet{..} = integer dropletId $$+ (nest 5 $ (text name) <+> brackets (pretty status) <+> pretty region) $$+ (nest 5 $ hcat $ punctuate (char '/') [pretty memory, pretty disk, int vcpus <+> text "cores"]) $$+ (nest 5 $ pretty networks)++instance Pretty Status+instance Pretty NetType+instance Pretty IP++instance Pretty Region where+ pretty Region{..} = text regionSlug+ pretty (RegionSlug s) = text s+ pretty NoRegion = empty++instance Pretty Networks where+ pretty Networks{..} = text "IPv4" $$ nest 2 (pretty v4) $$+ text "IPv6" $$ nest 2 (pretty v6)+ pretty NoNetworks = text "N/A"++instance Pretty (Network a) where+ pretty NetworkV4{..} = pretty ip_address <> char '/' <> pretty netmask <+> brackets (pretty netType)+ pretty NetworkV6{..} = pretty ip_address <> char '/' <> int netmask_v6 <+> brackets (pretty netType)++instance Pretty (Bytes Giga) where+ pretty Bytes{..} = int bytesSize <> text "G"++instance Pretty (Bytes Mega) where+ pretty Bytes{..} = int bytesSize <> text "M"++instance (Pretty a) => Pretty [a] where+ pretty = sep . map pretty++instance Pretty Key where+ pretty Key{..} = integer keyId <+> text keyName <+> text keyFingerprint <+> text publicKey++instance Pretty Image where+ pretty Image{..} = integer imageId <+> text imageName <+> text distribution++instance Pretty TransferRate+instance Pretty SizeSlug++instance Pretty Size where+ pretty Size{..} = pretty szSlug $$+ nest 5 (hcat $ punctuate (char '/') [pretty szMemory, int szVcpus, pretty szDisk, pretty szTransfer]) $$+ nest 5 (pretty szPrice_Hourly <> text "$/h, " <> pretty szPrice_Monthly <> text "$/mo" ) $$+ nest 5 (hcat $ punctuate (char ',') $ map pretty szRegions)++instance Pretty ActionResult where+ pretty ActionResult{..} = brackets (integer actionId) <+> pretty actionStartedAt <+> text "->" <+> pretty actionCompletedAt $$+ (nest 5 $ integer actionResourceId <+> text (show actionType) <> char ':' <+> text (show actionStatus))++outputResult :: (Pretty a, MonadIO m) => a -> m ()+outputResult = liftIO . putStrLn . render . pretty+
+ src/Network/DO/Types.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |Contains Haskell representation of most data types used for interacting with+-- DigitalOcean's API v2+--+-- See https://developers.digitalocean.com/documentation/v2/+module Network.DO.Types where++import Data.Aeson as A hiding (Error, Result)+import Data.Aeson.Types as A hiding (Error, Result)+import Data.Default+import qualified Data.HashMap.Lazy as H+import Data.IP+import Data.List (elemIndex)+import Data.Monoid ((<>))+import Data.Text (unpack)+import Data.Time (UTCTime)+import GHC.Generics+++type AuthToken = String++type Slug = String++type URI = String++newtype Error = Error { msg :: String } deriving (Eq, Show, Read)++type Result a = Either Error a++error :: String -> Result a+error = Left . Error++data ToolConfiguration = Tool { slackUri :: Maybe URI+ , authToken :: Maybe AuthToken+ , quiet :: Bool+ } deriving (Show,Read)++instance Default ToolConfiguration where+ def = Tool Nothing Nothing False++-- | A type for describing @Region@+-- A region can be assigned an empty object when it is undefined, or be referenced simply+-- by its @slug@+-- https://developers.digitalocean.com/documentation/v2/#regions+data Region = Region { regionName :: String+ , regionSlug :: Slug+ , regionSizes :: [ SizeSlug ]+ , regionAvailable :: Bool+ }+ | RegionSlug Slug+ | NoRegion++instance ToJSON Region where+ toJSON (RegionSlug s) = toJSON s+ toJSON NoRegion = object []+ toJSON Region{..} = object [ "name" .= regionName+ , "slug" .= regionSlug+ , "sizes" .= regionSizes+ , "available" .= regionAvailable+ ]++instance Show Region where+ show (RegionSlug s) = s+ show NoRegion = "NoRegion"+ show Region{..} = "Region { regionName = " <> show regionName <>+ ", regionSlug = " <> show regionSlug <>+ ", regionSizes = " <> show regionSizes <>+ ", regionAvailable = " <> show regionAvailable <>+ "}"+++instance FromJSON Region where+ parseJSON (String s) = return $ RegionSlug (unpack s)+ parseJSON (Object o) = if H.null o+ then return NoRegion+ else Region+ <$> o .: "name"+ <*> o .: "slug"+ <*> o .: "sizes"+ <*> o .: "available"+ parseJSON e = failParse e+++-- | String representation of size slugs+-- This maps to corresponding expected JSON string value.+sizeSlugs :: [String]+sizeSlugs = [ "512mb", "1gb", "2gb", "4gb", "8gb", "16gb", "32gb", "48gb", "64gb", "96gb" ]++-- | Enumeration of all possible size slugs+data SizeSlug = M512 | G1 | G2 | G4 | G8 | G16 | G32 | G48 | G64 | G96+ deriving (Enum,Ord,Eq)++instance Show SizeSlug where+ show sz = sizeSlugs !! fromEnum sz++instance Read SizeSlug where+ readsPrec _ sz = case elemIndex sz sizeSlugs of+ Just i -> return (toEnum i, "")+ Nothing -> fail $ "cannot parse " <> sz++instance ToJSON SizeSlug where+ toJSON sz = toJSON $ sizeSlugs !! fromEnum sz++instance FromJSON SizeSlug where+ parseJSON (String s) = case elemIndex (unpack s) sizeSlugs of+ Just i -> return $ toEnum i+ Nothing -> fail $ "cannot parse " <> unpack s+ parseJSON e = failParse e+++type ImageSlug = String+type KeyId = Int++defaultImage :: ImageSlug+defaultImage = "ubuntu-14-04-x64"++data BoxConfiguration = BoxConfiguration { configName :: String+ , boxRegion :: Region+ , size :: SizeSlug+ , configImageSlug :: ImageSlug+ , keys :: [KeyId]+ , backgroundCreate :: Bool+ } deriving (Show)++instance ToJSON BoxConfiguration where+ toJSON BoxConfiguration{..} = object [ "name" .= configName+ , "region" .= boxRegion+ , "size" .= size+ , "image" .= configImageSlug+ , "ssh_keys" .= keys+ , "backups" .= False+ , "ipv6" .= False+ , "private_networking" .= False+ ]++type Id = Integer++data Mega+data Giga++-- | A type for various sizes+-- Type parameter is used to define number's magnitude+newtype Bytes a = Bytes { bytesSize :: Int } deriving Show++jsonBytes :: Int -> Parser (Bytes a)+jsonBytes = return . Bytes++instance FromJSON (Bytes Mega) where+ parseJSON (Number n) = jsonBytes (truncate n)+ parseJSON e = failParse e++instance FromJSON (Bytes Giga) where+ parseJSON (Number n) = jsonBytes (truncate n)+ parseJSON e = failParse e++newtype Date = Date { theDate :: UTCTime } deriving Show++instance FromJSON Date where+ parseJSON d@(String _) = Date <$> parseJSON d+ parseJSON e = failParse e++data Status = New+ | Active+ | Off+ | Archive+ deriving (Eq,Show)++instance FromJSON Status where+ parseJSON (String s) = case s of+ "new" -> return New+ "active" -> return Active+ "off" -> return Off+ "archive" -> return Archive+ _ -> fail $ "cannot parse " <> unpack s+ parseJSON e = failParse e++data NetType = Public | Private deriving (Show, Eq)++-- | Type of a single Network definition+--+-- This type is parameterized with a phantom type which lifts the network address type at+-- the type level (could use DataKinds extension...). This allows distinguishing types of+-- of networks while using same parsing.+data Network a = NetworkV4 { ip_address :: IP+ , netmask :: IP+ , gateway :: IP+ , netType :: NetType+ }+ | NetworkV6 { ip_address :: IP+ , netmask_v6 :: Int+ , gateway :: IP+ , netType :: NetType+ } deriving Show++instance FromJSON IP where+ parseJSON (String s) = return $ read $ unpack s+ parseJSON e = fail $ "cannot parse IP " <> show e++instance FromJSON NetType where+ parseJSON (String s) = case s of+ "public" -> return Public+ "private" -> return Private+ e -> failParse e+ parseJSON e = failParse e++data V4+data V6++jsonNetwork :: (FromJSON a3, FromJSON a2, FromJSON a1, FromJSON a) => (a3 -> a2 -> a1 -> a -> b) -> Object -> Parser b+jsonNetwork f n = f+ <$> (n .: "ip_address")+ <*> (n .: "netmask")+ <*> (n .: "gateway")+ <*> (n .: "type")++instance FromJSON (Network V4) where+ parseJSON (Object n) = jsonNetwork NetworkV4 n+ parseJSON e = failParse e++instance FromJSON (Network V6) where+ parseJSON (Object n) = jsonNetwork NetworkV6 n+ parseJSON e = fail $ "cannot parse network v6 " <> show e+++-- | Type of Networks configured for a @Droplet@+--+-- A network is either a list of IPv4 and IPv6 NICs definitions, or no network. We need this+-- because a droplet can contain an ''empty'' @networks@ JSON Object entry, instead of @null@.+data Networks = Networks { v4 :: [ Network V4 ]+ , v6 :: [ Network V6 ]+ }+ | NoNetworks+ deriving (Generic, Show)++instance FromJSON Networks where+ parseJSON (Object n) = if H.null n+ then return NoNetworks+ else Networks+ <$> (n .: "v4")+ <*> (n .: "v6")+ parseJSON e = fail $ "cannot parse network v6 " <> show e++-- | (Partial) Type of Droplets+--+-- https://developers.digitalocean.com/documentation/v2/#droplets+data Droplet = Droplet { dropletId :: Id+ , name :: String+ , memory :: Bytes Mega+ , vcpus :: Int+ , disk :: Bytes Giga+ , locked :: Bool+ , created_at :: Date+ , status :: Status+ , backup_ids :: [ Id ]+ , snapshot_ids :: [ Id ]+ , region :: Region+ , size_slug :: SizeSlug+ , networks :: Networks+ } deriving (Show)++instance FromJSON Droplet where+ parseJSON (Object o) = Droplet+ <$> o .: "id"+ <*> o .: "name"+ <*> o .: "memory"+ <*> o .: "vcpus"+ <*> o .: "disk"+ <*> o .: "locked"+ <*> o .: "created_at"+ <*> o .: "status"+ <*> o .: "backup_ids"+ <*> o .: "snapshot_ids"+ <*> o .: "region"+ <*> o .: "size_slug"+ <*> o .: "networks"+ parseJSON e = fail $ "cannot parse network v6 " <> show e+++data ImageType = Snapshot+ | Temporary+ | Backup+ deriving Show++instance FromJSON ImageType where+ parseJSON (String s) = case s of+ "snapshot" -> return Snapshot+ "temporary" -> return Temporary+ "backup" -> return Backup+ _ -> fail $ "cannot parse " <> unpack s+ parseJSON e = failParse e++-- | Type of droplet images+--+-- https://developers.digitalocean.com/documentation/v2/#images+data Image = Image { imageId :: Id+ , imageName :: String+ , distribution :: String+ , imageSlug :: Maybe Slug+ , publicImage :: Bool+ , imageRegions :: [ Region ]+ , min_disk_size :: Bytes Giga+ , image_created_at :: Date+ , imageType :: ImageType+ } deriving Show++instance FromJSON Image where+ parseJSON (Object o) = Image+ <$> o .: "id"+ <*> o .: "name"+ <*> o .: "distribution"+ <*> o .:? "slug"+ <*> o .: "public"+ <*> o .: "regions"+ <*> o .: "min_disk_size"+ <*> o .: "created_at"+ <*> o .: "type"+ parseJSON e = failParse e++-- | Type of SSH @Key@s+--+--https://developers.digitalocean.com/documentation/v2/#ssh-keys+data Key = Key { keyId :: Id+ , keyFingerprint :: String+ , publicKey :: String+ , keyName :: String+ } deriving Show++instance FromJSON Key where+ parseJSON (Object o) = Key+ <$> o .: "id"+ <*> o .: "fingerprint"+ <*> o .: "public_key"+ <*> o .: "name"+ parseJSON e = failParse e++type TransferRate = Double+type Price = Double++-- | Type of Size objects+--+-- https://developers.digitalocean.com/documentation/v2/#sizes+data Size = Size { szSlug :: SizeSlug+ , szMemory :: Bytes Mega+ , szVcpus :: Int+ , szDisk :: Bytes Giga+ , szTransfer :: TransferRate+ , szPrice_Monthly :: Price+ , szPrice_Hourly :: Price+ , szRegions :: [ Region ]+ , szAvailable :: Bool+ } deriving (Show)+++instance FromJSON Size where+ parseJSON (Object o) = Size+ <$> o .: "slug"+ <*> o .: "memory"+ <*> o .: "vcpus"+ <*> o .: "disk"+ <*> o .: "transfer"+ <*> o .: "price_monthly"+ <*> o .: "price_hourly"+ <*> o .: "regions"+ <*> o .: "available"++ parseJSON e = failParse e+++-- * Droplets Actions++-- | Type of action status+-- This is returned when action is initiated or when status of some action is requested++data ActionResult = ActionResult { actionId :: Id+ , actionStatus :: ActionStatus+ , actionType :: ActionType+ , actionStartedAt :: Maybe Date+ , actionCompletedAt :: Maybe Date+ , actionResourceId :: Id+ , actionResourceType :: String+ , actionRegionSlug :: Region+ } deriving (Show)++instance FromJSON ActionResult where+ parseJSON (Object o) = ActionResult+ <$> o .: "id"+ <*> o .: "status"+ <*> o .: "type"+ <*> o .:? "started_at"+ <*> o .:? "completed_at"+ <*> o .: "resource_id"+ <*> o .: "resource_type"+ <*> o .: "region_slug"+ parseJSON v = fail $ "cannot parse action " ++ show v++data ActionStatus = InProgress+ | Completed+ | Errored+ deriving (Show)++instance FromJSON ActionStatus where+ parseJSON (String s) = case s of+ "in-progress" -> return InProgress+ "completed" -> return Completed+ "errored" -> return Errored+ _ -> fail $ "unknown action status " ++ show s+ parseJSON v = fail $ "cannot parse action status " ++ show v++data ActionType = PowerOff+ | PowerOn+ | MakeSnapshot+ deriving (Show)++instance FromJSON ActionType where+ parseJSON (String s) = case s of+ "power_off" -> return PowerOff+ "power_on" -> return PowerOn+ "snapshot" -> return MakeSnapshot+ _ -> fail $ "unknown action type " ++ show s+ parseJSON v = fail $ "cannot parse action type " ++ show v++instance ToJSON ActionType where+ toJSON PowerOff = String "power_off"+ toJSON PowerOn = String "power_on"+ toJSON MakeSnapshot = String "snapshot"++data Action = DoPowerOff+ | DoPowerOn+ | CreateSnapshot String+ deriving Show++instance ToJSON Action where+ toJSON DoPowerOff = object [ "type" .= PowerOff ]+ toJSON DoPowerOn = object [ "type" .= PowerOn ]+ toJSON (CreateSnapshot snapshotName) = object [ "type" .= MakeSnapshot+ , "name" .= snapshotName+ ]++-- |Type of Domain zones+--+-- https://developers.digitalocean.com/documentation/v2/#domains+data Domain = Domain { domainName :: String+ , domainTTL :: Int+ , zone_file :: String+ } deriving (Show)++instance FromJSON Domain where+ parseJSON (Object o) = Domain+ <$> o .: "name"+ <*> o .: "ttl"+ <*> o .: "zone_file"++ parseJSON e = failParse e++-- | Enumeration of possible DNS records types+data DNSType = A | CNAME | TXT | PTR | SRV | NS | AAAA | MX+ deriving (Show, Read, Generic)++instance FromJSON DNSType+instance ToJSON DNSType++-- | Type of Domain zone file entries+--+-- https://developers.digitalocean.com/documentation/v2/#domain-records+data DomainRecord = DomainRecord { recordId :: Id+ , recordType :: DNSType+ , recordName :: String+ , recordData :: String+ , recordPriority :: Maybe Double+ , recordPort :: Maybe Int+ , recordWeight :: Maybe Double+ } deriving (Show)+++instance FromJSON DomainRecord where+ parseJSON (Object o) = DomainRecord+ <$> o .: "id"+ <*> o .: "type"+ <*> o .: "name"+ <*> o .: "data"+ <*> o .: "priority"+ <*> o .: "port"+ <*> o .: "weight"++ parseJSON e = failParse e++failParse :: (Show a1, Monad m) => a1 -> m a+failParse e = fail $ "cannot parse " <> show e
+ src/Network/REST.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Functor and low-level mechanism to interact with a server using Wreq and JSON values.+module Network.REST(module Network.REST.Commands+ ,module Network.REST.Wreq+ ,ssh) where++import Network.REST.Commands+import Network.REST.Wreq+-- TODO temporary kludge+import Network.SSH
+ src/Network/REST/Commands.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Functor and low-level mechanism to interact with a server using "REST" API.+--+-- This module exposes @Net@ functor which can be implemented using various stack.+-- In particular, we provide @Network.REST.Wreq@ module as a wreq-based implementation+-- and a test-only implementation which is used to check correctness of higher-level+-- code, in particular in relation with JSON serialization.+module Network.REST.Commands where++import Control.Monad.Trans.Free (FreeT (..), liftF)+import Data.Aeson (Value)+import Network.URI (URI)+import Network.Wreq (Options)++data REST a = Get URI (Value -> a)+ | Post URI Value (Maybe Value -> a)+ | WaitFor Int String a+ | GetWith Options URI (Value -> a)+ | PostWith Options URI Value (Either String Value -> a)+ | DeleteWith Options URI a+ deriving (Functor)++type RESTT = FreeT REST++-- smart constructors+getJSON :: (Monad m) => URI -> RESTT m Value+getJSON uri = liftF $ Get uri id++getJSONWith :: (Monad m) => Options -> URI -> RESTT m Value+getJSONWith opts uri = liftF $ GetWith opts uri id++postJSON :: (Monad m) => URI -> Value -> RESTT m (Maybe Value)+postJSON uri json = liftF $ Post uri json id++postJSONWith :: (Monad m) => Options -> URI -> Value -> RESTT m (Either String Value)+postJSONWith opts uri json = liftF $ PostWith opts uri json id++deleteJSONWith :: (Monad m) => Options -> URI -> RESTT m ()+deleteJSONWith opts uri = liftF $ DeleteWith opts uri ()++waitFor :: (Monad m) => Int -> String -> RESTT m ()+waitFor delay message = liftF $ WaitFor delay message ()+
+ src/Network/REST/Wreq.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Implementation of @Net@ interface based on <http://wreq.io wreq>+module Network.REST.Wreq where++import Control.Concurrent (threadDelay)+import Control.Lens ((^.))+import Control.Monad.Trans.Free+import Data.Aeson (Value, decode, eitherDecode)+import Data.ByteString.Lazy (ByteString)+import Network.REST.Commands+import Network.URI+import Network.Wreq++-- | An implementation of @Net@ functor based on wreq and @IO@+runWreq :: RESTT IO r -> IO r+runWreq r = do+ mr <- runFreeT r+ step mr+ where+ asString :: URI -> String+ asString = ($ "") . uriToString id++ step (Pure value) = return value++ step (Free (WaitFor delay message k)) = do+ putStrLn message+ threadDelay delay+ runWreq k++ step (Free (Get uri k)) = do+ b <- asJSON =<< get (asString uri) :: IO (Response Value)+ let value = b ^. responseBody+ runWreq (k value)++ step (Free (GetWith opts uri k)) = do+ b <- asJSON =<< getWith opts (asString uri) :: IO (Response Value)+ let value = b ^. responseBody+ runWreq (k value)++ step (Free (DeleteWith opts uri k)) = do+ _ <- deleteWith opts (asString uri) :: IO (Response ByteString)+ runWreq k++ step (Free (Post uri val k)) = do+ resp <- post (asString uri) val :: IO (Response ByteString)+ let value :: Maybe Value = decode $ resp ^. responseBody+ runWreq (k value)++ step (Free (PostWith opts uri val k)) = do+ resp <- postWith opts (asString uri) val :: IO (Response ByteString)+ let value :: Either String Value = eitherDecode $ resp ^. responseBody+ runWreq (k value)++
+ src/Network/SSH.hs view
@@ -0,0 +1,10 @@+module Network.SSH+ (ssh)+ where++import Control.Exception (Exception, try)+import Control.Monad.Trans (MonadIO (..))+import System.Process (callProcess)++ssh :: (MonadIO m, Exception e) => [String] -> m (Either e ())+ssh args = liftIO $ try (callProcess "ssh" args)
+ stack.yaml view
@@ -0,0 +1,4 @@+flags: {}+packages:+- '.'+resolver: lts-3.3