lxd-client (empty) → 0.1.0.0
raw patch · 12 files changed
+3979/−0 lines, 12 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, bimap, bytestring, connection, containers, data-default, directory, either, exceptions, filepath, hspec, hspec-core, http-api-data, http-client, http-client-tls, http-media, http-types, lxd-client, mtl, network, random, semigroups, servant, servant-client, text, tls, transformers, turtle, unix, uuid, websockets, x509, x509-store, x509-validation
Files
- LICENSE +674/−0
- Setup.hs +2/−0
- example/Main.hs +21/−0
- lxd-client.cabal +96/−0
- src/Network/LXD/Client.hs +256/−0
- src/Network/LXD/Client/API.hs +431/−0
- src/Network/LXD/Client/Commands.hs +755/−0
- src/Network/LXD/Client/Events.hs +61/−0
- src/Network/LXD/Client/Internal/Prelude.hs +43/−0
- src/Network/LXD/Client/Remotes.hs +17/−0
- src/Network/LXD/Client/Types.hs +1469/−0
- test/Integration.hs +154/−0
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ lxd-client+ Copyright (C) 2016 Henri Verroken++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ lxd-client Copyright (C) 2016 Henri Verroken+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad.IO.Class (liftIO)+import Network.LXD.Client.Commands++main :: IO ()+main = runWithLocalHost def $ do+ liftIO $ putStrLn "Creating my-container"+ lxcCreate . containerCreateRequest "my-container"+ . ContainerSourceRemote+ $ remoteImage imagesRemote "ubuntu/xenial/amd64"++ liftIO $ putStrLn "Starting my-container"+ lxcStart "my-container"++ liftIO $ putStrLn "Stopping my-container"+ lxcStop "my-container" False++ liftIO $ putStrLn "Deleting my-container"+ lxcDelete "my-container"
+ lxd-client.cabal view
@@ -0,0 +1,96 @@+name: lxd-client+version: 0.1.0.0+synopsis: LXD client written in Haskell.+description:+ Implementation of the LXD client protocol in Haskell.+ .+ This module implements the LXD client protocol in Haskell using servant and+ websockets. It allows you to manage LXD containers and other resources+ directly from Haskell.+ .+ More information and a tutorial is in "Network.LXD.Client.Commands".+ .+ Accompanying blog post:+ <https://deliquus.com/posts/2017-10-02-using-servant-to-orchestrate-lxd-containers.md>+homepage: https://github.com/hverr/haskell-lxd-client#readme+license: GPL-3+license-file: LICENSE+author: Henri Verroken+maintainer: henriverroken@gmail.com+copyright: 2017 Henri Verroken+category: System+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Network.LXD.Client+ , Network.LXD.Client.API+ , Network.LXD.Client.Commands+ , Network.LXD.Client.Events+ , Network.LXD.Client.Internal.Prelude+ , Network.LXD.Client.Remotes+ , Network.LXD.Client.Types+ build-depends: base >= 4.7 && < 5+ , aeson+ , async+ , bimap+ , bytestring+ , connection+ , containers+ , data-default+ , directory+ , either+ , exceptions+ , filepath+ , http-api-data+ , http-client+ , http-client-tls+ , http-media+ , http-types+ , mtl+ , network+ , semigroups+ , servant+ , servant-client+ , text+ , tls+ , transformers+ , unix+ , websockets+ , x509+ , x509-store+ , x509-validation+ ghc-options: -Wall+ default-extensions: NoImplicitPrelude OverloadedStrings+ default-language: Haskell2010++executable lxd-client-example+ hs-source-dirs: example+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends: base+ , lxd-client+ default-language: Haskell2010++test-suite lxd-client-integration+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Integration.hs+ other-modules:+ build-depends: base+ , lxd-client+ , exceptions+ , hspec+ , hspec-core+ , random+ , text+ , turtle+ , uuid+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ default-extensions: NoImplicitPrelude OverloadedStrings+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/hverr/haskell-lxd-client
+ src/Network/LXD/Client.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+-- | This module exposes functionality to create LXD clients. These can+-- be used to communciate to an LXD daemon, either using the high-level+-- "Network.LXD.Client.Commands" module, or the low-level+-- "Network.LXD.Client.API" module.+--+-- __You are probably looking for "Network.LXD.Client.Commands"__, which+-- exposes a high-level interface to communicate with the LXD daemon.+--+-- If you are simply connecting to the LXD daemon on your local host,+-- you shouldn't import this module. The "Network.LXD.Client.Commands"+-- module probably re-exports enough functionality for your needs.+--+--+module Network.LXD.Client (+ module Network.LXD.Client.Types++ -- * LXD Host Management+ -- ** HTTPS Clients+ -- *** Types+, RemoteHost(..)+, ClientAuth(..)+, ServerAuth(..)+, Host, RemoteName, Certificate, Key, PrivateKey(..)+ -- *** Functions+, remoteHostClient+, remoteHostManager+, clientManager++ -- * Unix Clients+, LocalHost(..)+, localHostClient++ -- * WebSockets Clients+, runWebSocketsRemote+, runWebSocketsLocal+) where++import Network.LXD.Client.Internal.Prelude++import Control.Exception (SomeException, tryJust, toException, throwIO, bracket)++import Data.Default (Default, def)+import Data.Either.Combinators (mapLeft)+import Data.X509 (CertificateChain)+import Data.X509.Validation (ValidationCache,+ FailedReason(NameMismatch),+ ServiceID,+ validateDefault)+import Data.X509.CertificateStore (CertificateStore, readCertificateStore)+import qualified Data.ByteString.Lazy as B++import Network.LXD.Client.Types++import Network.Connection (ConnectionParams(..), TLSSettings(..), initConnectionContext)+import Network.HTTP.Client (Manager, ManagerSettings(..), newManager, defaultManagerSettings, socketConnection)+import Network.HTTP.Client.TLS (mkManagerSettings)+import Network.TLS (ClientHooks(onCertificateRequest, onServerCertificate),+ ClientParams(clientShared, clientHooks, clientSupported),+ Credential,+ Shared(sharedCAStore),+ Supported(supportedCiphers),+ credentialLoadX509,+ defaultParamsClient)+import Network.TLS.Extra.Cipher (ciphersuite_all)+import qualified Network.Connection as Con+import qualified Network.Socket as Socket+import qualified Network.WebSockets as WS+import qualified Network.WebSockets.Stream as WS++import Servant.Client (BaseUrl(..), ClientEnv(..), Scheme(Http, Https))++import System.Directory (getHomeDirectory)+import System.IO.Error (catchIOError, isEOFError)++type RemoteName = String+type Host = String+type Certificate = FilePath+type Key = FilePath++-- | A structure containing everything to connect to a remote LXD host.+data RemoteHost = RemoteHost {+ remoteHostHost :: Host -- ^ The remote host to use when querying the HTTP endpoint. (default=@127.0.0.1@)+ , remoteHostPort :: Int -- ^ The remote port to use when querying the HTTP endpoint. (default=@8443@)+ , remoteHostBasePath :: String -- ^ The base path to use when querying the HTTP endpoint. (default=@/@)+ , remoteHostClientKey :: ClientAuth -- ^ The client authentication to use when connecting.+ , remoteHostCertificate :: ServerAuth -- ^ The server certificate to trust.+}++instance Default RemoteHost where+ def = RemoteHost { remoteHostHost = ""+ , remoteHostPort = 8443+ , remoteHostBasePath = ""+ , remoteHostClientKey = DefaultClientAuth+ , remoteHostCertificate = DefaultCAStore }++-- | A structure containing everything to connect to a lcoal LXD host.+newtype LocalHost = LocalHost {+ localHostUnix :: FilePath -- ^ The path to the local unix socket.+ }++instance Default LocalHost where+ def = LocalHost { localHostUnix = "/var/lib/lxd/unix.socket" }++-- | Specifies the client authentication method.+data ClientAuth = NoClientAuth -- ^ Do not authenticate the client.+ | DefaultClientAuth -- ^ Look in @~/.config/lxc@ and fetch the client certificate.+ | ClientAuthKey PrivateKey -- ^ Use a custom private key.++data PrivateKey = PrivateKey Certificate Key++privateKey :: ClientAuth -> Maybe PrivateKey+privateKey NoClientAuth = Nothing+privateKey DefaultClientAuth = Just (PrivateKey "~/.config/lxc/client.crt" "~/.config/lxc/client.key")+privateKey (ClientAuthKey key) = Just key++-- | Specifies the server authentication method.+data ServerAuth = DefaultCAStore -- ^ Use the default CA store when checking the certificate.+ | DefaultServerAuth RemoteName -- ^ Look in @~/.config/lxc/servercerts@ and fetch the server certificate for+ -- the specified remote.+ | ServerAuth Certificate -- ^ Use a custom server certificate.++serverCertificate :: ServerAuth -> Maybe Certificate+serverCertificate DefaultCAStore = Nothing+serverCertificate (DefaultServerAuth remote) = Just ("~/.config/lxc/servercerts/" ++ remote ++ ".crt")+serverCertificate (ServerAuth cert) = Just cert++remoteHostManager :: (MonadError String m, MonadIO m) => RemoteHost -> m Manager+remoteHostManager RemoteHost{..} = clientManager remoteHostHost+ (privateKey remoteHostClientKey)+ (serverCertificate remoteHostCertificate)++remoteHostClient :: (MonadError String m, MonadIO m) => RemoteHost -> m ClientEnv+remoteHostClient remote@RemoteHost{..} =+ ClientEnv <$> remoteHostManager remote <*> pure baseUrl+ where+ baseUrl = BaseUrl Https remoteHostHost remoteHostPort remoteHostBasePath+++clientManager :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m Manager+clientManager = ((.).(.).(.)) (>>= newManager') clientManagerSettings+ where newManager' = liftIO . newManager++clientManagerSettings :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m ManagerSettings+clientManagerSettings host clientKey serverCert = do+ tlsSettings <- clientTlsSettings host clientKey serverCert+ return $ mkManagerSettings tlsSettings Nothing++clientTlsSettings :: (MonadError String m, MonadIO m) => Host -> Maybe PrivateKey -> Maybe Certificate -> m TLSSettings+clientTlsSettings host clientKey serverCert =+ clientTlsSettings' host <$> credentials clientKey <*> caStore serverCert+ where+ credentials Nothing = return Nothing+ credentials (Just (PrivateKey cert key)) = do+ cert' <- expandHomeDirectory cert+ key' <- expandHomeDirectory key+ creds <- liftIO . catchAdditional $ credentialLoadX509 cert' key'+ Just <$> eitherToError creds++ caStore Nothing = return Nothing+ caStore (Just cert) = Just <$> (eitherToError =<< liftIO (readCertificateStore' cert))+ readCertificateStore' cert = maybe (Left $ "error: could not read certificate at " ++ cert) Right <$> readCertificateStore cert++clientTlsSettings' :: Host -> Maybe Credential -> Maybe CertificateStore -> TLSSettings+clientTlsSettings' host creds caStore =+ TLSSettings clientParams+ where+ hooks = def { onCertificateRequest = const $ return creds+ , onServerCertificate = validateServerCert }+ clientParams = (defaultParamsClient host "")+ { clientShared = shared+ , clientHooks = hooks+ , clientSupported = def { supportedCiphers = ciphersuite_all }+ }+ shared | Just store <- caStore = def { sharedCAStore = store }+ | otherwise = def++clientConnectionParams :: (MonadError String m, MonadIO m) => RemoteHost -> m ConnectionParams+clientConnectionParams RemoteHost{..} = do+ tlsSettings <- clientTlsSettings remoteHostHost+ (privateKey remoteHostClientKey)+ (serverCertificate remoteHostCertificate)+ return ConnectionParams { connectionHostname = remoteHostHost+ , connectionPort = fromIntegral remoteHostPort+ , connectionUseSecure = Just tlsSettings+ , connectionUseSocks = Nothing }++localHostClient :: MonadIO m => LocalHost -> m ClientEnv+localHostClient host = do+ m <- liftIO $ newManager defaultManagerSettings { managerRawConnection = createUnixConnection }+ return $ ClientEnv m baseUrl+ where+ createUnixConnection = return $ \_ _ _ -> do+ s <- unixSocket host+ socketConnection s 4096+ baseUrl = BaseUrl Http "localhost" 80 ""++runWebSocketsRemote :: (MonadError String m, MonadIO m) => RemoteHost -> String -> WS.ClientApp a -> m a+runWebSocketsRemote host path app = do+ ctx <- liftIO initConnectionContext+ params <- clientConnectionParams host+ liftIO $ bracket (Con.connectTo ctx params)+ Con.connectionClose+ action+ where+ action con = do+ stream <- WS.makeStream (reader con) (writer con)+ WS.runClientWithStream stream+ (remoteHostHost host)+ path+ WS.defaultConnectionOptions+ []+ app++ reader con = catchIOError (Just <$> Con.connectionGetChunk con) $ \e ->+ if isEOFError e+ then return Nothing+ else throwIO e+ writer con bs = case bs of+ Nothing -> return ()+ Just bs' -> Con.connectionPut con (B.toStrict bs')++runWebSocketsLocal :: (MonadError String m, MonadIO m) => LocalHost -> String -> WS.ClientApp a -> m a+runWebSocketsLocal host path app = liftIO $ do+ s <- unixSocket host+ WS.runClientWithSocket s "localhost" path WS.defaultConnectionOptions [] app++validateServerCert :: CertificateStore+ -> ValidationCache+ -> ServiceID+ -> CertificateChain+ -> IO [FailedReason]+validateServerCert a b c d = filter (not . ignore) <$> validateDefault a b c d+ where ignore x | NameMismatch _ <- x = True+ | otherwise = False++unixSocket :: LocalHost -> IO Socket.Socket+unixSocket LocalHost{..} = do+ s <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+ Socket.connect s (Socket.SockAddrUnix localHostUnix)+ return s++catchAdditional :: IO (Either String a) -> IO (Either String a)+catchAdditional action = join . mapLeft show <$> tryJust (Just . toException') action+ where+ toException' :: SomeException -> SomeException+ toException' = toException++expandHomeDirectory :: MonadIO m => FilePath -> m FilePath+expandHomeDirectory ('~':'/':xs) = (++ "/" ++ xs) <$> liftIO getHomeDirectory+expandHomeDirectory x = return x++eitherToError :: MonadError err m => Either err a -> m a+eitherToError (Left x) = throwError x+eitherToError (Right x) = return x
+ src/Network/LXD/Client/API.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+-- | This module exposes a low-level Servant-built API for the LXD daemon.+--+-- You can query this API using Servant functions and a client created+-- from "Network.LXD.Client".+--+-- You probably want to use the commands exposed in+-- "Network.LXD.Client.Commands" instead.+module Network.LXD.Client.API (+ -- * API+ FailureResponse(..)+ -- ** Information+, supportedVersions+, apiConfig+, trustedCertificates++ -- ** Containers+ -- *** Querying informaiton+, containerNames+, containerCreate+, container+, containerDelete+ -- *** Configuration+, containerPut+, containerPatch+, containerRename+ -- *** State+, containerState+, containerPutState+ -- *** Executing commands+, containerExecImmediate+, containerExecWebsocketInteractive+, containerExecWebsocketNonInteractive+ -- *** Working with files+, WriteMode(..)+, containerGetPath+, containerPostPath+, containerDeletePath++ -- ** Images+, imageIds+, imageCreate+, imageAliases+, imageAlias+, image+, imageDelete++ -- ** Networks+, networkList+, networkCreate+, network+, networkPut+, networkPatch+, networkDelete++ -- ** Profiles+, profileList+, profileCreate+, profile+, profilePut+, profilePatch+, profileDelete++ -- ** Storage+, poolList+, poolCreate+, pool+, poolPut+, poolPatch+, poolDelete++ -- * Volumes+, volumeList+, volumeCreate+, volume+, volumePut+, volumePatch+, volumeDelete++ -- ** Operations+, operationIds+, operation+, operationCancel+, operationWait+, operationWebSocket++ -- ** WebSocket communciations+, readAllWebSocket+, writeAllWebSocket++ -- * Helpers+, ExecClient+) where++import Network.LXD.Client.Internal.Prelude++import Control.Concurrent (MVar, takeMVar)+import Control.Exception (Exception, catch, throwIO)+import Control.Monad.Reader (asks)++import Data.Aeson (FromJSON, Value, eitherDecode)+import Data.ByteString.Lazy (ByteString, toStrict)+import Data.List (find)+import Data.Maybe (catMaybes)+import Data.Proxy+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as Char8++import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Types.Header as HTTP+import qualified Network.HTTP.Types.Status as HTTP+import qualified Network.WebSockets as WS++import Servant.API+import Servant.Client hiding (FailureResponse)++import Web.HttpApiData (FromHttpApiData, ToHttpApiData, toHeader, parseHeader)++import Network.LXD.Client.Types++type API = Get '[JSON] (Response [ApiVersion])+ :<|> "1.0" :> Get '[JSON] (Response ApiConfig)+ :<|> "1.0" :> "certificates" :> Get '[JSON] (Response [CertificateHash])+ :<|> "1.0" :> "containers" :> Get '[JSON] (Response [ContainerName])+ :<|> "1.0" :> "containers" :> ReqBody '[JSON] ContainerCreateRequest :> Post '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> Get '[JSON] (Response Container)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> ReqBody '[JSON] ContainerDeleteRequest :> Delete '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> ReqBody '[JSON] ContainerPut :> Put '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> ReqBody '[JSON] ContainerPatch :> Patch '[JSON] (Response Value)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> ReqBody '[JSON] ContainerRename :> Post '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> "state" :> Get '[JSON] (Response ContainerState)+ :<|> "1.0" :> "containers" :> Capture "name" ContainerName :> "state" :> ReqBody '[JSON] ContainerPutState :> Put '[JSON] (AsyncResponse Value)+ :<|> ExecAPI 'ExecImmediate+ :<|> ExecAPI 'ExecWebsocketInteractive+ :<|> ExecAPI 'ExecWebsocketNonInteractive+ :<|> "1.0" :> "images" :> Get '[JSON] (Response [ImageId])+ :<|> "1.0" :> "images" :> ReqBody '[JSON] ImageCreateRequest :> Post '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "images" :> "aliases" :> Get '[JSON] (Response [ImageAliasName])+ :<|> "1.0" :> "images" :> "aliases" :> Capture "name" ImageAliasName :> Get '[JSON] (Response ImageAlias)+ :<|> "1.0" :> "images" :> Capture "id" ImageId :> Get '[JSON] (Response Image)+ :<|> "1.0" :> "images" :> Capture "id" ImageId :> ReqBody '[JSON] ImageDeleteRequest :> Delete '[JSON] (AsyncResponse Value)+ :<|> "1.0" :> "networks" :> Get '[JSON] (Response [NetworkName])+ :<|> "1.0" :> "networks" :> ReqBody '[JSON] NetworkCreateRequest :> Post '[JSON] (Response Value)+ :<|> "1.0" :> "networks" :> Capture "name" NetworkName :> Get '[JSON] (Response Network)+ :<|> "1.0" :> "networks" :> Capture "name" NetworkName :> ReqBody '[JSON] NetworkConfigRequest :> Put '[JSON] (Response Value)+ :<|> "1.0" :> "networks" :> Capture "name" NetworkName :> ReqBody '[JSON] NetworkConfigRequest :> Patch '[JSON] (Response Value)+ :<|> "1.0" :> "networks" :> Capture "name" NetworkName :> Delete '[JSON] (Response Value)+ :<|> "1.0" :> "profiles" :> Get '[JSON] (Response [ProfileName])+ :<|> "1.0" :> "profiles" :> ReqBody '[JSON] ProfileCreateRequest :> Post '[JSON] (Response Value)+ :<|> "1.0" :> "profiles" :> Capture "name" ProfileName :> Get '[JSON] (Response Profile)+ :<|> "1.0" :> "profiles" :> Capture "name" ProfileName :> ReqBody '[JSON] ProfileConfigRequest :> Put '[JSON] (Response Value)+ :<|> "1.0" :> "profiles" :> Capture "name" ProfileName :> ReqBody '[JSON] ProfileConfigRequest :> Patch '[JSON] (Response Value)+ :<|> "1.0" :> "profiles" :> Capture "name" ProfileName :> Delete '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Get '[JSON] (Response [PoolName])+ :<|> "1.0" :> "storage-pools" :> ReqBody '[JSON] PoolCreateRequest :> Post '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "name" PoolName :> Get '[JSON] (Response Pool)+ :<|> "1.0" :> "storage-pools" :> Capture "name" PoolName :> ReqBody '[JSON] PoolConfigRequest :> Put '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "name" PoolName :> ReqBody '[JSON] PoolConfigRequest :> Patch '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "name" PoolName :> Delete '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> Get '[JSON] (Response [VolumeName])+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> ReqBody '[JSON] VolumeCreateRequest :> Post '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> Capture "type" VolumeType :> Capture "volume" VolumeName :> Get '[JSON] (Response Volume)+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> Capture "type" VolumeType :> Capture "volume" VolumeName :> ReqBody '[JSON] VolumeConfigRequest :> Put '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> Capture "type" VolumeType :> Capture "volume" VolumeName :> ReqBody '[JSON] VolumeConfigRequest :> Patch '[JSON] (Response Value)+ :<|> "1.0" :> "storage-pools" :> Capture "pool" PoolName :> "volumes" :> Capture "type" VolumeType :> Capture "volume" VolumeName :> Delete '[JSON] (Response Value)+ :<|> "1.0" :> "operations" :> Get '[JSON] (Response AllOperations)+ :<|> "1.0" :> "operations" :> Capture "uuid" OperationId :> Get '[JSON] (Response Operation)+ :<|> "1.0" :> "operations" :> Capture "uuid" OperationId :> Delete '[JSON] (Response Value)+ :<|> "1.0" :> "operations" :> Capture "uuid" OperationId :> "wait" :> Get '[JSON] (Response Operation)+++api :: Proxy API+api = Proxy++supportedVersions :: ClientM (Response [ApiVersion])+apiConfig :: ClientM (Response ApiConfig)+trustedCertificates :: ClientM (Response [CertificateHash])+containerNames :: ClientM (Response [ContainerName])+containerCreate :: ContainerCreateRequest -> ClientM (AsyncResponse Value)+container :: ContainerName -> ClientM (Response Container)+containerDelete :: ContainerName -> ContainerDeleteRequest -> ClientM (AsyncResponse Value)+containerPut :: ContainerName -> ContainerPut -> ClientM (AsyncResponse Value)+containerPatch :: ContainerName -> ContainerPatch -> ClientM (Response Value)+containerRename :: ContainerName -> ContainerRename -> ClientM (AsyncResponse Value)+containerState :: ContainerName -> ClientM (Response ContainerState)+containerPutState :: ContainerName -> ContainerPutState -> ClientM (AsyncResponse Value)+containerExecImmediate :: ExecClient 'ExecImmediate+containerExecWebsocketInteractive :: ExecClient 'ExecWebsocketInteractive+containerExecWebsocketNonInteractive :: ExecClient 'ExecWebsocketNonInteractive+imageIds :: ClientM (Response [ImageId])+imageCreate :: ImageCreateRequest -> ClientM (AsyncResponse Value)+imageAliases :: ClientM (Response [ImageAliasName])+imageAlias :: ImageAliasName -> ClientM (Response ImageAlias)+image :: ImageId -> ClientM (Response Image)+imageDelete :: ImageId -> ImageDeleteRequest -> ClientM (AsyncResponse Value)+networkList :: ClientM (Response [NetworkName])+networkCreate :: NetworkCreateRequest -> ClientM (Response Value)+network :: NetworkName -> ClientM (Response Network)+networkPut :: NetworkName -> NetworkConfigRequest -> ClientM (Response Value)+networkPatch :: NetworkName -> NetworkConfigRequest -> ClientM (Response Value)+networkDelete :: NetworkName -> ClientM (Response Value)+profileList :: ClientM (Response [ProfileName])+profileCreate :: ProfileCreateRequest -> ClientM (Response Value)+profile :: ProfileName -> ClientM (Response Profile)+profilePut :: ProfileName -> ProfileConfigRequest -> ClientM (Response Value)+profilePatch :: ProfileName -> ProfileConfigRequest -> ClientM (Response Value)+profileDelete :: ProfileName -> ClientM (Response Value)+poolList :: ClientM (Response [PoolName])+poolCreate :: PoolCreateRequest -> ClientM (Response Value)+pool :: PoolName -> ClientM (Response Pool)+poolPut :: PoolName -> PoolConfigRequest -> ClientM (Response Value)+poolPatch :: PoolName -> PoolConfigRequest -> ClientM (Response Value)+poolDelete :: PoolName -> ClientM (Response Value)+volumeList :: PoolName -> ClientM (Response [VolumeName])+volumeCreate :: PoolName -> VolumeCreateRequest -> ClientM (Response Value)+volume' :: PoolName -> VolumeType -> VolumeName -> ClientM (Response Volume)+volumePut' :: PoolName -> VolumeType -> VolumeName -> VolumeConfigRequest -> ClientM (Response Value)+volumePatch' :: PoolName -> VolumeType -> VolumeName -> VolumeConfigRequest -> ClientM (Response Value)+volumeDelete' :: PoolName -> VolumeType -> VolumeName -> ClientM (Response Value)+operationIds :: ClientM (Response AllOperations)+operation :: OperationId -> ClientM (Response Operation)+operationCancel :: OperationId -> ClientM (Response Value)+operationWait :: OperationId -> ClientM (Response Operation)++supportedVersions :<|>+ apiConfig :<|>+ trustedCertificates :<|>+ containerNames :<|>+ containerCreate :<|>+ container :<|>+ containerDelete :<|>+ containerPut :<|>+ containerPatch :<|>+ containerRename :<|>+ containerState :<|>+ containerPutState :<|>+ containerExecImmediate :<|>+ containerExecWebsocketInteractive :<|>+ containerExecWebsocketNonInteractive :<|>+ imageIds :<|>+ imageCreate :<|>+ imageAliases :<|>+ imageAlias :<|>+ image :<|>+ imageDelete :<|>+ networkList :<|>+ networkCreate :<|>+ network :<|>+ networkPut :<|>+ networkPatch :<|>+ networkDelete :<|>+ profileList :<|>+ profileCreate :<|>+ profile :<|>+ profilePut :<|>+ profilePatch :<|>+ profileDelete :<|>+ poolList :<|>+ poolCreate :<|>+ pool :<|>+ poolPut :<|>+ poolPatch :<|>+ poolDelete :<|>+ volumeList :<|>+ volumeCreate :<|>+ volume' :<|>+ volumePut' :<|>+ volumePatch' :<|>+ volumeDelete' :<|>+ operationIds :<|>+ operation :<|>+ operationCancel :<|>+ operationWait+ = client api++volume :: PoolName -> VolumeName -> ClientM (Response Volume)+volume p v@(VolumeName t _) = volume' p t v++volumePut :: PoolName -> VolumeName -> VolumeConfigRequest -> ClientM (Response Value)+volumePut p v@(VolumeName t _) = volumePut' p t v++volumePatch :: PoolName -> VolumeName -> VolumeConfigRequest -> ClientM (Response Value)+volumePatch p v@(VolumeName t _) = volumePatch' p t v++volumeDelete :: PoolName -> VolumeName -> ClientM (Response Value)+volumeDelete p v@(VolumeName t _) = volumeDelete' p t v++containerGetPath :: ContainerName -> FilePath -> ClientM PathResponse+containerGetPath name fp = do+ req <- pathRequest name fp+ res <- performRequest req+ let lookupHdr :: FromHttpApiData a => HTTP.HeaderName -> ClientM a+ lookupHdr n = lookupHdr' n (Client.responseHeaders res)++ hType <- lookupHdr "X-LXD-Type"+ hUid <- lookupHdr "X-LXD-Uid"+ hGid <- lookupHdr "X-LXD-Gid"+ hMode <- lookupHdr "X-LXD-Mode"+ case fileResponse hType (Client.responseBody res) of+ Left err -> error' $ "Could not decode " ++ show hType ++ ": " ++ err+ Right file -> return PathResponse {+ pathUid = hUid+ , pathGid = hGid+ , pathMode = hMode+ , pathType = hType+ , getFile = file+ }+ where+ lookupHdr' :: FromHttpApiData a => HTTP.HeaderName -> [HTTP.Header] -> ClientM a+ lookupHdr' n xs = case find ((== n) . fst) xs of+ Nothing -> error' $ "Missing header in response: " ++ show n+ Just (_, v) -> case parseHeader v of+ Left err -> error' $ "Could not decode header " ++ show n+ ++ " with value " ++ show v ++ ": " ++ show err+ Right v' -> return v'++ error' = liftIO . throwIO . DecodeError++data WriteMode = ModeOverwrite | ModeAppend deriving (Show)++containerPostPath :: ContainerName+ -> FilePath+ -> Maybe Uid+ -> Maybe Gid+ -> Maybe FileMode+ -> FileType+ -> Maybe WriteMode+ -> ByteString+ -> ClientM (Response Value)+containerPostPath name fp uid gid perm ftype mode body = do+ req <- pathRequest name fp+ let hdrs = catMaybes [ hdr "X-LXD-Uid" <$> uid+ , hdr "X-LXD-Gid" <$> gid+ , hdr "X-LXD-Mode" <$> perm+ , hdr "X-LXD-Type" <$> Just ftype+ , hdr "X-LXD-Write" . mode' <$> mode ]+ let req' = req { Client.requestHeaders = hdrs+ , Client.requestBody = Client.RequestBodyLBS body }++ performJsonRequest req'+ where+ mode' ModeOverwrite = "overwrite" :: Text+ mode' ModeAppend = "append"++ hdr :: ToHttpApiData v => HTTP.HeaderName -> v -> HTTP.Header+ hdr n v = (n, toHeader v)++containerDeletePath :: ContainerName -> FilePath -> ClientM (Response Value)+containerDeletePath name fp = do+ res <- pathRequest name fp+ performJsonRequest $ res { Client.method = "DELETE" }++operationWebSocket :: OperationId -> Secret -> String+operationWebSocket (OperationId oid) (Secret secret) =+ "/1.0/operations/" ++ oid ++ "/websocket?secret=" ++ secret++readAllWebSocket :: (ByteString -> IO ()) -> WS.ClientApp ()+readAllWebSocket f con = do+ m <- (Just <$> WS.receiveDataMessage con) `catch` handle'+ case m of Nothing -> return ()+ Just (WS.Text _) -> WS.sendClose con BL.empty+ Just (WS.Binary bs) -> f bs+ >> readAllWebSocket f con+ where+ handle' (WS.CloseRequest _ _) = return Nothing+ handle' e = throwIO e++writeAllWebSocket :: MVar (Maybe ByteString) -> WS.ClientApp ()+writeAllWebSocket input con = do+ i <- takeMVar input+ case i of+ Nothing -> WS.sendClose con BL.empty+ Just bs -> WS.sendBinaryData con bs+ >> writeAllWebSocket input con++type ExecAPI a = "1.0" :> "containers" :> Capture "name" ContainerName :> "exec" :> ReqBody '[JSON] (ExecRequest a) :> Post '[JSON] (AsyncResponse (ExecResponseMetadata a))++type ExecClient a = ContainerName -> ExecRequest a -> ClientM (AsyncResponse (ExecResponseMetadata a))++pathRequest :: ContainerName -> FilePath -> ClientM Client.Request+pathRequest (ContainerName name) fp = do+ BaseUrl{..} <- askBaseUrl+ return Client.defaultRequest {+ Client.method = "GET"+ , Client.host = fromString baseUrlHost+ , Client.port = baseUrlPort+ , Client.path = toStrict $ fromString baseUrlPath <> "/1.0/containers/" <> Char8.pack name <> "/files"+ , Client.queryString = toStrict $ "?path=" <> Char8.pack fp+ }++performRequest :: Client.Request -> ClientM (Client.Response ByteString)+performRequest req = do+ m <- askManager+ r <- liftIO $ Client.httpLbs req m++ let status = Client.responseStatus r+ statusCode' = HTTP.statusCode status+ unless (statusCode' >= 200 && statusCode' < 300) $+ liftIO . throwIO $ FailureResponse req r+ return r++performJsonRequest :: FromJSON a => Client.Request -> ClientM a+performJsonRequest req = do+ res <- performRequest req+ case eitherDecode (Client.responseBody res) of+ Left err -> liftIO . throwIO . DecodeError $ "Could not decode JSON body: " ++ err+ Right v -> return v++-- | Exception thrown in 'containerGetPath', 'containerDeletePath' and+-- 'containerPostPath'.+data FailureResponse = FailureResponse Client.Request (Client.Response ByteString) deriving (Show)++instance Exception FailureResponse where++-- | Exception thrown in 'containerGetPath', 'containerDeletePath' and+-- 'containerPostPath'.+newtype DecodeError = DecodeError String deriving (Show)++instance Exception DecodeError where++askBaseUrl :: ClientM BaseUrl+askBaseUrl = asks $ \(ClientEnv _ url) -> url++askManager :: ClientM Client.Manager+askManager = asks $ \(ClientEnv mgr _) -> mgr
+ src/Network/LXD/Client/Commands.hs view
@@ -0,0 +1,755 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+-- | This module implements commands to communicate with the LXD daemon+-- over its REST API.+--+-- More information about LXD: <https://github.com/lxc/lxd>+--+-- This module implements a high-level interface, and is probably what+-- you need. It uses the lower-level interface implemented in+-- "Network.LXD.Client.API", but unless you are a power user, you+-- shouldn't need this module.+--+-- Accompanying blog post:+-- <https://deliquus.com/posts/2017-10-02-using-servant-to-orchestrate-lxd-containers.md>+--+module Network.LXD.Client.Commands (+ -- * How to use this library+ -- $use++ -- * Re-exports+ def+, module Network.LXD.Client.Remotes+, module Network.LXD.Client.Types++ -- * Running commands+, Host(..)+, HasClient(..)+, defaultClientEnv+, WithLocalHost, runWithLocalHost+, WithRemoteHost, runWithRemoteHost++ -- * API+, lxcApi+ -- * Containers+, lxcList+, lxcCreate+, lxcDelete+, lxcInfo+, lxcStart+, lxcStop+, lxcRestart+, lxcFreeze+, lxcUnfreeze++ -- * Exec+, lxcExec+, lxcExecEnv+, lxcExecRaw++ -- * Files and directories+ -- ** Deletion+, lxcFileDelete+ -- ** Files+, lxcFilePull+, lxcFilePullRaw+, lxcFilePush+, lxcFilePushAttrs+, lxcFilePushRaw+, lxcFilePushRawAttrs+ -- ** Directories+, lxcFileListDir+, lxcFileMkdir+, lxcFileMkdirTemplate+, lxcFileMkdirAttrs+ -- ** Recursive+, lxcFilePullRecursive+, lxcFilePushRecursive+, lxcFilePushRecursiveAttrs++ -- * Images+, lxcImageList+, lxcImageAliases+, lxcImageInfo+, lxcImageAlias+, lxcImageCreate+, lxcImageDelete++ -- * Networks+, lxcNetworkList+, lxcNetworkCreate+, lxcNetworkInfo+, lxcNetworkConfig+, lxcNetworkDelete++ -- * Profiles+, lxcProfileList+, lxcProfileCreate+, lxcProfileInfo+, lxcProfileConfig+, lxcProfileDelete++ -- * Storage+, lxcStorageList+, lxcStorageCreate+, lxcStorageInfo+, lxcStorageConfig+, lxcStorageDelete++ -- * Volume+, lxcVolumeList+, lxcVolumeCreate+, lxcVolumeInfo+, lxcVolumeConfig+, lxcVolumeDelete+) where++import Network.LXD.Client.Internal.Prelude++import Control.Concurrent.Async (Async, async, withAsync, wait, uninterruptibleCancel)+import Control.Concurrent.MVar+import Control.Monad ((>=>))+import Control.Monad.Catch (Exception, SomeException, MonadThrow, throwM, MonadCatch, catch, MonadMask, bracket)+import Control.Monad.State (StateT, evalStateT, gets, modify')++import Data.ByteString.Lazy (ByteString)+import Data.Default (def)+import Data.List (inits)+import Data.Map.Strict (Map)+import qualified Data.Aeson.Types as Aeson+import qualified Data.ByteString.Lazy as BL++import Numeric (readOct, showOct)+import qualified Network.WebSockets as WS++import Servant.Client (ClientM, ClientEnv, runClientM)+import System.Directory (createDirectory, doesDirectoryExist, listDirectory)+import System.FilePath ((</>), splitPath)+import System.Posix.Files (getFileStatus, fileMode, setFileMode)+import qualified System.IO as IO++import Network.LXD.Client hiding (Host)+import Network.LXD.Client.API+import Network.LXD.Client.Types+import Network.LXD.Client.Events+import Network.LXD.Client.Remotes++-- | A host that can be connected to.+data Host = HLocalHost LocalHost+ | HRemoteHost RemoteHost++-- | Monad with access to a 'ClientEnv'.+class (MonadIO m, MonadMask m) => HasClient m where+ -- | Return the LXD remote host to connect to.+ askHost :: m Host++ -- | Return the 'ClientEnv' to use when connecting to the LXD host.+ --+ -- Returns 'defaultClientEnv' by default.+ askClientEnv :: m ClientEnv+ askClientEnv = defaultClientEnv++-- | Create a default 'ClientEnv'.+defaultClientEnv :: HasClient m => m ClientEnv+defaultClientEnv = do+ host <- askHost+ liftIO (runExceptT $ client host) >>= \case+ Left err -> throwM $ ClientError err+ Right env -> return env+ where+ client (HLocalHost host) = localHostClient host+ client (HRemoteHost host) = remoteHostClient host++-- | Run a web sockets application using.+runWebSockets :: Host -> String -> WS.ClientApp a -> IO a+runWebSockets host' path app =+ runExceptT runWS >>= \case+ Left err -> throwM $ ClientError err+ Right env -> return env+ where+ runWS | HLocalHost host <- host' = runWebSocketsLocal host path app+ | HRemoteHost host <- host' = runWebSocketsRemote host path app++-- | Monad with access to a local host.+newtype WithLocalHost a = WithLocalHost (StateT (LocalHost, Maybe ClientEnv) IO a)+ deriving (Applicative, Functor, Monad, MonadIO, MonadCatch, MonadThrow, MonadMask)++instance HasClient WithLocalHost where+ askHost = WithLocalHost . gets $ HLocalHost . fst+ askClientEnv = do+ env <- WithLocalHost . gets $ snd+ case env of+ Just env' -> return env'+ Nothing -> do+ env' <- defaultClientEnv+ WithLocalHost . modify' $ \(x, _) -> (x, Just env')+ return env'++-- | Run a 'WithLocalHost' monad+runWithLocalHost :: LocalHost -> WithLocalHost a -> IO a+runWithLocalHost host (WithLocalHost m) = evalStateT m (host, Nothing)++-- | Monad with access to a remote host.+newtype WithRemoteHost a = WithRemoteHost (StateT (RemoteHost, Maybe ClientEnv) IO a)+ deriving (Applicative, Functor, Monad, MonadIO, MonadCatch, MonadThrow, MonadMask)++instance HasClient WithRemoteHost where+ askHost = WithRemoteHost . gets $ HRemoteHost . fst+ askClientEnv = do+ env <- WithRemoteHost . gets $ snd+ case env of+ Just env' -> return env'+ Nothing -> do+ env' <- defaultClientEnv+ WithRemoteHost . modify' $ \(x, _) -> (x, Just env')+ return env'++-- | Run a 'WithRemoteHost' monad+runWithRemoteHost :: RemoteHost -> WithRemoteHost a -> IO a+runWithRemoteHost host (WithRemoteHost m) = evalStateT m (host, Nothing)++-- | Get information about the API.+lxcApi :: HasClient m => m ApiConfig+lxcApi = runClient $ apiConfig >>= checkResponseOK++-- | List all container names.+lxcList :: HasClient m => m [ContainerName]+lxcList = runClient $ containerNames >>= checkResponseOK++-- | Create a new container.+lxcCreate :: HasClient m => ContainerCreateRequest -> m ()+lxcCreate req = runAndWait $ containerCreate req >>= checkResponseCreated++-- | Delete a container.+lxcDelete :: HasClient m => ContainerName -> m ()+lxcDelete n = runAndWait $ containerDelete n ContainerDeleteRequest+ >>= checkResponseCreated++-- | Get information about a container.+lxcInfo :: HasClient m => ContainerName -> m Container+lxcInfo = runClient . (container >=> checkResponseOK)++-- | Start a contianer.+lxcStart :: HasClient m => ContainerName -> m ()+lxcStart name = runAndWait $ containerPutState name s >>= checkResponseCreated+ where s = containerNewState Start False++-- | Stop a container.+--+-- The second flag forces the action.+lxcStop :: HasClient m => ContainerName -> Bool -> m ()+lxcStop name force = runAndWait $ containerPutState name s >>= checkResponseCreated+ where s = containerNewState Stop force++-- | Restart a container.+--+-- The second flag forces the action.+lxcRestart :: HasClient m => ContainerName -> Bool -> m ()+lxcRestart name force = runAndWait $ containerPutState name s >>= checkResponseCreated+ where s = containerNewState Restart force++-- | Freeze a container.+lxcFreeze :: HasClient m => ContainerName -> m ()+lxcFreeze name = runAndWait $ containerPutState name s >>= checkResponseCreated+ where s = containerNewState Freeze False++-- | Unfreeze a container.+lxcUnfreeze :: HasClient m => ContainerName -> m ()+lxcUnfreeze name = runAndWait $ containerPutState name s >>= checkResponseCreated+ where s = containerNewState Unfreeze False++-- | Execute a command, catch standard output, print stderr.+lxcExec :: HasClient m+ => ContainerName -- ^ Container name+ -> String -- ^ Command name+ -> [String] -- ^ Command arguments+ -> ByteString -- ^ Standard input+ -> m ByteString+lxcExec name cmd args = lxcExecEnv name cmd args mempty++-- | Execute a command, provide environment variables, catch standard output,+-- print stderr.+lxcExecEnv :: HasClient m+ => ContainerName -- ^ Container name+ -> String -- ^ Command name+ -> [String] -- ^ Command arguments+ -> Map String String -- ^ Environment variables+ -> ByteString -- ^ Standard input+ -> m ByteString+lxcExecEnv name cmd args env stdin' = do+ stdin <- liftIO newEmptyMVar+ stdout <- liftIO newEmptyMVar+ stderr <- liftIO newEmptyMVar+ bs <- liftIO $ newMVar mempty++ let printStderr :: IO ()+ printStderr = takeMVar stderr+ >>= BL.hPut IO.stdout+ >> IO.hFlush IO.stdout+ >> printStderr++ let saveStdout :: IO ()+ saveStdout = do bs' <- takeMVar stdout+ modifyMVar_ bs $ return . (<> bs')++ exec <- lxcExecRaw name cmd args env stdin stdout stderr+ liftIO $+ withAsync printStderr $ \_ ->+ withAsync saveStdout $ \_ -> do+ unless (BL.null stdin') $ putMVar stdin (Just stdin')+ putMVar stdin Nothing+ wait exec++ liftIO $ takeMVar bs++-- | Execute a command, with given environment variables.+lxcExecRaw :: HasClient m+ => ContainerName -- ^ Container name+ -> String -- ^ Command name+ -> [String] -- ^ Command arguments+ -> Map String String -- ^ Environment variables+ -> MVar (Maybe ByteString) -- ^ Stream of standard input, pass 'Nothing' to end the stream.+ -> MVar ByteString -- ^ Standard output+ -> MVar ByteString -- ^ Standard error+ -> m (Async ())+lxcExecRaw name cmd args env stdin stdout stderr = do+ resp <- runClient $ containerExecWebsocketNonInteractive name req+ md <- checkResponseCreatedMetadata resp+ let oid = responseOperation resp+ fds = execResponseMetadataWebsocketFds md+ stdout' = operationWebSocket oid (fdsAllStdout fds)+ stderr' = operationWebSocket oid (fdsAllStderr fds)+ stdin' = operationWebSocket oid (fdsAllStdin fds)++ host <- askHost+ let runWS = runWebSockets host++ liftIO . async $+ withAsync (runWS stdout' $ readAllWebSocket (putMVar stdout)) $ \stdoutThread ->+ withAsync (runWS stderr' $ readAllWebSocket (putMVar stderr)) $ \stderrThread ->+ withAsync (runWS stdin' $ writeAllWebSocket stdin) $ \stdinThread -> do+ wait stdoutThread+ wait stderrThread+ wait stdinThread+ where+ req = def { execRequestCommand = cmd:args+ , execRequestEnvironment = env }++-- | Delete a file or empty directory from an LXD container.+lxcFileDelete :: HasClient m => ContainerName -> FilePath -> m ()+lxcFileDelete name fp = void . runClient $ containerDeletePath name fp++-- | Pull the file contents from an LXD container.+lxcFilePull :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the container+ -> FilePath -- ^ Destination path, in the host+ -> m ()+lxcFilePull name src dst = do+ path <- runClient $ containerGetPath name src+ case getFile path of+ Directory _ -> throwM $ ClientError "expected a file, but got a directory"+ File bs -> do+ m' <- convFileMode' $ pathMode path+ liftIO $ BL.writeFile dst bs+ liftIO $ setFileMode dst m'++ lxcFilePullRaw name src >>= liftIO . BL.writeFile dst++-- | Pull the file contents from an LXD container, return the lazy bytestring.+lxcFilePullRaw :: HasClient m => ContainerName -> FilePath -> m ByteString+lxcFilePullRaw name src = do+ path <- runClient $ containerGetPath name src+ case getFile path of+ File bs -> return bs+ Directory _ -> throwM $ ClientError "expected a file, but got a directory"++-- | Push the file contents to an LXD container.+lxcFilePush :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the host+ -> FilePath -- ^ Destination path, in the container+ -> m ()+lxcFilePush name src dst = lxcFilePushAttrs name src dst Nothing Nothing++-- | Push the fole contents to an LXD container, with the given attributes.+lxcFilePushAttrs :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the host+ -> FilePath -- ^ Destination path, in the container+ -> Maybe Uid+ -> Maybe Gid+ -> m ()+lxcFilePushAttrs name src dst uid gid = do+ mode <- liftIO $ fileMode <$> getFileStatus src+ bs <- liftIO $ BL.readFile src+ lxcFilePushRawAttrs name dst+ uid gid+ (Just $ convFileMode mode)+ "file"+ Nothing+ bs++-- | Write the lazy bytestring to a file in an LXD container.+lxcFilePushRaw :: HasClient m => ContainerName -> FilePath -> ByteString -> m ()+lxcFilePushRaw name src = lxcFilePushRawAttrs name src n n n "file" n where n = Nothing++-- | Write the lazy bytestring to a file in an LXD container, with given file+-- attributes.+lxcFilePushRawAttrs :: HasClient m+ => ContainerName+ -> FilePath+ -> Maybe Uid+ -> Maybe Gid+ -> Maybe FileMode+ -> FileType+ -> Maybe WriteMode+ -> ByteString+ -> m ()+lxcFilePushRawAttrs name src uid gid fm ft wm bs = void . runClient $+ containerPostPath name src uid gid fm ft wm bs >>= checkResponseOK++-- | Create a directory using a host directory as a template.+--+-- Note that this function doesn't copy the directory contents. Use+-- 'lxcFilePushRecursive' if you want to copy the directory contents as well.+lxcFileMkdirTemplate :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the host+ -> FilePath -- ^ Destination path, in the container+ -> m ()+lxcFileMkdirTemplate name src dst = do+ mode <- liftIO $ fileMode <$> getFileStatus src+ lxcFileMkdirAttrs name dst False Nothing Nothing (Just $ convFileMode mode)++-- | List all entries in a directory, without @.@ or @..@.+lxcFileListDir :: HasClient m => ContainerName -> FilePath -> m [String]+lxcFileListDir name fp = do+ path <- runClient $ containerGetPath name fp+ case getFile path of+ File _ -> throwM $ ClientError "expected a directory, but got a file"+ Directory r -> checkResponseOK r++-- | Create a directory.+lxcFileMkdir :: HasClient m+ => ContainerName+ -> String+ -> Bool -- ^ Create parent directories+ -> m ()+lxcFileMkdir name dir p = lxcFileMkdirAttrs name dir p Nothing Nothing Nothing++-- | Create a directory, with given attributes.+lxcFileMkdirAttrs :: HasClient m+ => ContainerName+ -> String+ -> Bool -- ^ Create parent directories+ -> Maybe Uid+ -> Maybe Gid+ -> Maybe FileMode+ -> m ()+lxcFileMkdirAttrs name dir False uid gid fm = void . runClient $+ containerPostPath name dir uid gid fm "directory" Nothing mempty+lxcFileMkdirAttrs name dir True uid gid fm =+ mapM_ mkdir $ inits (splitPath dir)+ where+ mkdir xs = case concat xs of+ "/" -> return ()+ path -> do+ pathInfo <- runClient $ (Just <$> containerGetPath name path) `catch` ignoreExc+ case getFile <$> pathInfo of+ Just (File _) -> throwM $ ClientError $ "couldn't make dir " ++ dir ++ ": " ++ path ++ " is not a directory"+ Just (Directory _) -> return ()+ Nothing -> lxcFileMkdirAttrs name dir False uid gid fm++ ignoreExc :: Monad m => SomeException -> m (Maybe a)+ ignoreExc _ = return Nothing++-- | Recursively pull a directory (or file) from a container.+lxcFilePullRecursive :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the container+ -> FilePath -- ^ Destination path, in the host+ -> m ()+lxcFilePullRecursive name src dst = do+ path <- runClient $ containerGetPath name src+ m' <- convFileMode' $ pathMode path+ case getFile path of+ File bs -> do+ liftIO $ BL.writeFile dst bs+ liftIO $ setFileMode dst m'+ Directory resp -> do+ contents <- checkResponseOK resp+ liftIO $ createDirectory dst+ mapM_ go contents+ liftIO $ setFileMode dst m'+ where+ go file = lxcFilePullRecursive name src' dst'+ where src' = src </> file+ dst' = dst </> file++-- | Recursively push a directory (or file) to a container.+lxcFilePushRecursive :: HasClient m+ => ContainerName -- ^ Container name+ -> FilePath -- ^ Source path, in the host+ -> FilePath -- ^ Destination path, in the container+ -> m ()+lxcFilePushRecursive name src dst = lxcFilePushRecursiveAttrs name src dst Nothing Nothing++-- | Recursively push a directory (or file) to a container, with given file+-- attributes.+lxcFilePushRecursiveAttrs :: HasClient m+ => ContainerName+ -> FilePath -- ^ Souce path, in the host+ -> FilePath -- ^ Destination path, in the container+ -> Maybe Uid+ -> Maybe Gid+ -> m ()+lxcFilePushRecursiveAttrs name src dst uid gid = do+ isDir <- liftIO $ doesDirectoryExist src+ if not isDir+ then lxcFilePushAttrs name src dst uid gid+ else do+ lxcFileMkdirTemplate name src dst+ files <- liftIO $ listDirectory src+ mapM_ go files+ where+ go file = lxcFilePushRecursiveAttrs name src' dst' uid gid+ where src' = src </> file+ dst' = dst </> file++-- | List all image IDs.+lxcImageList :: HasClient m => m [ImageId]+lxcImageList = runClient $ imageIds >>= checkResponseOK++-- | List al image aliases.+lxcImageAliases :: HasClient m => m [ImageAliasName]+lxcImageAliases = runClient $ imageAliases >>= checkResponseOK++-- | Get image information.+lxcImageInfo :: HasClient m => ImageId -> m Image+lxcImageInfo = runClient . image >=> checkResponseOK++-- | Get image alias information.+lxcImageAlias :: HasClient m => ImageAliasName -> m ImageAlias+lxcImageAlias = runClient . imageAlias >=> checkResponseOK++-- | Create an image.+lxcImageCreate :: HasClient m => ImageCreateRequest -> m ()+lxcImageCreate req = runAndWait $ imageCreate req >>= checkResponseCreated++-- | Delete an image.+lxcImageDelete :: HasClient m => ImageId -> m ()+lxcImageDelete img = runAndWait $ imageDelete img def >>= checkResponseCreated++-- | List all networks+lxcNetworkList :: HasClient m => m [NetworkName]+lxcNetworkList = runClient $ networkList >>= checkResponseOK++-- | Create a network.+lxcNetworkCreate :: HasClient m => NetworkCreateRequest -> m ()+lxcNetworkCreate n = void . runClient $ networkCreate n >>= checkResponseOK++-- | Get network information.+lxcNetworkInfo :: HasClient m => NetworkName -> m Network+lxcNetworkInfo n = runClient $ network n >>= checkResponseOK++-- | Configure a network.+lxcNetworkConfig :: HasClient m => NetworkName -> NetworkConfigRequest -> m ()+lxcNetworkConfig n c = void . runClient $ networkPatch n c >>= checkResponseOK++-- | Delete a network+lxcNetworkDelete :: HasClient m => NetworkName -> m ()+lxcNetworkDelete n = void . runClient $ networkDelete n >>= checkResponseOK++-- | List all profiles+lxcProfileList :: HasClient m => m [ProfileName]+lxcProfileList = runClient $ profileList >>= checkResponseOK++-- | Create a profile.+lxcProfileCreate :: HasClient m => ProfileCreateRequest -> m ()+lxcProfileCreate n = void . runClient $ profileCreate n >>= checkResponseOK++-- | Get profile information.+lxcProfileInfo :: HasClient m => ProfileName -> m Profile+lxcProfileInfo n = runClient $ profile n >>= checkResponseOK++-- | Configure a profile.+lxcProfileConfig :: HasClient m => ProfileName -> ProfileConfigRequest -> m ()+lxcProfileConfig n c = void . runClient $ profilePatch n c >>= checkResponseOK++-- | Delete a profile+lxcProfileDelete :: HasClient m => ProfileName -> m ()+lxcProfileDelete n = void . runClient $ profileDelete n >>= checkResponseOK++-- | List all storage pools+lxcStorageList :: HasClient m => m [PoolName]+lxcStorageList = runClient $ poolList >>= checkResponseOK++-- | Create a storage pool.+lxcStorageCreate :: HasClient m => PoolCreateRequest -> m ()+lxcStorageCreate n = void . runClient $ poolCreate n >>= checkResponseOK++-- | Get storage pool information.+lxcStorageInfo :: HasClient m => PoolName -> m Pool+lxcStorageInfo n = runClient $ pool n >>= checkResponseOK++-- | Configure a storage pool.+lxcStorageConfig :: HasClient m => PoolName -> PoolConfigRequest -> m ()+lxcStorageConfig n c = void . runClient $ poolPatch n c >>= checkResponseOK++-- | Delete a storage pool+lxcStorageDelete :: HasClient m => PoolName -> m ()+lxcStorageDelete n = void . runClient $ poolDelete n >>= checkResponseOK++-- | List all volumes+lxcVolumeList :: HasClient m => PoolName -> m [VolumeName]+lxcVolumeList p = runClient $ volumeList p >>= checkResponseOK++-- | Create a volume.+lxcVolumeCreate :: HasClient m => PoolName -> VolumeCreateRequest -> m ()+lxcVolumeCreate p r = void . runClient $ volumeCreate p r >>= checkResponseOK++-- | Get volume information.+lxcVolumeInfo :: HasClient m => PoolName -> VolumeName -> m Volume+lxcVolumeInfo p n = runClient $ volume p n >>= checkResponseOK++-- | Configure a volume.+lxcVolumeConfig :: HasClient m => PoolName -> VolumeName -> VolumeConfigRequest -> m ()+lxcVolumeConfig p n c = void . runClient $ volumePatch p n c >>= checkResponseOK++-- | Delete a volume+lxcVolumeDelete :: HasClient m => PoolName -> VolumeName -> m ()+lxcVolumeDelete p n = void . runClient $ volumeDelete p n >>= checkResponseOK++-- | Run a client operation.+runClient :: HasClient m => ClientM a -> m a+runClient action = do+ clientEnv <- askClientEnv+ liftIO (runClientM action clientEnv) >>= \case+ Left err -> throwM $ ClientError (show err)+ Right a -> return a++convFileMode :: (Integral a, Show a) => a -> FileMode+convFileMode m = FileMode . pad $ showOct m ""+ where pad s | n <- length s, n < 4 = replicate (4 - n) '0' ++ s+ | otherwise = s++convFileMode' :: (MonadThrow m, Eq a, Num a) => FileMode -> m a+convFileMode' (FileMode fm) = case readOct fm of+ [(m, "")] -> return m+ _ -> throwM $ ClientError $ "received invalid file mode: " ++ show fm++-- | Exception raised when the remote host client couldn't be reached.+newtype ClientError = ClientError String++instance Show ClientError where+ show (ClientError err) = "Could not connect to the LXD host: " ++ err++instance Exception ClientError where++-- | Exception raised when the status of a response was unexpected.+data StatusError = StatusError {+ statusErrorExpected :: StatusCode+ , statusErrorReceived :: StatusCode }++instance Show StatusError where+ show StatusError{..} = "Unexpected response with code "+ ++ show statusErrorReceived ++ ", expected "+ ++ show statusErrorExpected++instance Exception StatusError where++-- | Check the validity of a synchronous response.+checkResponseOK :: MonadThrow m => Response a -> m a+checkResponseOK Response{..}+ | SSuccess <- statusCode = return metadata+ | otherwise = throwM $ StatusError SSuccess statusCode++-- | Check the validity of an asynchronous response.+checkResponseCreated :: MonadThrow m => AsyncResponse a -> m OperationId+checkResponseCreated Response{..}+ | SCreated <- statusCode = return responseOperation+ | otherwise = throwM $ StatusError SCreated statusCode++-- | Check the validity of an asynchronous response and return the metadata.+checkResponseCreatedMetadata :: MonadThrow m => AsyncResponse a -> m a+checkResponseCreatedMetadata Response{..}+ | SCreated <- statusCode = return $ backgroundOperationMetadata metadata+ | otherwise = throwM $ StatusError SCreated statusCode++-- | Wait for an operation, and check whether it was successfull+runAndWait :: HasClient m => ClientM OperationId -> m ()+runAndWait op = do+ oid <- liftIO newEmptyMVar+ ops <- liftIO newEmptyMVar+ host <- askHost++ let err = throwM . OperationError+ let waitForDone = do op' <- liftIO $ takeMVar ops+ case operationStatusCode op' of+ SSuccess -> return ()+ SStopped -> err "Operation unexpectedly stopped"+ SCancelled -> err "Opeartion unexpectedly cancelled"+ SFailure -> err $ "Operation failed: " ++ operationErr op'+ SRunning -> printProgress op' >> waitForDone+ _ -> waitForDone++ bracket+ (liftIO . async . runWebSockets host operationsPath $ listenForOperation oid ops)+ (liftIO . uninterruptibleCancel) $ \_ -> do+ oid' <- runClient op+ liftIO $ putMVar oid oid'+ waitForDone+ where+ printProgress op' = case Aeson.fromJSON (operationMetadata op') of+ Aeson.Error _ -> return ()+ Aeson.Success (OperationProgress p) -> liftIO $ do+ IO.hPutStr IO.stderr $ "Progres: " ++ p ++ "\r"+ IO.hFlush IO.stderr++-- | Exception raised when the operation was unsuccessful.+newtype OperationError = OperationError String++instance Show OperationError where+ show (OperationError err) = "Operation unsuccessful: " ++ err++instance Exception OperationError where++-- $use+--+-- All commands take place in the 'HasClient' monad. The 'WithLocalHost'+-- and 'WithRemoteHost' monads can be used directly for fast access to+-- an LXD daemon, but you can also make your own monad stack an instance+-- of 'HasClient'.+--+-- You can connect to an LXD daemon over a unix-socket on the local+-- host, or over HTTPS. For more information about these connection+-- types see "Network.LXD.Client".+--+-- An example using these command to conncet to the LXD instance on your+-- local host (should work out of the box).+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > module Main where+-- >+-- > import Control.Monad.IO.Class (liftIO)+-- > import Network.LXD.Client.Commands+-- >+-- > main :: IO ()+-- > main = runWithLocalHost def $ do+-- > liftIO $ putStrLn "Creating my-container"+-- > lxcCreate . containerCreateRequest "my-container"+-- > . ContainerSourceRemote+-- > $ remoteImage imagesRemote "ubuntu/xenial/amd64"+-- >+-- > liftIO $ putStrLn "Starting my-container"+-- > lxcStart "my-container"+-- >+-- > liftIO $ putStrLn "Stopping my-container"+-- > lxcStop "my-container" False+-- >+-- > liftIO $ putStrLn "Deleting my-container"+-- > lxcDelete "my-container"+--
+ src/Network/LXD/Client/Events.hs view
@@ -0,0 +1,61 @@+-- | This module implements high-level client for the LXD daemon events+-- end-points.+module Network.LXD.Client.Events where++import Network.LXD.Client.Internal.Prelude++import Control.Concurrent.MVar (MVar, putMVar, takeMVar)+import Control.Exception (Exception, catch, throwIO, finally)++import Data.Aeson (eitherDecode)+import Data.Coerce (coerce)+import Data.List (intercalate)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T++import qualified Network.WebSockets as WS++import Web.Internal.HttpApiData (ToHttpApiData(..))++import Network.LXD.Client.Types++eventsPath :: [EventType] -> String+eventsPath types = "/1.0/events?" ++ typesQuery+ where+ types' = intercalate "," $ map (T.unpack . toUrlPiece) types+ typesQuery | null types = ""+ | otherwise = "type=" ++ types'++operationsPath :: String+operationsPath = eventsPath [EventTypeOperation]++readAllEvents :: (Maybe Event -> IO ()) -> WS.ClientApp ()+readAllEvents f con =+ go `finally` WS.sendClose con BL.empty+ where+ go = do+ m <- (Just <$> WS.receiveDataMessage con) `catch` handle'+ case m of Nothing -> f Nothing+ Just (WS.Text t) -> decodeMsg t >>= f . Just >> go+ Just (WS.Binary b) -> decodeMsg b >>= f . Just >> go++ handle' (WS.CloseRequest _ _) = return Nothing+ handle' e = throwIO e++ decodeMsg msg = case eitherDecode msg of+ Left err -> throwIO . LXDMessageError $ "could not decode event: " ++ err+ Right v -> return v++listenForOperation :: MVar OperationId -> MVar Operation -> WS.ClientApp ()+listenForOperation oid' chan con = do+ oid <- liftIO $ takeMVar oid'+ readAllEvents (send oid) con+ where+ send _ Nothing = throwIO $ LXDMessageError "LXD event stream prematurelly stopped"+ send oid (Just event) = case eventMetadata event of+ EventOperationMetadata op -> when (coerce (operationId op) == oid) $ putMVar chan op+ _ -> return ()++newtype LXDMessageError = LXDMessageError String deriving (Show)++instance Exception LXDMessageError where
+ src/Network/LXD/Client/Internal/Prelude.hs view
@@ -0,0 +1,43 @@+-- | Internal prelude.+module Network.LXD.Client.Internal.Prelude (+ -- * Re-exports+ module Prelude++ -- * Monads+, module Control.Monad++ -- * Monad Transformers+, MonadError, ExceptT, runExceptT, throwError+, MonadIO, liftIO+, MonadState, StateT(..), modify, get, put+, MonadTrans, lift++ -- * Foldable+, foldlM++ -- * Monoid+, module Data.Monoid++ -- * Strings+, IsString(fromString)+) where++import Prelude hiding (error)++-- Monads+import Control.Monad (join, unless, void, when)++-- Monad transformers+import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.State (MonadState, StateT(..), modify, get, put)+import Control.Monad.Trans.Class (MonadTrans, lift)++-- Foldable+import Data.Foldable (foldlM)++-- Monoid+import Data.Monoid (Monoid, mempty, mappend, (<>))++-- Strings+import Data.String (IsString(fromString))
+ src/Network/LXD/Client/Remotes.hs view
@@ -0,0 +1,17 @@+-- | A collection of default remotes.+--+-- These remotes are installed on an LXD instance by default.+--+-- Run @lxc image list@ for more information.+module Network.LXD.Client.Remotes where++import Network.LXD.Client.Internal.Prelude++imagesRemote :: String+imagesRemote = "https://images.linuxcontainers.org"++ubuntuRemote :: String+ubuntuRemote = "https://cloud-images.ubuntu.com/releases"++ubuntuDailyRemote :: String+ubuntuDailyRemote = "https://cloud-images.ubuntu.com/daily"
+ src/Network/LXD/Client/Types.hs view
@@ -0,0 +1,1469 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module implements all types used to communicate with the LXD+-- daemon REST end-point.+--+-- These types are e.g. used in the "Network.LXD.Client.Commands"+-- module.+module Network.LXD.Client.Types (+ -- * Generic responses+ GenericResponse(..)+, Response+, AsyncResponse+, ResponseType(..)+, StatusCode(..)+ -- ** Background operations+, BackgroundOperation(..)++ -- * API+, ApiConfig(..)+, ApiStatus(..)+, AuthStatus(..)+, ApiVersion(..)+, ApiExtension(..)++ -- * Certificates+, CertificateHash(..)++ -- * Containers+ -- ** Querying information+, ContainerName(..)+, Container(..)+ -- ** Configuration+, ContainerPut(..)+, ContainerPatch(..)+, ContainerRename(..)+ -- ** State+, MemoryState(..)+, NetworkState(..)+, NetworkAddress(..)+, NetworkCounters(..)+, ContainerState(..)+, StateAction(..)+, ContainerPutState(..)+, containerNewState+ -- ** Creating containers+, ContainerCreateRequest(..)+, containerCreateRequest+, ContainerSource(..)+ -- ** Deleting containers+, ContainerDeleteRequest(..)+ -- ** Executing commands+, ExecParams(..)+, ExecRequest(..)+, ExecResponseMetadataImmediate+, ExecResponseMetadataWebsocket(..)+, ExecResponseMetadata+ -- ** Working with file descriptors+, Secret(..)+, FdSet(..)+, Fds(..)+, ExecFds+ -- ** Working with files+, Gid(..)+, Uid(..)+, FileMode(..)+, FileType(..)+, RawFileResponse(..)+, rawFileResponseBody+, fileResponse+, FileResponse(..)+, PathResponse(..)+ -- ** Referencing containers+, LocalContainer(..)++ -- * Images+ -- ** Querying information+, ImageId(..)+, Image(..)+, ImageAlias(..)+, defaultImageAlias+, ImageProperties(..)+, ImageAliasName(..)+ -- ** Creating and publishing new images+, ImageCreateRequest(..)+, imageCreateRequest+, ImageSource(..)+ -- ** Deleting images+, ImageDeleteRequest(..)+ -- ** Referencing images+, LocalImageByAlias(..)+, LocalImageByFingerprint(..)+, RemoteImage(..)+, remoteImage+, remoteImageId++ -- * Networks+, NetworkName(..)+, Network(..)+, NetworkCreateRequest(..)+, NetworkConfigRequest(..)++ -- * Profiles+, ProfileName(..)+, Profile(..)+, ProfileCreateRequest(..)+, ProfileConfigRequest(..)++ -- * Storage+, PoolName(..)+, Pool(..)+, PoolCreateRequest(..)+, PoolConfigRequest(..)++ -- * Volumes+, VolumeType+, VolumeName(..)+, Volume(..)+, VolumeCreateRequest(..)+, VolumeConfigRequest(..)++ -- * Operations+, OperationId(..)+, OperationStatus+, AllOperations(..)+, Operation(..)+, OperationProgress(..)++ -- * Events+, EventType(..)+, Event(..)+, EventMetadata(..)++ -- * Servant Helpers+, JsonOrBinary+) where++import Network.LXD.Client.Internal.Prelude+import qualified Prelude as P++import Data.Aeson+import Data.Bimap (Bimap)+import Data.ByteString.Lazy (ByteString)+import Data.Default+import Data.List (stripPrefix)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Map.Strict (Map)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text, pack, unpack)+import qualified Data.Bimap as Bimap+import qualified Data.Map.Strict as Map++import Network.HTTP.Media.MediaType (MediaType, (//))++import Servant.API.ContentTypes (Accept(..), MimeUnrender(..))++import Web.Internal.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))++-- | Generic LXD API response object.+data GenericResponse op a = Response {+ responseType :: ResponseType+ , status :: String+ , statusCode :: StatusCode+ , responseOperation :: op+ , errorCode :: Int+ , error :: String+ , metadata :: a+} deriving (Show)++-- | LXD API synchronous repsonse object, without resulting operation.+type Response a = GenericResponse String a++-- | LXD API asynchronous response object, with resulting operation+type AsyncResponse a = GenericResponse OperationId (BackgroundOperation a)++instance (FromJSON op, FromJSON a) => FromJSON (GenericResponse op a) where+ parseJSON = withObject "Response" $ \v -> Response+ <$> v .: "type"+ <*> v .: "status"+ <*> v .: "status_code"+ <*> v .: "operation"+ <*> v .: "error_code"+ <*> v .: "error"+ <*> v .: "metadata"++-- | Background operation response object, with metadata of type @m@.+data BackgroundOperation m = BackgroundOperation {+ backgroundOperationId :: String+ , backgroundOperationClass :: String+ , backgroundOperationCreatedAt :: String+ , backgroundOperationUpdatedAt :: String+ , backgroundOperationStatus :: String+ , backgroundOperationStatusCode :: StatusCode+ , backgroundOperationMetadata :: m+ , backgroundOperationMayCancel :: Bool+ , backgroundOperationeErr :: String+ }++instance FromJSON m => FromJSON (BackgroundOperation m) where+ parseJSON = withObject "BackgroundOperation" $ \v -> BackgroundOperation+ <$> v .: "id"+ <*> v .: "class"+ <*> v .: "created_at"+ <*> v .: "updated_at"+ <*> v .: "status"+ <*> v .: "status_code"+ <*> v .: "metadata"+ <*> v .: "may_cancel"+ <*> v .: "err"++-- | LXD API configuration object.+--+-- Returend when querying @GET \/1.0@. Some objects may not be present if+-- an untrusted requeset was made.+data ApiConfig = ApiConfig {+ apiExtensions :: [ApiExtension]+ , apiStatus :: ApiStatus+ , apiVersion :: String+ , authStatus :: AuthStatus+ , serverConfig :: Maybe Value+ , serverEnv :: Maybe Value+ , serverPublic :: Bool+} deriving (Show)++instance FromJSON ApiConfig where+ parseJSON = withObject "ApiConfig" $ \v -> ApiConfig+ <$> v .: "api_extensions"+ <*> v .: "api_status"+ <*> v .: "api_version"+ <*> v .: "auth"+ <*> v .:? "config"+ <*> v .:? "environment"+ <*> v .: "public"++-- | LXD API extension identifier.+data ApiExtension = ExtPatch+ | ExtCertificateUpdate+ | ExtContainerExecRecording+ | ExtFileAppend+ | ExtFileDelete+ | ExtContainerEditMetadata+ | ExtImageCreateAliases+ | ExtNetwork+ | ExtStorage+ | ExtOther String+ deriving (Eq, Ord, Show)++instance FromJSON ApiExtension where+ parseJSON v = apiExtensionFromString <$> parseJSON v++instance ToJSON ApiExtension where+ toJSON = toJSON . apiExtensionToString++apiExtensionMap :: Bimap String ApiExtension+apiExtensionMap = Bimap.fromList [+ ("patch" , ExtPatch)+ , ("certificate_update" , ExtCertificateUpdate)+ , ("container_exec_recording", ExtContainerExecRecording)+ , ("file_append" , ExtFileAppend)+ , ("file_delete" , ExtFileDelete)+ , ("container_edit_metadata" , ExtContainerEditMetadata)+ , ("image_create_aliases" , ExtImageCreateAliases)+ , ("network" , ExtNetwork)+ , ("storage" , ExtStorage)+ ]++apiExtensionFromString :: String -> ApiExtension+apiExtensionFromString v = fromMaybe (ExtOther v) $ Bimap.lookup v apiExtensionMap++apiExtensionToString :: ApiExtension -> String+apiExtensionToString (ExtOther v) = v+apiExtensionToString c = fromMaybe (P.error $ "unindexed api extension: " ++ show c) $ Bimap.lookupR c apiExtensionMap++-- | LXD trusted certificate hash.+newtype CertificateHash = CertificateHash String deriving (Eq, Show)++instance FromJSON CertificateHash where+ parseJSON = withText "CertificateHash" $ \text ->+ let prefix = "/1.0/certificates/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse hash: no prefix " ++ prefix+ Just hash -> return $ CertificateHash hash++-- | LXD container name.+newtype ContainerName = ContainerName String deriving (Eq, Show)++instance FromJSON ContainerName where+ parseJSON = withText "ContainerName" $ \text ->+ let prefix = "/1.0/containers/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse container name: no prefix " ++ prefix+ Just name -> return $ ContainerName name++instance ToJSON ContainerName where+ toJSON (ContainerName name) = toJSON name++instance IsString ContainerName where+ fromString = ContainerName++instance ToHttpApiData ContainerName where+ toUrlPiece (ContainerName name) = pack name++-- | LXD container information.+--+-- Returned when querying @GET \/1.0\/containers\/\<name\>@.+data Container = Container {+ containerArchitecture :: String+ , containerName :: String+ , containerConfig :: Map String String+ , containerCreatedAt :: String+ , containerDevices :: Map String (Map String String)+ , containerEphemeral :: Bool+ , containerProfiles :: [String]+ , containerStateful :: Bool+ , containerExpandedConfig :: Map String String+ , containerExpandedDevices :: Map String (Map String String)+ , containerStatus :: String+ , containerSatusCode :: Int+ , containerLastUsedAt :: String+} deriving (Show)++instance FromJSON Container where+ parseJSON = withObject "Container" $ \v -> Container+ <$> v .: "architecture"+ <*> v .: "name"+ <*> v .: "config"+ <*> v .: "created_at"+ <*> v .: "devices"+ <*> v .: "ephemeral"+ <*> v .: "profiles"+ <*> v .: "stateful"+ <*> v .: "expanded_config"+ <*> v .: "expanded_devices"+ <*> v .: "status"+ <*> v .: "status_code"+ <*> v .: "last_used_at"++-- | Used to set the configuration of an LXD container.+--+-- Used when querying @PUT \/1.0\/containers\/\<name\>@.+data ContainerPut = ContainerPut {+ containerPutArchitecture :: String+ , containerPutConfig :: Map String String+ , containerPutDevices :: Map String (Map String String)+ , containerPutEphemeral :: Bool+ , containerPutProfiles :: [String]+} deriving (Show)++instance ToJSON ContainerPut where+ toJSON ContainerPut{..} = object[+ "architecture" .= containerPutArchitecture+ , "config" .= containerPutConfig+ , "devices" .= containerPutDevices+ , "ephemeral" .= containerPutEphemeral+ , "profiles" .= containerPutProfiles+ ]++-- | Used to patch the configuration of an LXD container.+--+-- Used when querying @PATCH \/1.0\/containers\/\<name\>@.+data ContainerPatch = ContainerPatch {+ containerPatchArchitecture :: Maybe String+ , containerPatchConfig :: Maybe (Map String String)+ , containerPatchDevices :: Maybe (Map String (Map String String))+ , containerPatchEphemeral :: Maybe Bool+ , containerPatchProfiles :: Maybe [String]+} deriving (Show)++instance ToJSON ContainerPatch where+ toJSON ContainerPatch{..} = object $ catMaybes [+ (.=) <$> pure "architecture" <*> containerPatchArchitecture+ , (.=) <$> pure "config" <*> containerPatchConfig+ , (.=) <$> pure "devices" <*> containerPatchDevices+ , (.=) <$> pure "ephemeral" <*> containerPatchEphemeral+ , (.=) <$> pure "profiles" <*> containerPatchProfiles+ ]++-- | Used to rename a container to the given name.+--+-- Used when querying @POST \/1.0\/containers\/\<name\>@.+newtype ContainerRename = ContainerRename String deriving (Show)++instance ToJSON ContainerRename where+ toJSON (ContainerRename name) = object [ "name" .= name ]++-- | Memory state of an LXD container. As used by 'ContainerState'.+data MemoryState = MemoryState {+ memoryStateUsage :: Integer+ , memoryStateUsagePeak :: Integer+ , memoryStateSwapUsage :: Integer+ , memoryStateSwapUsagePeak :: Integer+} deriving (Show)++instance FromJSON MemoryState where+ parseJSON = withObject "MemoryState" $ \v -> do+ memoryStateUsage <- v .: "usage"+ memoryStateUsagePeak <- v .: "usage_peak"+ memoryStateSwapUsage <- v .: "swap_usage"+ memoryStateSwapUsagePeak <- v .: "swap_usage_peak"+ return MemoryState{..}++-- | Network state of an LXD container network device. As used by 'ContainerState'.+data NetworkState = NetworkState {+ networkStateAddresses :: [NetworkAddress]+ , networkStateCounters :: NetworkCounters+ , networkStateHwaddr :: String+ , networkStateHostName :: String+ , networkStateMtu :: Int+ , networkStateState :: String+ , networkStateType :: String+} deriving (Show)++instance FromJSON NetworkState where+ parseJSON = withObject "NetworkState" $ \v -> do+ networkStateAddresses <- v .: "addresses"+ networkStateCounters <- v .: "counters"+ networkStateHwaddr <- v .: "hwaddr"+ networkStateHostName <- v .: "host_name"+ networkStateMtu <- v .: "mtu"+ networkStateState <- v .: "state"+ networkStateType <- v .: "type"+ return NetworkState{..}++-- | Network address of an LXD container network device. As used by 'NetworkState'.+data NetworkAddress = NetworkAddress {+ networkAddressFamily :: String+ , networkAddressAddress :: String+ , networkAddressNetmask :: String+ , networkAddressScope :: String+} deriving (Show)++instance FromJSON NetworkAddress where+ parseJSON = withObject "NetworkAddress" $ \v -> do+ networkAddressFamily <- v .: "family"+ networkAddressAddress <- v .: "address"+ networkAddressNetmask <- v .: "netmask"+ networkAddressScope <- v .: "scope"+ return NetworkAddress{..}++-- | Collection of statistics of an LXD container network device. As used by 'NetworkState'.+data NetworkCounters = NetworkCounters {+ networkCountersBytesReceived :: Integer+ , networkCountersBytesSent :: Integer+ , networkCountersPacketsReceived :: Integer+ , networkCountersPacketsSent :: Integer+} deriving (Show)++instance FromJSON NetworkCounters where+ parseJSON = withObject "NetworkCounters" $ \v -> do+ networkCountersBytesReceived <- v .: "bytes_received"+ networkCountersBytesSent <- v .: "bytes_sent"+ networkCountersPacketsReceived <- v .: "packets_received"+ networkCountersPacketsSent <- v .: "packets_sent"+ return NetworkCounters{..}++-- | State of an LXD container.+--+-- Used when querying @GET \/1.0\/container\/\<name\>\/state@.+data ContainerState = ContainerState {+ containerStateStatus :: String+ , containerStateStatusCode :: StatusCode+ , containerStateCpu :: Integer+ , containerStateDisk :: Map String Integer+ , containerStateMemory :: MemoryState+ , containerStateNetwork :: Map String NetworkState+ , containerStatePid :: Int+ , containerStateProcesses :: Int+} deriving (Show)++instance FromJSON ContainerState where+ parseJSON = withObject "ContainerState" $ \v -> do+ cpu <- v .: "cpu"+ let containerStateCpu = fromMaybe 0 $ Map.lookup ("usage" :: String) cpu++ containerStateStatus <- v .: "status"+ containerStateStatusCode <- v .: "status_code"+ containerStateDisk <- v .: "disk"+ containerStateMemory <- v .: "memory"+ containerStateNetwork <- v .: "network"+ containerStatePid <- v .: "pid"+ containerStateProcesses <- v .: "processes"+ return ContainerState{..}++-- | State change action for an LXD container, as used by 'ContainerPutState'.+data StateAction = Stop+ | Start+ | Restart+ | Freeze+ | Unfreeze+ deriving (Eq, Show)++instance ToJSON StateAction where+ toJSON Stop = toJSON ("stop" :: Text)+ toJSON Start = toJSON ("start" :: Text)+ toJSON Restart = toJSON ("restart" :: Text)+ toJSON Freeze = toJSON ("freeze" :: Text)+ toJSON Unfreeze = toJSON ("unfreeze" :: Text)++-- | State change request for an LXD container.+--+-- Used when querying @PUT \/1.0\/container\/\<name\>\/state@.+data ContainerPutState = ContainerPutState {+ containerPutStateAction :: StateAction+ , containerPutStateTimeout :: Int+ , containerPutStateForce :: Bool+ , containerPutStateStateful :: Bool+} deriving (Show)++instance ToJSON ContainerPutState where+ toJSON ContainerPutState{..} = object [+ "action" .= containerPutStateAction+ , "timeout" .= containerPutStateTimeout+ , "force" .= containerPutStateForce+ , "stateful" .= containerPutStateStateful+ ]++containerNewState :: StateAction -> Bool -> ContainerPutState+containerNewState action force = ContainerPutState {+ containerPutStateAction = action+ , containerPutStateTimeout = 30+ , containerPutStateForce = force+ , containerPutStateStateful = False+ }++-- | LXD create container request object.+--+-- Used when querying @POST \/1.0\/containers@.+data ContainerCreateRequest = ContainerCreateRequest {+ containerCreateRequestName :: String+ , containerCreateRequestArchitecture :: String+ , containerCreateRequestProfiles :: [String]+ , containerCreateRequestEphemeral :: Bool+ , containerCreateRequestConfig :: Map String String+ , containerCreateRequestDevices :: Map String (Map String String)+ , containerCreateRequestInstanceType :: Maybe String+ , containerCreateRequestSource :: ContainerSource+ } deriving (Show)++instance ToJSON ContainerCreateRequest where+ toJSON ContainerCreateRequest{..} = object $ [+ "name" .= containerCreateRequestName+ , "architecture" .= containerCreateRequestArchitecture+ , "profiles" .= containerCreateRequestProfiles+ , "ephemeral" .= containerCreateRequestEphemeral+ , "config" .= containerCreateRequestConfig+ , "devices" .= containerCreateRequestDevices+ , "source" .= containerCreateRequestSource+ ] ++ catMaybes [+ (.=) <$> pure "instance_type" <*> containerCreateRequestInstanceType+ ]++-- | Create a default 'ContainerCreateRequest'.+containerCreateRequest :: String -> ContainerSource -> ContainerCreateRequest+containerCreateRequest name src = ContainerCreateRequest {+ containerCreateRequestName = name+ , containerCreateRequestArchitecture = "x86_64"+ , containerCreateRequestProfiles = ["default"]+ , containerCreateRequestEphemeral = False+ , containerCreateRequestConfig = mempty+ , containerCreateRequestDevices = mempty+ , containerCreateRequestInstanceType = Nothing+ , containerCreateRequestSource = src+ }++-- | Source for creating a container, as used by 'ContainerCreateRequest'.+data ContainerSource = ContainerSourceLocalByAlias LocalImageByAlias -- ^ Container based on a local image with a certain alias.+ | ContainerSourceLocalByFingerprint LocalImageByFingerprint -- ^ Container based on a local image with a certain alias.+ | ContainerSourceNone -- ^ Container without a pre-populated rootfs.+ | ContainerSourceRemote RemoteImage -- ^ Continer based on a public remote image.+ deriving (Show)++instance ToJSON ContainerSource where+ toJSON (ContainerSourceLocalByAlias (LocalImageByAlias alias)) = object [+ "type" .= ("image" :: String)+ , "alias" .= alias+ ]+ toJSON (ContainerSourceLocalByFingerprint (LocalImageByFingerprint img)) = object [+ "type" .= ("image" :: String)+ , "fingerprint" .= img+ ]+ toJSON ContainerSourceNone = object [+ "type" .= ("none" :: String)+ ]+ toJSON (ContainerSourceRemote RemoteImage{..}) = object $ [+ "type" .= ("image" :: String)+ , "mode" .= ("pull" :: String)+ , "server" .= remoteImageServer+ ] ++ catMaybes [+ (.=) <$> pure "secret" <*> remoteImageSecret+ , (.=) <$> pure "certificate" <*> remoteImageCertificate+ , (.=) <$> pure "alias" <*> remoteImageAlias+ , (.=) <$> pure "fingerprint" <*> remoteImageFingerprint+ ]+ where+ remoteImageAlias = either Just (const Nothing) remoteImageAliasOrFingerprint :: Maybe ImageAliasName+ remoteImageFingerprint = either (const Nothing) Just remoteImageAliasOrFingerprint :: Maybe ImageId++-- | Source for a local image, specified by its alias.+newtype LocalImageByAlias = LocalImageByAlias ImageAliasName deriving (Show)++instance IsString LocalImageByAlias where+ fromString = LocalImageByAlias . ImageAliasName++-- | Source for a local image, specified by its fingerprint+newtype LocalImageByFingerprint = LocalImageByFingerprint ImageId deriving (Show)++-- | Source for an image from a public or private remote.+data RemoteImage = RemoteImage {+ remoteImageServer :: String+ , remoteImageSecret :: Maybe String+ , remoteImageCertificate :: Maybe String+ , remoteImageAliasOrFingerprint :: Either ImageAliasName ImageId+ } deriving (Show)++-- | Create a remote image reference form a public remote.+remoteImage :: String -> ImageAliasName -> RemoteImage+remoteImage server alias = RemoteImage {+ remoteImageServer = server+ , remoteImageSecret = Nothing+ , remoteImageCertificate = Nothing+ , remoteImageAliasOrFingerprint = Left alias }++-- | Create a remote image reference form a public remote, using an image ID.+remoteImageId :: String -> ImageId -> RemoteImage+remoteImageId server img = RemoteImage {+ remoteImageServer = server+ , remoteImageSecret = Nothing+ , remoteImageCertificate = Nothing+ , remoteImageAliasOrFingerprint = Right img }++-- | LXD delete container request object.+--+-- Used when querying @DELETE \/1.0\/containers\/\<name\>@.+data ContainerDeleteRequest = ContainerDeleteRequest++instance Default ContainerDeleteRequest where+ def = ContainerDeleteRequest++instance ToJSON ContainerDeleteRequest where+ toJSON _ = object []++-- | Configuration parameter to 'ExecRequest' and 'ExecResponse'.+data ExecParams = ExecImmediate -- ^ Don't wait for a websocket connection before executing.+ | ExecWebsocketInteractive -- ^ Wait for websocket, allocate PTY.+ | ExecWebsocketNonInteractive -- ^ Wait for websocket, don't allocate PTY.+ deriving (Show)++-- | LXD container exec request, configured using 'ExecParams' as type parameter.+--+-- Request body when querying @POST \/1.0\/containers\/\<name\>\/exec@.+data ExecRequest (params :: ExecParams) = ExecRequest {+ execRequestCommand :: [String]+ , execRequestEnvironment :: Map String String+ , execRequestRecordOutput :: Bool+ , execRequestWidth :: Int+ , execRequestHeight :: Int+} deriving (Show)++instance Default (ExecRequest a) where+ def = ExecRequest { execRequestCommand = []+ , execRequestEnvironment = Map.empty+ , execRequestRecordOutput = False+ , execRequestWidth = 80+ , execRequestHeight = 25 }++instance ToJSON (ExecRequest 'ExecImmediate) where+ toJSON ExecRequest{..} = object [+ "command" .= execRequestCommand+ , "environment" .= execRequestEnvironment+ , "wait-for-websocket" .= False+ , "record-output" .= execRequestRecordOutput+ , "interactive" .= False+ , "width" .= execRequestWidth+ , "height" .= execRequestHeight+ ]++instance ToJSON (ExecRequest 'ExecWebsocketInteractive) where+ toJSON ExecRequest{..} = object [+ "command" .= execRequestCommand+ , "environment" .= execRequestEnvironment+ , "wait-for-websocket" .= True+ , "record-output" .= execRequestRecordOutput+ , "interactive" .= True+ , "width" .= execRequestWidth+ , "height" .= execRequestHeight+ ]+instance ToJSON (ExecRequest 'ExecWebsocketNonInteractive) where+ toJSON ExecRequest{..} = object [+ "command" .= execRequestCommand+ , "environment" .= execRequestEnvironment+ , "wait-for-websocket" .= True+ , "record-output" .= execRequestRecordOutput+ , "interactive" .= False+ , "width" .= execRequestWidth+ , "height" .= execRequestHeight+ ]++-- | A secret used to connect to a websocket.+newtype Secret = Secret String deriving (Eq, Show)++instance FromJSON Secret where+ parseJSON = withText "Secret" $ return . Secret . unpack++-- | A set of selected file descriptors.+data FdSet = FdAll | FdPty deriving (Show)++-- | A set of file descriptors.+data Fds set where+ FdsAll :: { fdsAllStdin :: Secret+ , fdsAllStdout :: Secret+ , fdsAllStderr :: Secret+ , fdsAllControl :: Secret } -> Fds 'FdAll+ FdsPty :: { fdsPty :: Secret+ , fdsPtyControl :: Secret } -> Fds 'FdPty++deriving instance Show (Fds set)++instance FromJSON (Fds 'FdAll) where+ parseJSON = withObject "Fds 'FdAll" $ \v -> FdsAll+ <$> v .: "0"+ <*> v .: "1"+ <*> v .: "2"+ <*> v .: "control"++instance FromJSON (Fds 'FdPty) where+ parseJSON = withObject "Fds 'FdPty" $ \v -> FdsPty+ <$> v .: "0"+ <*> v .: "control"++-- | Type family converting an 'ExecParams' to an 'FdSet'.+type family ExecFds (params :: ExecParams) :: FdSet where+ ExecFds 'ExecWebsocketInteractive = 'FdPty+ ExecFds 'ExecWebsocketNonInteractive = 'FdAll++-- | Metadata of an immediate exec response.+--+-- Returned when querying @POST \/1.0\/containers\/\<name\>\/exec@ with+-- 'ExecImmediate' as configuration.+type ExecResponseMetadataImmediate = Value++-- | Metadata of a websocket exec repsonse.+--+-- Returned when querying @POST \/1.0\/containers\/\<name\>\/exec@ with+-- 'ExecWebsocketInteractive' or 'ExecWebsocketNonInteractive' as+-- configuration.+--+-- Paramtrized by a file descriptor set 'FdSet', see also the type family+-- 'ExecFds'.+newtype ExecResponseMetadataWebsocket fdset = ExecResponseMetadataWebsocket {+ execResponseMetadataWebsocketFds :: Fds fdset+} deriving (Show)++instance FromJSON (ExecResponseMetadataWebsocket 'FdPty) where+ parseJSON = withObject "ExecResponseMetadata 'FdPty" $ \v ->+ ExecResponseMetadataWebsocket <$> v .: "fds"++instance FromJSON (ExecResponseMetadataWebsocket 'FdAll) where+ parseJSON = withObject "ExecResponseMetadata 'FdAll" $ \v ->+ ExecResponseMetadataWebsocket <$> v .: "fds"++-- | Type family converting an 'ExecParams' to the corresponding response type.+type family ExecResponseMetadata (params :: ExecParams) :: * where+ ExecResponseMetadata 'ExecImmediate = ExecResponseMetadataImmediate+ ExecResponseMetadata 'ExecWebsocketInteractive = ExecResponseMetadataWebsocket 'FdPty+ ExecResponseMetadata 'ExecWebsocketNonInteractive = ExecResponseMetadataWebsocket 'FdAll++-- | Group ID of a container file.+newtype Gid = Gid Int deriving (Bounded, Enum, Eq, FromHttpApiData, Integral, Num, Ord, Read, Real, Show, ToHttpApiData)++-- | User ID of a container file.+newtype Uid = Uid Int deriving (Bounded, Enum, Eq, FromHttpApiData, Integral, Num, Ord, Read, Real, Show, ToHttpApiData)++-- | Mode of a container file. Encoded in standard octal notation, e.g. @0644@.+newtype FileMode = FileMode String deriving (Eq, FromHttpApiData, IsString, Ord, Read, Show, ToHttpApiData)++-- | Type of a container file. Can be one of @directory@, @file@ or @symlink@.+newtype FileType = FileType String deriving (Eq, FromHttpApiData, IsString, Ord, Read, Show, ToHttpApiData)++-- | LXD file response object, representing either a file or a directory.+--+-- Used by the @GET \/1.0\/containers\/\<name\>\/files\/\<filename\>@ endpoints.+data FileResponse = File ByteString+ | Directory (Response [String])+ deriving (Show)++-- | Raw file response, not yet decoded, used because of a bug in Servant.+--+-- Use headers to get actual content type.+data RawFileResponse = RawFileResponse MediaType ByteString deriving (Show)++-- | Get the body of a 'RawFileResponse'.+rawFileResponseBody :: RawFileResponse -> ByteString+rawFileResponseBody (RawFileResponse _ bs) = bs++-- | Construct a file response from a type and a 'ByteString'.+fileResponse :: FileType -> ByteString -> Either String FileResponse+fileResponse "file" bs = Right $ File bs+fileResponse "directory" bs = eitherDecode bs+fileResponse t _ = Left $ "unsupported file type: " ++ show t++instance FromJSON FileResponse where+ parseJSON v = Directory <$> do+ r <- parseJSON v+ -- If the directory is empty, the LXD server will send @null@ instead+ -- of the empty list. Handle that case here.+ case metadata r of+ Nothing -> return r { metadata = [] }+ Just xs -> return r { metadata = xs }++instance MimeUnrender JsonOrBinary RawFileResponse where+ mimeUnrenderWithType _ mt = Right . RawFileResponse mt++-- | LXD path response object, which is a file and metadata.+--+-- Used by the @\/1.0\/containers\/\<name\>\/files\/...@ endpoints.+data PathResponse = PathResponse {+ pathUid :: Uid+ , pathGid :: Gid+ , pathMode :: FileMode+ , pathType :: FileType+ , getFile :: FileResponse+ } deriving (Show)++-- | Reference to a local container, as used by 'ImageSource'.+newtype LocalContainer = LocalContainer ContainerName deriving (Show)++instance IsString LocalContainer where+ fromString = LocalContainer . ContainerName++-- | LXD image identifier.+newtype ImageId = ImageId String deriving (Eq, Show)++instance FromJSON ImageId where+ parseJSON = withText "ImageId" $ \text ->+ let prefix = "/1.0/images/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse image id: no prefix " ++ prefix+ Just img -> return $ ImageId img++instance ToJSON ImageId where+ toJSON (ImageId image) = toJSON image++instance ToHttpApiData ImageId where+ toUrlPiece (ImageId img) = pack img++-- | Alias of an image.+--+-- Returned when querying @GET \/1.0\/images/aliases\/\<name\>@,+-- and as a part of @GET \/1.0\/images\/\<fingerprint\>@.+data ImageAlias = ImageAlias {+ imageAliasName :: String+ , imageAliasDescription :: String+ , imageAliasTarget :: Maybe String+ } deriving (Show)++instance FromJSON ImageAlias where+ parseJSON = withObject "ImageAlias" $ \v -> ImageAlias+ <$> v .: "name"+ <*> v .: "description"+ <*> v .:? "target"++instance ToJSON ImageAlias where+ toJSON ImageAlias{..} = object [+ "name" .= imageAliasName+ , "description" .= imageAliasDescription+ ]++-- | Create a default 'ImageAlias', with empty description and target.+defaultImageAlias :: String -> ImageAlias+defaultImageAlias name = ImageAlias {+ imageAliasName = name+ , imageAliasDescription = ""+ , imageAliasTarget = Nothing+ }++-- | Properties of an image.+data ImageProperties = ImageProperties {+ imagePropertiesArchitecture :: Maybe String+ , imagePropertiesDescription :: Maybe String+ , imagePropertiesOs :: Maybe String+ , imagePropertiesRelease :: Maybe String+ } deriving (Show)++instance FromJSON ImageProperties where+ parseJSON = withObject "ImageProperties" $ \v -> ImageProperties+ <$> v .:? "architecture"+ <*> v .:? "description"+ <*> v .:? "os"+ <*> v .:? "release"++-- | LXD image information.+--+-- Returned when querying @GET \/1.0\/images\/\<fingerprint\>@.+data Image = Image {+ imageAllAliases :: [ImageAlias]+ , imageArchitecture :: String+ , imageAutoUpdate :: Bool+ , imageCached :: Bool+ , imageFingerprint :: String+ , imageFilename :: String+ , imageProperties :: ImageProperties+ , imagePublic :: Bool+ , imageSize :: Integer+ , imageCreatedAt :: String+ , imageExpiresAt :: String+ , imageLastUsedAt :: String+ , imageUplaodedAt :: String+ } deriving (Show)++-- | LXD alias name.+--+-- Returned when querying @GET \/1.0\/images/aliases@.+newtype ImageAliasName = ImageAliasName String deriving (Eq, Show)++instance IsString ImageAliasName where+ fromString = ImageAliasName++instance FromJSON ImageAliasName where+ parseJSON = withText "ImageAliasName" $ \text ->+ let prefix = "/1.0/images/aliases/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse image alias name id: no prefix " ++ prefix+ Just name -> return $ ImageAliasName name++instance ToJSON ImageAliasName where+ toJSON (ImageAliasName image) = toJSON image++instance ToHttpApiData ImageAliasName where+ toUrlPiece (ImageAliasName name) = pack name++instance FromJSON Image where+ parseJSON = withObject "Image" $ \v -> Image+ <$> v .: "aliases"+ <*> v .: "architecture"+ <*> v .: "auto_update"+ <*> v .: "cached"+ <*> v .: "fingerprint"+ <*> v .: "filename"+ <*> v .: "properties"+ <*> v .: "public"+ <*> v .: "size"+ <*> v .: "created_at"+ <*> v .: "expires_at"+ <*> v .: "last_used_at"+ <*> v .: "uploaded_at"++-- | LXD image create request object.+--+-- Used when querying @POST \/1.0\/images@.+data ImageCreateRequest = ImageCreateRequest {+ imageCreateRequestPublic :: Bool+ , imageCreateRequestAutoUpdate :: Bool+ , imageCreateRequestProperties :: Value+ , imageCreateRequestAliases :: [ImageAlias]+ , imageCreateRequestSource :: ImageSource+ } deriving (Show)++-- | Construct a new default 'ImageCreateRequest'.+imageCreateRequest :: ImageSource -> ImageCreateRequest+imageCreateRequest src = ImageCreateRequest {+ imageCreateRequestPublic = False+ , imageCreateRequestAutoUpdate = False+ , imageCreateRequestProperties = object []+ , imageCreateRequestAliases = []+ , imageCreateRequestSource = src+ }++instance ToJSON ImageCreateRequest where+ toJSON ImageCreateRequest{..} = object [+ "public" .= imageCreateRequestPublic+ , "auto_update" .= imageCreateRequestAutoUpdate+ , "properties" .= imageCreateRequestProperties+ , "aliases" .= imageCreateRequestAliases+ , "source" .= imageCreateRequestSource+ ]++-- | A generic image source, used by 'ImageCreateRequest'.+data ImageSource = ImageSourceRemoteImage RemoteImage+ | ImageSourceLocalContainer LocalContainer+ deriving (Show)++instance ToJSON ImageSource where+ toJSON (ImageSourceLocalContainer (LocalContainer name)) = object [+ "type" .= ("container" :: String)+ , "name" .= name+ ]+ toJSON (ImageSourceRemoteImage RemoteImage{..}) = object $ [+ "type" .= ("image" :: String)+ , "mode" .= ("pull" :: String)+ , "server" .= remoteImageServer+ ] ++ catMaybes [+ (.=) <$> pure "secret" <*> remoteImageSecret+ , (.=) <$> pure "certificate" <*> remoteImageCertificate+ , (.=) <$> pure "alias" <*> remoteImageAlias+ , (.=) <$> pure "fingerprint" <*> remoteImageFingerprint+ ]+ where+ remoteImageAlias = either Just (const Nothing) remoteImageAliasOrFingerprint :: Maybe ImageAliasName+ remoteImageFingerprint = either (const Nothing) Just remoteImageAliasOrFingerprint :: Maybe ImageId++-- | LXD image delete request object.+--+-- Used when querying @DELETE \/1.0\/images\/\<fingerprint\>@.+data ImageDeleteRequest = ImageDeleteRequest++instance Default ImageDeleteRequest where+ def = ImageDeleteRequest++instance ToJSON ImageDeleteRequest where+ toJSON _ = object []++-- | LXD network name.+newtype NetworkName = NetworkName String deriving (Eq, Show)++instance FromJSON NetworkName where+ parseJSON = withText "NetworkName" $ \text ->+ let prefix = "/1.0/networks/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse netwokr name: no prefix " ++ prefix+ Just name -> return $ NetworkName name++instance ToJSON NetworkName where+ toJSON (NetworkName name) = toJSON name++instance IsString NetworkName where+ fromString = NetworkName++instance ToHttpApiData NetworkName where+ toUrlPiece (NetworkName name) = pack name++-- | LXD network.+--+-- Returned when querying @GET \/1.0\/networks\/\<name\>@.+data Network = Network {+ networkName :: String+ , networkConfig :: Map String String+ , networkManaged :: Bool+ , networkType :: String+ , networkUsedBy :: [ContainerName]+} deriving (Show)++instance FromJSON Network where+ parseJSON = withObject "Network" $ \v -> do+ networkName <- v .: "name"+ networkConfig <- v .: "config"+ networkManaged <- v .: "managed"+ networkType <- v .: "type"+ networkUsedBy <- v .: "used_by"+ return Network{..}++-- | LXD network create request.+--+-- Used when querying @POST \/1.0\/networks@.+data NetworkCreateRequest = NetworkCreateRequest {+ networkCreateRequestName :: NetworkName+ , networkCreateRequestDescription :: String+ , networkCreateRequestConfig :: Map String String+} deriving (Show)++instance ToJSON NetworkCreateRequest where+ toJSON NetworkCreateRequest{..} = object [+ "name" .= networkCreateRequestName+ , "description" .= networkCreateRequestDescription+ , "config" .= networkCreateRequestConfig+ ]++-- | LXD network config update request.+--+-- Used when querying @PUT/PATCH \/1.0\/networks\/\<name\>@.+newtype NetworkConfigRequest = NetworkConfigRequest {+ networkConfigRequestConfig :: Map String String+} deriving (Show)++instance ToJSON NetworkConfigRequest where+ toJSON NetworkConfigRequest{..} = object [ "config" .= networkConfigRequestConfig ]++-- | LXD profile name.+--+-- Returned by @GET \/1.0\/profiles@.+newtype ProfileName = ProfileName String deriving (Eq, Show)++instance FromJSON ProfileName where+ parseJSON = withText "ProfileName" $ \text ->+ let prefix = "/1.0/profiles/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse profile name: no prefix " ++ prefix+ Just operation -> return $ ProfileName operation++instance IsString ProfileName where+ fromString = ProfileName++instance ToHttpApiData ProfileName where+ toUrlPiece (ProfileName name) = pack name++-- | LXD profile.+--+-- Returned by @GET \/1.0\/profiles\/\<name\>@.+data Profile = Profile {+ profileName :: String+ , profileDescription :: String+ , profileConfig :: Map String String+ , profileDevices :: Map String (Map String String)+ , profileUsedBy :: [ContainerName]+} deriving (Show)++instance FromJSON Profile where+ parseJSON = withObject "Profile" $ \v -> do+ profileName <- v .: "name"+ profileDescription <- v .: "description"+ profileConfig <- v .: "config"+ profileDevices <- v .: "devices"+ profileUsedBy <- v .: "use_by"+ return Profile{..}++-- | LXD profile create request.+--+-- Used when querying @POST \/1.0\/profiles@.+data ProfileCreateRequest = ProfileCreateRequest {+ profileCreateRequestName :: String+ , profileCreateRequestDescription :: String+ , profileCreateRequestConfig :: Map String String+ , profileCreateRequestDevices :: Map String (Map String String)+} deriving (Show)++instance ToJSON ProfileCreateRequest where+ toJSON ProfileCreateRequest{..} = object [+ "name" .= profileCreateRequestName+ , "description" .= profileCreateRequestDescription+ , "config" .= profileCreateRequestConfig+ , "devices" .= profileCreateRequestDevices+ ]++-- | LXD profile config request.+--+-- Used when querying @PUT/PATCH \/1.0\/profiles\/\<name\>@.+data ProfileConfigRequest = ProfileConfigRequest {+ profileConfigRequestConfig :: Maybe (Map String String)+ , profileConfigRequestDescription :: Maybe String+ , profileConfigRequestDevices :: Maybe (Map String (Map String String))+} deriving (Show)++instance ToJSON ProfileConfigRequest where+ toJSON ProfileConfigRequest{..} = object $ catMaybes [+ (.=) <$> pure "config" <*> profileConfigRequestConfig+ , (.=) <$> pure "description" <*> profileConfigRequestDescription+ , (.=) <$> pure "devices" <*> profileConfigRequestDevices+ ]++-- | LXD storage pool name.+--+-- Returned by @GET \/1.0\/storage-pools@.+newtype PoolName = PoolName String deriving (Eq, Show)++instance FromJSON PoolName where+ parseJSON = withText "PoolName" $ \text ->+ let prefix = "/1.0/storage-pools/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse storage pool name: no prefix " ++ prefix+ Just operation -> return $ PoolName operation++instance IsString PoolName where+ fromString = PoolName++instance ToHttpApiData PoolName where+ toUrlPiece (PoolName name) = pack name+++-- | LXD pool.+--+-- Returned by @GET \/1.0\/storage-pools\/\<name\>@.+data Pool = Pool {+ poolName :: String+ , poolDescription :: String+ , poolDriver :: String+ , poolConfig :: Map String String+ , poolUsedBy :: [ContainerName]+} deriving (Show)++instance FromJSON Pool where+ parseJSON = withObject "Pool" $ \v -> do+ poolName <- v .: "name"+ poolDescription <- v .: "description"+ poolDriver <- v .: "driver"+ poolConfig <- v .: "config"+ poolUsedBy <- v .: "used_by"+ return Pool{..}++-- | LXD pool create request.+--+-- Used when querying @POST \/1.0\/storage-pools@.+data PoolCreateRequest = PoolCreateRequest {+ poolCreateRequestName :: String+ , poolCreateRequestDriver :: String+ , poolCreateRequestConfig :: Map String String+} deriving (Show)++instance ToJSON PoolCreateRequest where+ toJSON PoolCreateRequest{..} = object [+ "name" .= poolCreateRequestName+ , "driver" .= poolCreateRequestDriver+ , "config" .= poolCreateRequestConfig+ ]++-- | LXD pool config request.+--+-- Used when querying @PUT/PATCH \/1.0\/storage-pools\/\<name\>@.+newtype PoolConfigRequest = PoolConfigRequest {+ poolConfigRequestConfig :: Map String String+} deriving (Show)++instance ToJSON PoolConfigRequest where+ toJSON PoolConfigRequest{..} = object [ "config" .= poolConfigRequestConfig ]+++-- | Type of a volume.+type VolumeType = String++-- | LXD volume name, and its type.+--+-- Returned by @GET \/1.0\/storage-pools\/\<name\>\/volumes@.+data VolumeName = VolumeName VolumeType String++instance FromJSON VolumeName where+ parseJSON = withText "VolumeName" $ \text ->+ case reverse $ splitOn' '/' (unpack text) of+ n:t:_ -> return $ VolumeName (toType t) n+ _ -> fail $ "could not parse voluem name: " ++ show text+ where+ splitOn' _ [] = []+ splitOn' s xs = case span (/= s) xs of+ (y, []) -> if last y == s then [y, []] else [y]+ (y, ys) -> y:splitOn' s ys++ toType "containers" = "container"+ toType t = t++instance ToHttpApiData VolumeName where+ toUrlPiece (VolumeName _ name) = pack name++-- | LXD volume.+--+-- Returend by @GET \/1.0\/storage-pools\/\<name\>\/volumes\/\<type\>\/\<volume\>@.+data Volume = Volume {+ volumeName :: String+ , volumeType :: String+ , volumeConfig :: Map String String+ , volumeUsedBy :: [ContainerName]+} deriving (Show)++instance FromJSON Volume where+ parseJSON = withObject "Volume" $ \v -> do+ volumeName <- v .: "name"+ volumeType <- v .: "type"+ volumeConfig <- v .: "config"+ volumeUsedBy <- v .: "used_by"+ return Volume{..}++-- | LXD volume create request.+--+-- Used when querying @POST \/1.0\/storage-pools\/\<name\>\/volumes@.+data VolumeCreateRequest = VolumeCreateRequest {+ volumeCreateRequestConfig :: Map String String+ , volumeCreateRequestPool :: String+ , volumeCreateRequestName :: String+ , volumeCreateRequestType :: String+} deriving (Show)++instance ToJSON VolumeCreateRequest where+ toJSON VolumeCreateRequest{..} = object [+ "config" .= volumeCreateRequestConfig+ , "pool" .= volumeCreateRequestPool+ , "name" .= volumeCreateRequestName+ , "type" .= volumeCreateRequestType+ ]++-- | LXD volume config request.+--+-- Returend by @PUT/PATCH \/1.0\/storage-pools\/\<name\>\/volumes\/\<type\>\/\<volume\>@.+newtype VolumeConfigRequest = VolumeConfigRequest {+ volumeConfigRequestConfig :: Map String String+} deriving (Show)++instance ToJSON VolumeConfigRequest where+ toJSON VolumeConfigRequest{..} = object [ "config" .= volumeConfigRequestConfig ]++-- | LXD operation identifier.+newtype OperationId = OperationId String deriving (Eq, Show)++instance FromJSON OperationId where+ parseJSON = withText "OperationId" $ \text ->+ let prefix = "/1.0/operations/" in+ case stripPrefix prefix (unpack text) of+ Nothing -> fail $ "could not parse operation id: no prefix " ++ prefix+ Just operation -> return $ OperationId operation++instance IsString OperationId where+ fromString = OperationId++instance ToHttpApiData OperationId where+ toUrlPiece (OperationId operation) = pack operation++-- | LXD operation status.+type OperationStatus = String++-- | LXD list of all operations.+newtype AllOperations = AllOperations (Map OperationStatus [OperationId])+ deriving (Show)++instance FromJSON AllOperations where+ parseJSON v = AllOperations <$> parseJSON v++-- | LXD operation.+--+-- Returned when querying @GET \/1.0\/operations\/\<uuid\>@.+data Operation = Operation {+ operationId :: String+ , operationClass :: String+ , operationCreatedAt :: String+ , operationUpdatedAt :: String+ , operationStatus :: OperationStatus+ , operationStatusCode :: StatusCode+ , operationMetadata :: Value+ , operationMayCancel :: Bool+ , operationErr :: String+} deriving (Show)++instance FromJSON Operation where+ parseJSON = withObject "Operation" $ \v -> Operation+ <$> v .: "id"+ <*> v .: "class"+ <*> v .: "created_at"+ <*> v .: "updated_at"+ <*> v .: "status"+ <*> v .: "status_code"+ <*> v .: "metadata"+ <*> v .: "may_cancel"+ <*> v .: "err"++-- | Progress of an LXD operation.+--+-- You can try to decode 'operationMetadata' if the 'operationStatusCode' is+-- 'SRunning' to see of the operation contains progress information.+--+-- The embedded 'String' value is in the format @87% (12.04 MB/s)@.+newtype OperationProgress = OperationProgress String deriving (Show)++instance FromJSON OperationProgress where+ parseJSON = withObject "OperationProgress" $ \v ->+ OperationProgress <$> (v .: "download_progress")++-- | Type of an LXD event from the @\/1.0\/events@ handle.+data EventType = EventTypeLogging+ | EventTypeOperation+ deriving (Eq, Show)++instance ToHttpApiData EventType where+ toUrlPiece EventTypeLogging = "logging"+ toUrlPiece EventTypeOperation = "operation"++instance FromHttpApiData EventType where+ parseUrlPiece "logging" = Right EventTypeLogging+ parseUrlPiece "operation" = Right EventTypeOperation+ parseUrlPiece t = Left $ "unknown event type: " <> t++instance FromJSON EventType where+ parseJSON = withText "EventType" $ \t -> case t of+ "logging" -> return EventTypeLogging+ "operation" -> return EventTypeOperation+ t' -> fail $ "unknown event type: " ++ show t'++-- | An event received from @\/1.0\/events@.+data Event = Event {+ eventTimestamp :: String+ , eventType :: EventType+ , eventMetadata :: EventMetadata+} deriving (Show)++instance FromJSON Event where+ parseJSON = withObject "Event" $ \v -> do+ eventTimestamp <- v .: "timestamp"+ eventType <- (v .: "type") >>= parseJSON+ eventMetadata <- case eventType of+ EventTypeLogging -> EventLoggingMetadata <$> (v .: "metadata")+ EventTypeOperation -> EventOperationMetadata <$> (v .: "metadata")+ return Event{..}++-- | Metadata of an event.+data EventMetadata = EventLoggingMetadata Value+ | EventOperationMetadata Operation+ deriving (Show)++-- | The type of a generic response object.+data ResponseType = Sync | Async deriving (Eq, Show)++instance FromJSON ResponseType where+ parseJSON = withText "ResponseType" $ \case+ "sync" -> pure Sync+ "async" -> pure Async+ v -> fail $ "Unknown value: " ++ show v++data StatusCode = SCreated+ | SStopped+ | SRunning+ | SSuccess+ | SFailure+ | SCancelled+ | SOther Int+ deriving (Eq, Ord, Show)++statusCodeMap :: Bimap Int StatusCode+statusCodeMap = Bimap.fromList [+ (100, SCreated)+ , (102, SStopped)+ , (103, SRunning)+ , (200, SSuccess)+ , (400, SFailure)+ , (401, SCancelled)+ ]++statusCodeFromInt :: Int -> StatusCode+statusCodeFromInt v = fromMaybe (SOther v) $ Bimap.lookup v statusCodeMap++statusCodeToInt :: StatusCode -> Int+statusCodeToInt (SOther v) = v+statusCodeToInt c = fromMaybe (P.error $ "unindexed status code: " ++ show c) $ Bimap.lookupR c statusCodeMap++instance FromJSON StatusCode where+ parseJSON v = statusCodeFromInt <$> parseJSON v++instance ToJSON StatusCode where+ toJSON = toJSON . statusCodeToInt++-- | LXD API version string, e.g. 1.0.+newtype ApiVersion = ApiVersion String deriving (Eq, Show)++instance FromJSON ApiVersion where+ parseJSON = withText "ApiVersion" $ pure . ApiVersion . unpack++data ApiStatus = Development | Stable | Deprecated deriving (Eq, Show)++instance FromJSON ApiStatus where+ parseJSON = withText "ApiStatus" $ \case+ "development" -> pure Development+ "stable" -> pure Stable+ "deprecated" -> pure Deprecated+ v -> fail $ "Unknown value: " ++ show v++data AuthStatus = Guest | Untrusted | Trusted deriving (Eq, Show)++instance FromJSON AuthStatus where+ parseJSON = withText "AuthStatus" $ \case+ "guest" -> pure Guest+ "untrusted" -> pure Untrusted+ "trusted" -> pure Trusted+ v -> fail $ "Unknown value: " ++ show v++data JsonOrBinary++instance Accept JsonOrBinary where+ contentTypes _ = ("application" // "octet-stream") :| ["application" // "json"]
+ test/Integration.hs view
@@ -0,0 +1,154 @@+module Main where++import Network.LXD.Client.Internal.Prelude hiding (log)++import Control.Monad.Catch (bracket, bracket_)+import Control.Concurrent (threadDelay)++import Data.Coerce (coerce)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.UUID as UUID++import System.Environment (getExecutablePath, lookupEnv)+import System.Random (randomIO)++import Test.Hspec+import Turtle (sh, procs, empty)++import Network.LXD.Client.Commands hiding (containerName)++main :: IO ()+main = do+ local <- getLocal+ if local+ then runTestSuite+ else bracket createLxd destroyLxd $ \containerName -> do+ initializeLxd containerName+ runTestSuiteLxd containerName+ where+ getLocal = do+ env <- lookupEnv "LOCAL"+ return $ env `elem` map Just ["yes", "y", "1", "true"]++--------------------------------------------------------------------------------++runTestSuite :: IO ()+runTestSuite = hspec testSuite++testSuite :: Spec+testSuite = describe "containers" $ do+ it "should create, start, stop and delete a container" $ runWithLocalHost def $ do+ name <- liftIO randomContainerName+ logOK $ "Creating " ++ show name+ lxcCreate . containerCreateRequest (coerce name)+ . ContainerSourceRemote+ $ remoteImage imagesRemote "alpine/3.4/amd64"++ logOK "Starting" >> lxcStart name+ logOK "Stopping" >> lxcStop name False+ logOK "Deleting" >> lxcDelete name++ it "should execute commands" $ do+ out <- withContainer $ \name -> lxcExec name "/bin/cat" [] "Hello World!"+ out `shouldBe` "Hello World!"++ it "should pull files" $ do+ out <- withContainer $ \name -> lxcFilePullRaw name "/etc/hostname"+ logOK $ "Contents of /etc/hostname: " ++ show out+ out `shouldNotBe` ""++ it "should delete files and directories" $ withExts [ExtFileDelete] $ do+ out <- withContainer $ \name -> do+ _ <- lxcExec name "/bin/mkdir" ["/hello_world_dir"] mempty+ _ <- lxcExec name "/bin/touch" ["/hello_world_file"] mempty+ lxcFileDelete name "/hello_world_dir"+ lxcFileDelete name "/hello_world_file"+ lxcFileListDir name "/"+ out `shouldNotContain` ["hello_world_dir"]+ out `shouldNotContain` ["hello_world_file"]+++randomContainerName :: IO ContainerName+randomContainerName = ContainerName . T.unpack . ("lxd-test-suite-" <>) . UUID.toText <$> randomIO++withContainer :: (ContainerName -> WithLocalHost a) -> IO a+withContainer action = do+ name <- randomContainerName+ let create = lxcCreate . containerCreateRequest (coerce name)+ . ContainerSourceRemote+ $ remoteImage imagesRemote "alpine/3.4/amd64"+ runWithLocalHost def $ bracket_+ (logOK ("Creating " ++ show name) >> create >> lxcStart name)+ (logOK "Stopping" >> lxcStop name True >> lxcDelete name)+ (action name)++withExts :: [ApiExtension] -> IO () -> IO ()+withExts exts action = do+ avail <- apiExtensions <$> runWithLocalHost def lxcApi+ if all (`elem` avail) exts+ then action+ else logErr $ "Could not test: not all extensions available: " ++ show exts++--------------------------------------------------------------------------------++-- | Create a new LXD container.+createLxd :: IO Text+createLxd = do+ containerName <- ("lxd-client-test-" <>) . UUID.toText <$> randomIO+ logOK $ "Creating LXD container " ++ show containerName+ sh $ procs "lxc" ["launch", "images:ubuntu/xenial", containerName,+ "-c", "security.privileged=true",+ "-c", "security.nesting=true"] empty+ threadDelay 5000000+ return containerName++-- | Destory the LXD container.+destroyLxd :: Text -> IO ()+destroyLxd containerName = sh $ do+ logOK $ "destroying LXD container " ++ show containerName+ procs "lxc" ["delete", "-f", containerName] empty++-- | Initialize a container to run tests in.+initializeLxd :: Text -> IO ()+initializeLxd containerName = sh $ do+ logOK $ "Installing LXD into " ++ show containerName+ let exec cmd = procs "lxc" (["exec", containerName, "--"] ++ cmd) empty+ exec ["apt-get", "update"]+ exec ["apt-get", "install", "-y", "software-properties-common"]+ exec ["add-apt-repository", "-y", "ppa:ubuntu-lxc/lxd-stable"]+ exec ["apt-get", "update"]+ exec ["apt-get", "-y", "install", "lxd"]+ exec ["lxd", "init", "--auto"]+ exec ["lxc", "network", "create", "lxdbr0"]+ exec ["lxc", "network", "attach-profile", "lxdbr0", "default", "eth0"]++-- | Run the test suite in the specified container.+runTestSuiteLxd :: Text -> IO ()+runTestSuiteLxd containerName = sh $ do+ executable <- liftIO getExecutablePath+ logOK $ "Pushing " ++ executable ++ " into " ++ show containerName+ procs "lxc" ["file", "push", T.pack executable,+ containerName <> "/usr/local/bin/lxd-client-integration"]+ empty++ logOK $ "Executing the integration tests inside " ++ show containerName+ procs "lxc" ["exec", containerName,+ "--env", "LOCAL=yes", "--",+ "/usr/local/bin/lxd-client-integration"] empty++--------------------------------------------------------------------------------++logOK :: MonadIO m => String -> m ()+logOK = log "[+]"++logErr :: MonadIO m => String -> m ()+logErr = log "[-]"++log :: MonadIO m => String -> String -> m ()+log p m | (w, msg) <- splitLogMessage m = liftIO . putStrLn $ w ++ p ++ " " ++ msg++splitLogMessage :: String -> (String, String)+splitLogMessage = span (== ' ')++--------------------------------------------------------------------------------