diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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 . + +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 +. + + 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 +. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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" diff --git a/lxd-client.cabal b/lxd-client.cabal new file mode 100644 --- /dev/null +++ b/lxd-client.cabal @@ -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: + +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 diff --git a/src/Network/LXD/Client.hs b/src/Network/LXD/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client.hs @@ -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 diff --git a/src/Network/LXD/Client/API.hs b/src/Network/LXD/Client/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/API.hs @@ -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 diff --git a/src/Network/LXD/Client/Commands.hs b/src/Network/LXD/Client/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/Commands.hs @@ -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: +-- +-- 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: +-- +-- +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" +-- diff --git a/src/Network/LXD/Client/Events.hs b/src/Network/LXD/Client/Events.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/Events.hs @@ -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 diff --git a/src/Network/LXD/Client/Internal/Prelude.hs b/src/Network/LXD/Client/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/Internal/Prelude.hs @@ -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)) diff --git a/src/Network/LXD/Client/Remotes.hs b/src/Network/LXD/Client/Remotes.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/Remotes.hs @@ -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" diff --git a/src/Network/LXD/Client/Types.hs b/src/Network/LXD/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/LXD/Client/Types.hs @@ -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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\\/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\/\\/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\/\@. +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\/\\/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\/\\/exec@ with +-- 'ExecImmediate' as configuration. +type ExecResponseMetadataImmediate = Value + +-- | Metadata of a websocket exec repsonse. +-- +-- Returned when querying @POST \/1.0\/containers\/\\/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\/\\/files\/\@ 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\/\\/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\/\@, +-- and as a part of @GET \/1.0\/images\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\@. +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\/\\/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\/\\/volumes\/\\/\@. +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\/\\/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\/\\/volumes\/\\/\@. +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\/\@. +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"] diff --git a/test/Integration.hs b/test/Integration.hs new file mode 100644 --- /dev/null +++ b/test/Integration.hs @@ -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 (== ' ') + +--------------------------------------------------------------------------------