diff --git a/AGPL b/AGPL new file mode 100644 --- /dev/null +++ b/AGPL @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 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 Affero General Public License is a free, copyleft license for +software and other kinds of works, specifically designed to ensure +cooperation with the community in the case of network server software. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +our General Public Licenses are 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. + + 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. + + Developers that use our General Public Licenses protect your rights +with two steps: (1) assert copyright on the software, and (2) offer +you this License which gives you legal permission to copy, distribute +and/or modify the software. + + A secondary benefit of defending all users' freedom is that +improvements made in alternate versions of the program, if they +receive widespread use, become available for other developers to +incorporate. Many developers of free software are heartened and +encouraged by the resulting cooperation. However, in the case of +software used on network servers, this result may fail to come about. +The GNU General Public License permits making a modified version and +letting the public access it on a server without ever releasing its +source code to the public. + + The GNU Affero General Public License is designed specifically to +ensure that, in such cases, the modified source code becomes available +to the community. It requires the operator of a network server to +provide the source code of the modified version running there to the +users of that server. Therefore, public use of a modified version, on +a publicly accessible server, gives the public access to the source +code of the modified version. + + An older license, called the Affero General Public License and +published by Affero, was designed to accomplish similar goals. This is +a different license, not a version of the Affero GPL, but Affero has +released a new version of the Affero GPL which permits relicensing under +this license. + + 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 Affero 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. Remote Network Interaction; Use with the GNU General Public License. + + Notwithstanding any other provision of this License, if you modify the +Program, your modified version must prominently offer all users +interacting with it remotely through a computer network (if your version +supports such interaction) an opportunity to receive the Corresponding +Source of your version by providing access to the Corresponding Source +from a network server at no charge, through some standard or customary +means of facilitating copying of software. This Corresponding Source +shall include the Corresponding Source for any work covered by version 3 +of the GNU General Public License that is incorporated pursuant to the +following paragraph. + + 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 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 work with which it is combined will remain governed by version +3 of the GNU General Public License. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU Affero 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 Affero 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 Affero 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 Affero 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. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero 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 Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If your software can interact with users remotely through a computer +network, you should also make sure that it provides a way for users to +get its source. For example, if your program is a web application, its +interface could display a "Source" link that leads users to an archive +of the code. There are many ways you could offer source, and different +solutions will be better for different programs; see section 13 for the +specific requirements. + + 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 AGPL, see +. diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,5 @@ +debug-me (1.20170505) unstable; urgency=medium + + * First release of debug-me. + + -- Joey Hess Thu, 04 May 2017 17:03:19 -0400 diff --git a/CmdLine.hs b/CmdLine.hs new file mode 100644 --- /dev/null +++ b/CmdLine.hs @@ -0,0 +1,176 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module CmdLine where + +import Types +import ServerList + +import Data.Monoid +import Options.Applicative +import Network.URI +import Network.Wai.Handler.Warp (Port) +import qualified Data.Text as T + +data CmdLine = CmdLine + { mode :: Mode + } + +data Mode + = UserMode UserOpts + | DeveloperMode DeveloperOpts + | DownloadMode DownloadOpts + | WatchMode WatchOpts + | GraphvizMode GraphvizOpts + | ReplayMode ReplayOpts + | VerifyMode VerifyOpts + | ServerMode ServerOpts + | ControlMode ControlOpts + +data UserOpts = UserOpts + { cmdToRun :: Maybe String + , useServer :: URI + } + +data DeveloperOpts = DeveloperOpts + { debugUrl :: URI + } + +data DownloadOpts = DownloadOpts + { downloadUrl :: URI + } + +data WatchOpts = WatchOpts + { watchUrl :: URI + } + +data GraphvizOpts = GraphvizOpts + { graphvizLogFile :: FilePath + , graphvizShowHashes :: Bool + } + +data ReplayOpts = ReplayOpts + { replayLogFile :: FilePath + } + +data VerifyOpts = VerifyOpts + { verifyLogFile :: FilePath + } + +data ServerOpts = ServerOpts + { serverDirectory :: FilePath + , serverPort :: Port + , serverEmail :: Maybe EmailAddress + , serverDeleteOldLogs :: Bool + } + +data ControlOpts = ControlOpts + { controlWindowEnabled :: Bool + } + +parseCmdLine :: Parser CmdLine +parseCmdLine = CmdLine <$> parseMode + +parseMode :: Parser Mode +parseMode = (UserMode <$> parseuser) + <|> (DeveloperMode <$> parsedeveloper) + <|> (ReplayMode <$> parsereplay) + <|> (VerifyMode <$> parseverify) + <|> (DownloadMode <$> parsedownload) + <|> (WatchMode <$> parsewatch) + <|> (GraphvizMode <$> parsegraphviz) + <|> (ServerMode <$> parseserver) + <|> (ControlMode <$> parsecontrol) + where + parseuser = UserOpts + <$> optional (strOption + ( long "run" + <> metavar "command" + <> help "program to run (default: login shell)" + )) + <*> option readurl + ( long "use-server" + <> metavar "url" + <> value defaultServerUrl + <> showDefault + <> help "url of debug-me server to use" + ) + parsedeveloper = DeveloperOpts + <$> argument readurl + ( metavar "url" + <> help "debug a user on the given url" + ) + parsegraphviz = GraphvizOpts + <$> option str + ( long "graphviz" + <> metavar "logfile" + <> help "visualize log file with graphviz" + ) + <*> switch + ( long "show-hashes" + <> help "display hashes in graphviz" + ) + parsereplay = ReplayOpts + <$> option str + ( long "replay" + <> metavar "logfile" + <> help "replay log file" + ) + parseverify = VerifyOpts + <$> option str + ( long "verify" + <> metavar "logfile" + <> help "verify log file" + ) + parsedownload = DownloadOpts + <$> option readurl + ( long "download" + <> metavar "url" + <> help "download log file from server" + ) + parsewatch = WatchOpts + <$> option readurl + ( long "watch" + <> metavar "url" + <> help "display a debug-me session non-interactively" + ) + parseserver = ServerOpts + <$> strOption + ( long "server" + <> metavar "logdir" + <> help "run server, storing logs in the specified directory" + ) + <*> option auto + ( long "port" + <> metavar "N" + <> value 8081 + <> showDefault + <> help "port for server to listen on" + ) + <*> optional (T.pack <$> strOption + ( long "from-email" + <> metavar "address" + <> help "email session logs using this from address" + )) + <*> switch + ( long "delete-old-logs" + <> help "delete session logs after session is done" + ) + parsecontrol = ControlOpts + <$> switch + ( long "control" + <> help "control running debug-me session" + ) + +getCmdLine :: IO CmdLine +getCmdLine = execParser opts + where + opts = info (helper <*> parseCmdLine) + ( fullDesc + <> header "debug-me - provable remote debugging sessions" + ) + +readurl :: ReadM URI +readurl = eitherReader $ maybe (Left "url parse error") Right . parseURI diff --git a/ControlSocket.hs b/ControlSocket.hs new file mode 100644 --- /dev/null +++ b/ControlSocket.hs @@ -0,0 +1,130 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveGeneric #-} + +-- | debug-me session control unix socket + +module ControlSocket where + +import Types +import DotDir +import JSON + +import System.IO +import System.Posix +import System.FilePath +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Control.Exception +import qualified Network.Socket as S +import qualified Data.ByteString.Lazy as L +import Data.Char + +data ControlInput + = ControlInputAction ControlAction + | ControlWindowMessage String + deriving (Show, Generic) + +data ControlOutput + = ControlOutputAction ControlAction + | ControlWindowOpened + | ControlWindowRequestedImmediateQuit + deriving (Show, Generic) + +instance ToJSON ControlInput +instance FromJSON ControlInput +instance ToJSON ControlOutput +instance FromJSON ControlOutput + +defaultSocketFile :: IO FilePath +defaultSocketFile = ( "control") <$> dotDir + +bindSocket :: FilePath -> IO S.Socket +bindSocket socketfile = do + -- Delete any existing socket file. + _ <- try (removeLink socketfile) :: IO (Either IOException ()) + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.bind soc (S.SockAddrUnix socketfile) + setFileMode socketfile (unionFileModes ownerWriteMode ownerReadMode) + S.listen soc 2 + return soc + +-- | Serve connections to the control socket, feeding data between it and +-- the TMChans. +-- +-- Returns once either of the TMChans is closed. +serveControlSocket :: S.Socket -> TMChan ControlInput -> TMChan ControlOutput -> IO () +serveControlSocket soc ichan ochan = do + _ <- serve `race` waitclose + return () + where + serve = do + (sconn, _) <- S.accept soc + conn <- S.socketToHandle sconn ReadWriteMode + hSetBinaryMode conn True + _ <- async $ sendToConn conn ichan + `race` receiveFromConn conn ochan + serve + waitclose = atomically $ do + ic <- isClosedTMChan ichan + oc <- isClosedTMChan ochan + if ic || oc + then return () + else retry + +-- | Connects to the control socket and feeds data between it and the +-- TMChans. +-- +-- Returns when the socket server exits or the TMChan ControlInput is +-- closed. +connectControlSocket :: FilePath -> TMChan ControlInput -> TMChan ControlOutput -> IO () +connectControlSocket socketfile ichan ochan = bracket setup cleanup connected + where + setup = do + soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol + S.connect soc (S.SockAddrUnix socketfile) + conn <- S.socketToHandle soc ReadWriteMode + hSetBinaryMode conn True + return conn + cleanup conn = do + hClose conn + atomically $ do + closeTMChan ichan + closeTMChan ochan + connected conn = do + _ <- sendToConn conn ochan + `race` receiveFromConn conn ichan + return () + +sendToConn :: ToJSON a => Handle -> TMChan a -> IO () +sendToConn conn chan = go =<< atomically (readTMChan chan) + where + go Nothing = return () + go (Just v) = do + L.hPut conn (encode v) + hPutStr conn "\n" + hFlush conn + sendToConn conn chan + +receiveFromConn :: FromJSON a => Handle -> TMChan a -> IO () +receiveFromConn conn chan = withLines conn go + where + go [] = return () + go (l:ls) + | L.null l = go ls + | otherwise = case decode l of + Nothing -> error "internal control message parse error" + Just v -> do + atomically $ writeTMChan chan v + go ls + +withLines :: Handle -> ([L.ByteString] -> IO a) -> IO a +withLines conn a = do + ls <- L.split nl <$> L.hGetContents conn + a ls + where + nl = fromIntegral (ord '\n') diff --git a/ControlWindow.hs b/ControlWindow.hs new file mode 100644 --- /dev/null +++ b/ControlWindow.hs @@ -0,0 +1,195 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +-- | debug-me session control window + +module ControlWindow where + +import Types +import CmdLine +import ControlSocket +import VirtualTerminal +import Gpg +import Gpg.Wot +import Output + +import System.IO +import System.Environment +import System.Process +import System.Posix +import Control.Exception +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Data.ByteString.UTF8 (fromString, toString) +import Data.Char +import Control.Monad +import Data.Monoid +import Prelude + +winDesc :: String +winDesc = "debug-me session control and chat window" + +displayInControlWindow :: TMChan ControlInput -> String -> IO () +displayInControlWindow ichan msg = atomically $ + writeTMChan ichan (ControlWindowMessage msg) + +controlWindow :: ControlOpts -> IO () +controlWindow _ = do + putStrLn $ "** " ++ winDesc + putStrLn "(Enter /quit here at any time to end the debug-me session.)" + socketfile <- defaultSocketFile + ichan <- newTMChanIO + ochan <- newTMChanIO + promptchan <- newTChanIO + responsechan <- newTChanIO + -- Let the debug-me that's being controlled know that the control + -- window is open. + atomically $ writeTMChan ochan ControlWindowOpened + _ <- connectControlSocket socketfile ichan ochan + `race` displayInput ochan ichan promptchan responsechan + `race` collectOutput ochan promptchan responsechan + putStrLn $ "** " ++ winDesc ++ " closing; debug-me session is done" + return () + +-- | Opens the control window, or if that can't be done, tells the user +-- to run debug-me --control. +-- +-- Returns once either of the TMChans is closed. +openControlWindow :: IO (TMChan ControlInput, TMChan ControlOutput) +openControlWindow = do + socketfile <- defaultSocketFile + soc <- bindSocket socketfile + ichan <- newTMChanIO + ochan <- newTMChanIO + _ <- async $ serveControlSocket soc ichan ochan + myexe <- getMyExe + mproc <- runInVirtualTerminal winDesc myexe ["--control"] + let cannotrun = do + putStrLn "You need to open another shell prompt, and run: debug-me --control" + return (ichan, ochan) + case mproc of + Nothing -> cannotrun + Just p -> do + (_, _, _, pid) <- createProcess p + -- Wait for message from control process. + v <- atomically (readTMChan ochan) + `race` waitForProcess pid + case v of + Left (Just ControlWindowOpened) -> return (ichan, ochan) + Left _ -> error "unexpected message from control process" + Right _ -> cannotrun + + +-- | Get path to debug-me program. +-- +-- The standalone bundle sets DEBUG_ME_EXE to the path to use. +getMyExe :: IO FilePath +getMyExe = maybe getExecutablePath return =<< lookupEnv "DEBUG_ME_EXE" + +type Prompt = () +type Response = String + +type PromptChan = TChan Prompt +type ResponseChan = TChan Response + +collectOutput :: TMChan ControlOutput -> PromptChan -> ResponseChan -> IO () +collectOutput ochan promptchan responsechan = do + myusername <- fromString <$> getLoginName + loop myusername + where + loop myusername = do + l <- getLine + if map toLower l == "/quit" + then atomically $ + writeTMChan ochan ControlWindowRequestedImmediateQuit + else do + mc <- atomically $ do + -- Is any particular input being prompted for now? + mp <- tryReadTChan promptchan + case mp of + Just _ -> do + writeTChan responsechan l + return Nothing + Nothing -> do + let c = ChatMessage (Val myusername) (Val $ fromString l) + writeTMChan ochan $ ControlOutputAction c + return (Just c) + maybe (return ()) displayChatMessage mc + loop myusername + +displayInput :: TMChan ControlOutput -> TMChan ControlInput -> PromptChan -> ResponseChan -> IO () +displayInput ochan ichan promptchan responsechan = loop + where + loop = go =<< atomically (readTMChan ichan) + go Nothing = return () + go (Just (ControlWindowMessage m)) = do + putStrLn m + loop + go (Just (ControlInputAction (SessionKey k _))) = do + askToAllow ochan promptchan responsechan k + loop + go (Just (ControlInputAction m@(ChatMessage {}))) = do + displayChatMessage m + loop + go _ = loop + +displayChatMessage :: ControlAction -> IO () +displayChatMessage (ChatMessage username msg) = do + putStrLn $ sanitizeForDisplay $ toString $ + "<" <> val username <> "> " <> val msg + hFlush stdout +displayChatMessage _ = return () + +askToAllow :: TMChan ControlOutput -> PromptChan -> ResponseChan -> PerhapsSigned PublicKey -> IO () +askToAllow ochan _ _ (UnSigned pk) = atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyRejected pk +askToAllow ochan promptchan responsechan k@(GpgSigned pk _ _) = do + putStrLn "Someone wants to connect to this debug-me session." + putStrLn "Checking their GnuPG signature ..." + (v, gpgoutput) <- gpgVerify k + putStr $ unlines $ map sanitizeForDisplay $ lines $ toString gpgoutput + case v of + Nothing -> do + putStrLn "Unable to download their GnuPG key, or signature verification failed." + reject + Just gpgkeyid -> flip catch woterror $ do + putStrLn "Checking the GnuPG web of trust ..." + ss <- isInStrongSet gpgkeyid + ws <- downloadWotStats gpgkeyid + putStrLn $ unlines $ map sanitizeForDisplay $ + describeWot ws ss + promptconnect + where + promptconnect :: IO () + promptconnect = do + atomically $ writeTChan promptchan () + putStr "Let them connect to the debug-me session and run commands? [y/n] " + hFlush stdout + r <- atomically $ readTChan responsechan + case map toLower r of + "y" -> accept + "yes" -> accept + "n" -> reject + "no" -> reject + _ -> promptconnect + reject = do + putStrLn "Rejecting their connection." + atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyRejected pk + accept = do + putStrLn "Connection accepted. They can now enter commands in this debug-me session." + putStrLn "(And, you can type in this window to chat with them.)" + atomically $ writeTMChan ochan $ + ControlOutputAction $ SessionKeyAccepted pk + woterror :: SomeException -> IO () + woterror e = do + putStrLn (show e) + putStrLn "Web of trust check failed!" + putStrLn "" + putStrLn "Their identity cannot be verified!" + promptconnect diff --git a/Crypto.hs b/Crypto.hs new file mode 100644 --- /dev/null +++ b/Crypto.hs @@ -0,0 +1,99 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-} + +module Crypto where + +import Val +import Hash +import Types + +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import Crypto.Error +import Crypto.Random.Entropy +import Data.ByteArray (convert) +import qualified Data.ByteString as B + +dummySignature :: Signature +dummySignature = OtherSignature (Val mempty) + +class Signed t where + getSignature :: t -> Signature + hashExceptSignature :: t -> Hash + mkSigned :: MySessionKey -> (Signature -> t) -> t + mkSigned sk mk = + let tmp = mk dummySignature + in mk (sign sk tmp) + +instance Hashable a => Signed (Activity a) where + getSignature = activitySignature + hashExceptSignature (Activity a mpa mpe mt _s) = hash $ + Tagged "Activity" [hash a, hash mpa, hash mpe, hash mt] + +instance Signed Control where + getSignature = controlSignature + hashExceptSignature (Control a _s) = hash $ + Tagged "Control" a + +instance Hashable t => Signed (Message t) where + getSignature (ActivityMessage a) = getSignature a + getSignature (ControlMessage c) = getSignature c + hashExceptSignature (ActivityMessage a) = hashExceptSignature a + hashExceptSignature (ControlMessage c) = hashExceptSignature c + +instance Signed AnyMessage where + getSignature (User m) = getSignature m + getSignature (Developer m) = getSignature m + hashExceptSignature (User m) = hashExceptSignature m + hashExceptSignature (Developer m) = hashExceptSignature m + +sign :: Signed v => MySessionKey -> v -> Signature +sign (MySessionKey sk pk) v = Ed25519Signature $ Val $ convert $ + Ed25519.sign sk pk (toSign v) + +toSign :: Signed v => v -> B.ByteString +toSign = val . hashValue . hashExceptSignature + +-- | Verifiy the signature of a Signed value. +verifySigned :: Signed v => SigVerifier -> v -> Bool +verifySigned (SigVerifier _ verifier) v = + case getSignature v of + Ed25519Signature (Val s) -> + case Ed25519.signature s of + CryptoPassed sig -> verifier (toSign v) sig + CryptoFailed _ -> False + OtherSignature _ -> False + +data SigVerifier = SigVerifier Int (B.ByteString -> Ed25519.Signature -> Bool) + +instance Show SigVerifier where + show (SigVerifier n _) = "SigVerifier (" ++ show n ++ ")" + +mkSigVerifier :: PublicKey -> SigVerifier +mkSigVerifier (PublicKey (Val pk)) = + case Ed25519.publicKey pk of + CryptoPassed pk' -> SigVerifier 1 (Ed25519.verify pk') + CryptoFailed _ -> mempty + +instance Monoid SigVerifier where + mempty = SigVerifier 0 $ \_b _s -> False + mappend (SigVerifier na a) (SigVerifier nb b) = + SigVerifier (na+nb) $ \d s -> b d s || a d s + +data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey + +instance Show MySessionKey where + show _ = "" + +genMySessionKey :: IO MySessionKey +genMySessionKey = do + -- Crypto.Random.Entropy may use rdrand, or /dev/random. + -- Even if you don't trust rdrand to be free of backdoors, + -- it seems safe enough to use it for a session key that + -- is only used for signing, not encryption. + rand32 <- getEntropy 32 :: IO B.ByteString + sk <- throwCryptoErrorIO $ Ed25519.secretKey rand32 + return $ MySessionKey sk (Ed25519.toPublic sk) diff --git a/DotDir.hs b/DotDir.hs new file mode 100644 --- /dev/null +++ b/DotDir.hs @@ -0,0 +1,17 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module DotDir where + +import System.Posix +import System.Directory +import System.FilePath + +dotDir :: IO FilePath +dotDir = do + home <- homeDirectory <$> (getUserEntryForID =<< getEffectiveUserID) + let dir = home ".debug-me" + createDirectoryIfMissing False dir + return dir diff --git a/Gpg.hs b/Gpg.hs new file mode 100644 --- /dev/null +++ b/Gpg.hs @@ -0,0 +1,164 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Gpg where + +import Val +import Hash +import Types +import Crypto + +import Data.ByteArray (convert) +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as B8 +import System.IO +import System.Posix.IO hiding (createPipe) +import System.Process +import System.Exit +import Control.Exception +import System.Directory +import Control.Concurrent.Async + +newtype GpgKeyId = GpgKeyId String + deriving (Show) + +newtype GpgSign = GpgSign Bool + +myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey) +myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do + let pk = PublicKey (Val $ convert epk) + if gpgsign + then gpgSign pk + else return (UnSigned pk) + +-- | Sign a debug-me session PublicKey with gpg. +gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey) +gpgSign pk = do + putStrLn "Using gpg to sign the debug-me session key." + -- Write it to a temp file because gpg sometimes is unhappy + -- about password prompting when stdin is not connected to + -- the console. + tmpdir <- getTemporaryDirectory + (tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp" + B.hPut tmph $ val $ hashValue $ hash pk + hClose tmph + (_, Just hout, _, pid) <- createProcess $ + (proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile]) + { std_out = CreatePipe + } + hSetBinaryMode hout True + sig <- GpgSig . Val <$> B.hGetContents hout + st <- waitForProcess pid + _ <- try (removeFile tmpfile) :: IO (Either IOException ()) + case st of + ExitSuccess -> do + -- Verify the just signed data to determine + -- the gpg public key used to sign it. The gpg + -- public key is included in the GpgSigned data. + v <- fst <$> gpgVerifyClearSigned sig + case v of + Just (gpgkeyid, _) -> do + pubkey <- gpgExportPublicKey gpgkeyid + return $ GpgSigned pk sig pubkey + Nothing -> error "gpg sign verification failed" + ExitFailure _ -> error "gpg sign failed" + +-- | Export gpg public key in minimal form. +gpgExportPublicKey :: GpgKeyId -> IO GpgKeyExport +gpgExportPublicKey (GpgKeyId gpgkeyid) = do + (_, Just hout, _, pid) <- createProcess $ + (proc "gpg" opts) + { std_out = CreatePipe + } + hSetBinaryMode hout True + b <- B.hGetContents hout + st <- waitForProcess pid + if st == ExitSuccess + then return $ GpgKeyExport $ Val b + else error "gpg --export failed" + where + opts = + [ "-a" + , "--export-options", "no-export-attributes,export-minimal" + , "--export", gpgkeyid + ] + +gpgImportPublicKey :: GpgKeyExport -> IO () +gpgImportPublicKey (GpgKeyExport (Val b)) = do + (Just hin, Just hout, Just herr, pid) <- createProcess $ + (proc "gpg" [ "--import"] ) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + hSetBinaryMode hin True + B.hPut hin b + hClose hin + _ <- B.hGetContents hout + `concurrently` B.hGetContents herr + _ <- waitForProcess pid + return () + +-- | Verify the gpg signature and return the keyid that signed it. +-- Also makes sure that the gpg signed data is the hash of the +-- debug-me PublicKey. +gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId, SignInfoDesc) +gpgVerify (UnSigned _) = return (Nothing, mempty) +gpgVerify (GpgSigned pk gpgsig keyexport) = do + gpgImportPublicKey keyexport + go =<< gpgVerifyClearSigned gpgsig + where + go (Nothing, s) = return (Nothing, s) + go (Just (gpgkeyid, signeddata), s) = do + let norm = filter (not . B.null) . B8.lines + let pkissigned = norm signeddata == norm (val (hashValue (hash pk))) + return $ if pkissigned + then (Just gpgkeyid, s) + else (Nothing, s) + +type SignInfoDesc = B.ByteString + +-- | Verify a clearsigned GpgSig, returning the key id used to sign it, +-- and the data that was signed. +-- +-- Gpg outputs to stderr information about who signed the +-- data, and that is returned also. +gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString), SignInfoDesc) +gpgVerifyClearSigned (GpgSig (Val sig)) = do + (statusreadh, statuswriteh) <- createPipe + statuswritefd <- handleToFd statuswriteh + (Just hin, Just hout, Just herr, pid) <- createProcess $ + (proc "gpg" (verifyopts statuswritefd)) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + closeFd statuswritefd + B.hPut hin sig + hClose hin + hSetBinaryMode hout True + ((signeddata, sigdesc), mgpgkeyid) <- B.hGetContents hout + `concurrently` B.hGetContents herr + `concurrently` (parseStatusFd <$> hGetContents statusreadh) + st <- waitForProcess pid + let siginfo = if st == ExitSuccess + then case mgpgkeyid of + Just gpgkeyid -> Just (gpgkeyid, signeddata) + Nothing -> Nothing + else Nothing + return (siginfo, sigdesc) + where + verifyopts statuswritefd = + [ "--status-fd", show statuswritefd + , "--verify" + , "--output", "-" + ] + +parseStatusFd :: String -> Maybe GpgKeyId +parseStatusFd = go . map words . lines + where + go [] = Nothing + go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid) + go (_:rest) = go rest diff --git a/Gpg/Wot.hs b/Gpg/Wot.hs new file mode 100644 --- /dev/null +++ b/Gpg/Wot.hs @@ -0,0 +1,119 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveGeneric #-} + +-- | Gpg web of trust checking, using wotsap's JSON output + +module Gpg.Wot where + +import Gpg +import JSON + +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Data.List +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T + +data WotStats = WotStats + { key :: Node + , cross_sigs :: [Node] + , key_signed :: [Node] + , other_sigs :: [Node] + } + deriving (Show, Generic) + +data WotPath = WotPath + { from :: Node + , to :: Node + , xpaths :: [[Node]] + } + deriving (Show, Generic) + +data Node = Node + { kid :: String + , msd :: Double + , rank :: Integer + , uid :: String + } + deriving (Show, Generic) + +-- | wotsap's json has some upper-case fields; lowercase field for parsing +jsonLower :: Value -> Value +jsonLower (Object o) = Object . M.fromList . map lowerPair . M.toList $ o + where + lowerPair (k, v) = (T.toLower k, v) +jsonLower x = x + +instance FromJSON WotStats where + parseJSON = genericParseJSON defaultOptions . jsonLower + +instance FromJSON WotPath where + parseJSON = genericParseJSON defaultOptions . jsonLower + +instance FromJSON Node where + parseJSON = genericParseJSON defaultOptions . jsonLower + +wotServer :: String +wotServer = "https://pgp.cs.uu.nl/" + +downloadWotStats :: GpgKeyId -> IO (Maybe WotStats) +downloadWotStats (GpgKeyId k) = do + manager <- getGlobalManager + request <- parseRequest url + response <- httpLbs request manager + return $ decode (responseBody response) + where + url = wotServer ++ "/stats/" ++ k ++ ".json" + +downloadWotPath :: GpgKeyId -> GpgKeyId -> IO (Maybe WotPath) +downloadWotPath (GpgKeyId fromid) (GpgKeyId toid) = do + manager <- getGlobalManager + request <- parseRequest url + response <- httpLbs request manager + return $ decode (responseBody response) + where + url = wotServer ++ "/paths/" ++ fromid ++ "/to/" ++ toid ++ ".json" + +-- | A key that is known to be in the strong set. +-- +-- This could be any key in the gpg strong set. Currently, it's +-- Joey Hess's key, which is in the strong set and belongs to the author of +-- this program, which the user must implicitly trust since they're running +-- it. But any key in the strong set would work as well; this is only used +-- to determine if other keys have a path into the strong set. +knownKeyInStrongSet :: GpgKeyId +knownKeyInStrongSet = GpgKeyId "E85A5F63B31D24C1EBF0D81CC910D9222512E3C7" + +newtype StrongSetAnalysis = StrongSetAnalysis Bool + deriving (Show) + +isInStrongSet :: GpgKeyId -> IO StrongSetAnalysis +isInStrongSet k = maybe (StrongSetAnalysis False) (const $ StrongSetAnalysis True) + <$> downloadWotPath k knownKeyInStrongSet + +describeWot :: Maybe WotStats -> StrongSetAnalysis -> [String] +describeWot (Just ws) (StrongSetAnalysis ss) + | ss == False = [theirname ++ "'s identity cannot be verified!"] + | otherwise = + [ theirname ++ "'s identity has been verified by as many as " + ++ show (length sigs) ++ " people, including:" + , intercalate ", " $ take 10 $ nub $ + map (stripEmail . uid) bestconnectedsigs + , "" + , theirname ++ " is probably a real person." + ] + where + theirname = stripEmail (uid (key ws)) + sigs = cross_sigs ws ++ other_sigs ws + bestconnectedsigs = sortOn rank sigs +describeWot Nothing _ = + [ "" + , "Their identity cannot be verified!" + ] + +stripEmail :: String -> String +stripEmail = unwords . takeWhile (not . ("<" `isPrefixOf`)) . words diff --git a/Graphviz.hs b/Graphviz.hs new file mode 100644 --- /dev/null +++ b/Graphviz.hs @@ -0,0 +1,137 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} + +module Graphviz (graphviz) where + +import Types +import CmdLine +import Log + +import Data.Char hiding (Control) +import Data.Monoid +import Data.GraphViz +import Data.GraphViz.Attributes.Complete +import Data.GraphViz.Types.Generalised as G +import Data.GraphViz.Types.Monadic +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import Data.Text.Encoding.Error + +graphviz :: GraphvizOpts -> IO () +graphviz opts = do + l <- streamLog (graphvizLogFile opts) + let g = genGraph opts l + f <- createImage (graphvizLogFile opts) Png g + putStrLn ("Generated " ++ f) + +createImage :: PrintDotRepr dg n => FilePath -> GraphvizOutput -> dg n -> IO FilePath +createImage f o g = Data.GraphViz.addExtension (runGraphvizCommand Dot g) o f + +genGraph :: GraphvizOpts -> [Either String Log] -> G.DotGraph T.Text +genGraph opts ls = digraph (Str "debug-me") $ do + nodeAttrs [style filled] + forM_ ls $ + showlog [ xcolor Green ] + where + showlog s (Right l) = showactivity s l + showlog _ (Left l) = node (display l) [xcolor Red, shape DiamondShape] + + showactivity s l = case (loggedMessage l, loggedHash l) of + (User (ActivityMessage a), Just h) -> do + node (display h) $ s ++ + [ textLabel $ prettyDisplay $ activity a + , shape BoxShape + ] + linkprev s a h + (Developer (ActivityMessage a), Just h) -> do + node (display h) $ s ++ + [ textLabel $ prettyDisplay $ activity a + , shape Circle + ] + linkprev s a h + (User (ControlMessage c), Nothing) -> showcontrol c + (Developer (ControlMessage c), Nothing) -> showcontrol c + _ -> return () + + showcontrol (Control (EnteredRejected hr _) _) = do + let rejstyle = + [ xcolor Red + , Style [dashed, filled] + ] + let nodename = display $ "Rejected: " <> display hr + node nodename $ rejstyle ++ + [ textLabel "Rejected" + , shape BoxShape + ] + edge nodename (display hr) rejstyle + showcontrol _ = return () + + linkprev s a h = do + case prevActivity a of + Nothing -> return () + Just p -> link p h s + case prevEntered a of + Nothing -> return () + Just p -> link p h (s ++ enteredpointerstyle) + link a b s = edge (display a) (display b) $ s ++ + if graphvizShowHashes opts + then [ textLabel (prettyDisplay a) ] + else [] + + enteredpointerstyle = [ xcolor Gray ] + +xcolor :: X11Color -> Attribute +xcolor c = Color [toWC $ X11Color c] + +class Display t where + -- Display more or less as-is, for graphviz. + display :: t -> T.Text + -- Prettified display for user-visible labels etc. + prettyDisplay :: t -> T.Text + prettyDisplay = prettyDisplay . display + +instance Display T.Text where + display = id + prettyDisplay t + | all visible s = t + | all isPrint s && not (leadingws s) && not (leadingws (reverse s)) = t + | otherwise = T.pack (show s) + where + s = T.unpack t + visible c = isPrint c && not (isSpace c) + leadingws (c:_) = isSpace c + leadingws _ = False + +instance Display String where + display = display . T.pack + +instance Display Val where + display (Val b) = T.decodeUtf8With lenientDecode (L.fromStrict b) + +instance Display Hash where + display (Hash m h) = T.pack (show m) <> display h + -- Use short hash for pretty display. + -- The "h:" prefix is to work around this bug: + -- https://github.com/ivan-m/graphviz/issues/16 + prettyDisplay h = display $ Val $ "h:" <> (B.take 5 $ val $ hashValue h) + +instance Display Seen where + display = display . seenData + +instance Display Entered where + display v + | B.null (val $ echoData v) = display $ enteredData v + | otherwise = "[" <> display (echoData v) <> "] " <> display (enteredData v) + +instance Display Control where + display = display . control + +instance Display ControlAction where + display = T.pack . show diff --git a/Hash.hs b/Hash.hs new file mode 100644 --- /dev/null +++ b/Hash.hs @@ -0,0 +1,92 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} + +module Hash where + +import Types + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Crypto.Hash as H + +class Hashable a where + hash :: a -> Hash + +instance Hashable B.ByteString where + -- Encodes the SHA512 using base16 format + hash = Hash SHA512 . Val . C8.pack . show . sha512 + +instance Hashable Val where + hash (Val v) = hash v + +instance Hashable Hash where + hash = id + +sha512 :: B.ByteString -> H.Digest H.SHA512 +sha512 = H.hash + +-- | A value tagged with a ByteString describing the type of value. +-- This is hashed by hashing the concacenation of the hash of the +-- bytestring and the hash of the value. This way, items of different types +-- but with the same internal content will hash differently. For example, +-- a Seen "foo" and a Entered "foo" should not hash the same. +data Tagged a = Tagged B.ByteString a + +instance Hashable a => Hashable (Tagged a) where + hash (Tagged b a) = hash [hash b, hash a] + +instance Hashable a => Hashable (Activity a) where + hash (Activity a mps mpe mt s) = hash $ Tagged "Activity" + [hash a, hash mps, hash mpe, hash mt, hash s] + +instance Hashable Entered where + hash v = hash $ Tagged "Entered" + [hash (enteredData v), hash (echoData v)] + +instance Hashable Seen where + hash v = hash $ Tagged "Seen" [hash (seenData v)] + +instance Hashable ControlAction where + hash (EnteredRejected h1 h2) = hash $ Tagged "EnteredRejected" + [hash h1, hash h2] + hash (SessionKey pk v) = hash $ Tagged "SessionKey" [hash pk, hash v] + hash (SessionKeyAccepted pk) = hash $ Tagged "SessionKeyAccepted" pk + hash (SessionKeyRejected pk) = hash $ Tagged "SessionKeyRejected" pk + hash (ChatMessage u m) = hash $ Tagged "ChatMessage" [hash u, hash m] + +instance Hashable Signature where + hash (Ed25519Signature s) = hash $ Tagged "Ed25519Signature" s + hash (OtherSignature s) = hash $ Tagged "OtherSignature" s + +instance Hashable PublicKey where + hash (PublicKey v) = hash $ Tagged "PublicKey" v + +instance Hashable GpgSig where + hash (GpgSig v) = hash $ Tagged "GpgSig" v + +instance Hashable GpgKeyExport where + hash (GpgKeyExport v) = hash $ Tagged "GpgKeyExport" v + +instance Hashable a => Hashable (PerhapsSigned a) where + hash (GpgSigned a sig export) = hash $ + Tagged "GpgSigned" [hash a, hash sig, hash export] + hash (UnSigned a) = hash $ Tagged "UnSigned" a + +instance Hashable ElapsedTime where + hash (ElapsedTime n) = hash $ Tagged "ElapsedTime" $ C8.pack $ show n + +-- | Hash a list of hashes by hashing the concacenation of the hashes. +instance Hashable [Hash] where + hash = hash . B.concat . map (val . hashValue) + +-- | Hash empty string for Nothing +instance Hashable v => Hashable (Maybe v) where + hash Nothing = hash () + hash (Just v) = hash v + +instance Hashable () where + hash () = hash (mempty :: B.ByteString) diff --git a/JSON.hs b/JSON.hs new file mode 100644 --- /dev/null +++ b/JSON.hs @@ -0,0 +1,18 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module JSON ( + module Data.Aeson, + Generic, + sumOptions +) where + +import GHC.Generics (Generic) +import Data.Aeson +import qualified Data.Aeson.Types as Aeson + +-- | Nicer JSON encoding for sum types. +sumOptions :: Aeson.Options +sumOptions = defaultOptions { Aeson.sumEncoding = Aeson.ObjectWithSingleField } diff --git a/Log.hs b/Log.hs new file mode 100644 --- /dev/null +++ b/Log.hs @@ -0,0 +1,101 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveGeneric #-} + +module Log where + +import Types +import Hash +import Memory +import JSON +import SessionID +import DotDir + +import Data.Char +import Data.Time.Clock.POSIX +import qualified Data.ByteString.Lazy as L +import System.IO +import System.Directory +import System.FilePath +import Control.Exception + +-- | One item in a log of a debug-me session. +-- +-- Note that the time stamp is included to allow replaying logs, but +-- it's not part of the provable session. +-- +-- Note that changing this in ways that change the JSON serialization +-- changes debug-me's log file format. +data Log = Log + { loggedMessage :: AnyMessage + , loggedHash :: Maybe Hash + , loggedTimestamp :: Timestamp + } + deriving (Show, Generic) + +instance DataSize Log where + dataSize l = dataSize (loggedMessage l) + + maybe 0 dataSize (loggedHash l) + + 2 + +instance ToJSON Log +instance FromJSON Log + +mkLog :: AnyMessage -> POSIXTime -> Log +mkLog m now = Log + { loggedMessage = m + , loggedHash = case m of + User (ActivityMessage a) -> Just (hash a) + Developer (ActivityMessage a) -> Just (hash a) + User (ControlMessage _) -> Nothing + Developer (ControlMessage _) -> Nothing + , loggedTimestamp = now + } + +type Timestamp = POSIXTime + +type Logger = AnyMessage -> IO () + +logDir :: IO FilePath +logDir = ( "log") <$> dotDir + +withSessionLogger :: (Maybe FilePath) -> SessionID -> (Logger -> IO a) -> IO a +withSessionLogger subdir sessionid a = bracket setup cleanup go + where + setup = do + basedir <- logDir + let dir = maybe basedir (basedir ) subdir + createDirectoryIfMissing False dir + return $ sessionLogFile dir sessionid + cleanup logfile = putStrLn $ "** debug-me session was logged to " ++ logfile + go logfile = withFile logfile WriteMode (a . mkLogger) + +withLogger :: FilePath -> (Logger -> IO a) -> IO a +withLogger logfile a = withFile logfile WriteMode (a . mkLogger) + +nullLogger :: Logger +nullLogger _ = return () + +mkLogger :: Handle -> Logger +mkLogger h a = do + l <- mkLog a <$> getPOSIXTime + writeLogHandle l h + +writeLogHandle :: Log -> Handle -> IO () +writeLogHandle l h = do + L.hPut h (encode l) + hPutStr h "\n" + hFlush h + +parseLog :: L.ByteString -> [Either String Log] +parseLog = map eitherDecode' + . filter (not . L.null) + . L.split (fromIntegral (ord '\n')) + +-- | Streams a log without loading it all into memory. +-- When lines cannot be parsed, they will be Left. +streamLog :: FilePath -> IO [Either String Log] +streamLog f = parseLog <$> L.readFile f diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,84 @@ +# The install target will add this before all paths it writes to. +PREFIX?= + +# Can be "stack" or "cabal", or "./Setup" to build and use Setup.hs +BUILDER?=stack + +# Options to pass to the BUILDER. +# Using -j1 may result in a reproducible build. +BUILDEROPTIONS?= + +# Propigate flags through ghc to linker and compiler. +ghc_options=$(shell \ + for w in $(LDFLAGS); do \ + printf -- "-optl%s\n" "$$w"; \ + done; \ + for w in $(CFLAGS); do \ + printf -- "-optc%s\n" "$$w"; \ + done; \ + for w in $(CPPFLAGS); do \ + printf -- "-optc-Wp,%s\n" "$$w"; \ + done; \ + ) + +build: + rm -f debug-me + $(MAKE) debug-me + +debug-me: + if [ "$(BUILDER)" = ./Setup ]; then ghc --make Setup; fi + if [ "$(BUILDER)" = stack ]; then \ + $(BUILDER) build --ghc-options="$(ghc_options)" $(BUILDEROPTIONS); \ + else \ + $(BUILDER) configure --ghc-options="$(ghc_options)"; \ + $(BUILDER) build $(BUILDEROPTIONS); \ + fi + if [ "$(BUILDER)" = stack ]; then \ + ln -sf $$(find .stack-work/ -name debug-me -type f | grep build/debug-me/debug-me | tail -n 1) debug-me; \ + else \ + ln -sf dist/build/debug-me/debug-me debug-me; \ + fi + +clean: + if [ "$(BUILDER)" != ./Setup ] && [ "$(BUILDER)" != cabal ]; then $(BUILDER) clean; fi + rm -rf dist .stack-work tmp + rm -f debig-me Build/LinuxMkLibs Setup + find . -name \*.o -exec rm {} \; + find . -name \*.hi -exec rm {} \; + +install: install-files + useradd --system debug-me + chmod 700 $(DESTDIR)$(PREFIX)/var/log/debug-me + chown debug-me:debug-me $(DESTDIR)$(PREFIX)/var/log/debug-me + +install-files: debug-me install-mans + install -d $(DESTDIR)$(PREFIX)/var/log/debug-me + install -d $(DESTDIR)$(PREFIX)/usr/bin + install -s -m 0755 debug-me $(DESTDIR)$(PREFIX)/usr/bin/debug-me + install -d $(DESTDIR)$(PREFIX)/lib/systemd/system + install -m 0644 debug-me.service $(DESTDIR)$(PREFIX)/lib/systemd/system/debug-me.service + install -d $(DESTDIR)$(PREFIX)/etc/init.d + install -m 0755 debug-me.init $(DESTDIR)$(PREFIX)/etc/init.d/debug-me + install -d $(DESTDIR)$(PREFIX)/etc/default + install -m 0644 debug-me.default $(DESTDIR)$(PREFIX)/etc/default/debug-me + +install-mans: + install -d $(DESTDIR)$(PREFIX)/usr/share/man/man1 + install -m 0644 debug-me.1 $(DESTDIR)$(PREFIX)/usr/share/man/man1/debug-me.1 + +Build/LinuxMkLibs: Build/LinuxMkLibs.hs + ghc --make $@ -Wall -fno-warn-tabs + +LINUXSTANDALONE_DEST=tmp/debug-me +linuxstandalone: debug-me Build/LinuxMkLibs + rm -rf "$(LINUXSTANDALONE_DEST)" + mkdir -p tmp + cp -R standalone/linux/skel "$(LINUXSTANDALONE_DEST)" + install -d "$(LINUXSTANDALONE_DEST)/bin" + cp debug-me "$(LINUXSTANDALONE_DEST)/bin/" + strip "$(LINUXSTANDALONE_DEST)/bin/debug-me" + ./Build/LinuxMkLibs "$(LINUXSTANDALONE_DEST)" + $(MAKE) install-mans DESTDIR="$(LINUXSTANDALONE_DEST)" + cd tmp && tar c debug-me | gzip -9 --rsyncable > debug-me-standalone-$(shell dpkg --print-architecture).tar.gz + +.PHONY: debug-me diff --git a/Memory.hs b/Memory.hs new file mode 100644 --- /dev/null +++ b/Memory.hs @@ -0,0 +1,14 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Memory where + +-- | Class of things whose size in memory is known. +-- +-- (This can be an approximate size, but should be no larger than the +-- memory used to reprecent the thing.) +class DataSize t where + -- ^ Size in bytes + dataSize :: t -> Integer diff --git a/Output.hs b/Output.hs new file mode 100644 --- /dev/null +++ b/Output.hs @@ -0,0 +1,15 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Output where + +import Data.Char + +sanitizeForDisplay :: String -> String +sanitizeForDisplay = map go + where + go c + | isPrint c = c + | otherwise = '?' diff --git a/PrevActivity.hs b/PrevActivity.hs new file mode 100644 --- /dev/null +++ b/PrevActivity.hs @@ -0,0 +1,58 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module PrevActivity where + +import Types +import Crypto + +import Control.Concurrent.STM + +-- | Remove the hashes from a message. Doing this before sending +-- it over the wire saves transmitting that data, without weakening +-- security at all. +removeHashes :: AnyMessage -> MissingHashes AnyMessage +removeHashes msg = MissingHashes $ case msg of + User (ActivityMessage a) -> User (go a) + Developer (ActivityMessage a) -> Developer (go a) + _ -> msg + where + go a = ActivityMessage $ a + { prevActivity = Nothing + , prevEntered = Nothing + } + +type RecentActivity = STM (SigVerifier, [Hash]) + +-- | Restore the hashes to a message received. +-- This needs a RecentActivity cache, and it tries hashes from that cache +-- to find the one that was used when the message was sent, at which +-- point the message's signature will verify. +restoreHashes :: RecentActivity -> MissingHashes AnyMessage -> STM AnyMessage +restoreHashes ra (MissingHashes msg) = case msg of + User (ActivityMessage act) -> + User . ActivityMessage <$> find act + Developer (ActivityMessage act) -> + Developer . ActivityMessage <$> find act + User (ControlMessage {}) -> return msg + Developer (ControlMessage {}) -> return msg + + where + find act = do + (sigverifier, l) <- ra + let l' = Nothing : map Just l + let ll = do + ah <- l' + eh <- l' + return $ act + { prevActivity = ah + , prevEntered = eh + } + go act sigverifier ll + go act _ [] = return act + go act sigverifier (l:ls) = do + if verifySigned sigverifier l + then return l + else go act sigverifier ls diff --git a/ProtocolBuffers.hs b/ProtocolBuffers.hs new file mode 100644 --- /dev/null +++ b/ProtocolBuffers.hs @@ -0,0 +1,326 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveGeneric, DataKinds, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | Protocol buffers serialization for the debug-me wire protocol. + - + - The message types in here define protocol buffers, so should be changed + - with care. These messages correspond to the main data types in the Types + - module. + - + - Note that the type level numbers used with fields should never be + - changed. + -} + +module ProtocolBuffers where + +import qualified Types as T +import Val + +import Data.ProtocolBuffers +import GHC.Generics (Generic) +import qualified Data.ByteString as B +import Data.Monoid +import Prelude + +data SeenP = SeenP + { seenDataP :: Required 1 (Value B.ByteString) + } + deriving (Generic) + +data EnteredP = EnteredP + { enteredDataP :: Required 2 (Value B.ByteString) + , echoDataP :: Required 3 (Value B.ByteString) + } + deriving (Generic) + +data MessageP a + = ActivityMessageP + { activityMessageP :: Required 4 (Message (ActivityP a)) } + | ControlMessageP + { controlMessageP :: Required 5 (Message ControlP) } + deriving (Generic) + +data ActivityP a = ActivityP + { activityP :: Required 6 (Message a) + , elapsedTimeP :: Required 7 (Message ElapsedTimeP) + , activitySignatureP :: Required 8 (Message SignatureP) + } + deriving (Generic) + +data ControlP = ControlP + { controlP :: Required 9 (Message ControlActionP) + , controlSignatureP ::Required 10 (Message SignatureP) + } + deriving (Generic) + +data ControlActionP + = EnteredRejectedP + { enteredRejectedP :: Required 11 (Message HashP) + , enteredLastAcceptedP :: Optional 12 (Message HashP) + } + | SessionKeyP + { sessionKeyP :: Required 13 (Message (PerhapsSignedP PublicKeyP)) + , protocolVersionP :: Required 14 (Value B.ByteString) + } + | SessionKeyAcceptedP + { sessionKeyAcceptedP :: Required 15 (Message PublicKeyP) } + | SessionKeyRejectedP + { sessionKeyRejectedP :: Required 16 (Message PublicKeyP) } + | ChatMessageP + { chatMessageSenderName :: Required 17 (Value B.ByteString) + , chatMessage :: Required 18 (Value B.ByteString) + } + deriving (Generic) + +data SignatureP + = Ed25519SignatureP + { ed25519SignatureP :: Required 19 (Value B.ByteString) } + | OtherSignatureP + { otherSignatureP :: Required 20 (Value B.ByteString) } + deriving (Generic) + +data PublicKeyP = PublicKeyP + { mkPublicKeyP :: Required 21 (Value B.ByteString) } + deriving (Generic) + +data PerhapsSignedP a + = GpgSignedP + { gpgSignedValP :: Required 22 (Message a) + , gpgSigP :: Required 23 (Message GpgSigP) + , gpgKeyExportP :: Required 24 (Message GpgKeyExportP) + } + | UnSignedP + { mkUnSignedP :: Required 25 (Message a ) + } + deriving (Generic) + +data GpgSigP = GpgSigP + { mkGpgSigP :: Required 26 (Value B.ByteString) } + deriving (Generic) + +data GpgKeyExportP = GpgKeyExportP + { mkGpgKeyExportP :: Required 27 (Value B.ByteString) } + deriving (Generic) + +data ElapsedTimeP = ElapsedTimeP + { mkElapsedTimeP :: Required 28 (Value Double) } + deriving (Generic) + +data AnyMessageP + = UserP { mkUserP :: Required 29 (Message (MessageP SeenP)) } + | DeveloperP { mkDeveloperP :: Required 30 (Message (MessageP EnteredP)) } + deriving (Generic) + +data HashP = HashP + { hashMethodP :: Required 31 (Message HashMethodP) + , hashValueP :: Required 32 (Value B.ByteString) + } + deriving (Generic) + +data HashMethodP + = SHA512P { mkSHA512P :: Required 33 (Value Bool) } + | SHA3P { mkSHA3P :: Required 34 (Value Bool) } + deriving (Generic) + +-- | Conversion between protocol buffer messages and debug-me's main Types. +class ProtocolBuffer p t where + toProtocolBuffer :: t -> p + fromProtocolBuffer :: p -> t + +instance ProtocolBuffer SeenP T.Seen where + toProtocolBuffer t = SeenP + { seenDataP = putField $ val $ T.seenData t + } + fromProtocolBuffer p =T.Seen + { T.seenData = Val $ getField $ seenDataP p + } + +instance ProtocolBuffer EnteredP T.Entered where + toProtocolBuffer t = EnteredP + { enteredDataP = putField $ val $ T.enteredData t + , echoDataP = putField $ val $ T.echoData t + } + fromProtocolBuffer p =T.Entered + { T.enteredData = Val $ getField $ enteredDataP p + , T.echoData = Val $ getField $ echoDataP p + } + +instance ProtocolBuffer (ActivityP p) (T.Activity t) => ProtocolBuffer (MessageP p) (T.Message t) where + toProtocolBuffer (T.ActivityMessage a) = + ActivityMessageP (putField (toProtocolBuffer a)) + toProtocolBuffer (T.ControlMessage c) = + ControlMessageP (putField (toProtocolBuffer c)) + fromProtocolBuffer p@(ActivityMessageP {}) = + T.ActivityMessage $ fromProtocolBuffer $ + getField $ activityMessageP p + fromProtocolBuffer p@(ControlMessageP {}) = + T.ControlMessage $ fromProtocolBuffer $ + getField $ controlMessageP p + +instance ProtocolBuffer p t => ProtocolBuffer (ActivityP p) (T.Activity t) where + toProtocolBuffer t = ActivityP + { activityP = putField $ toProtocolBuffer $ T.activity t + , elapsedTimeP = putField $ toProtocolBuffer $ T.elapsedTime t + , activitySignatureP = putField $ toProtocolBuffer $ T.activitySignature t + } + fromProtocolBuffer p = T.Activity + { T.activity = fromProtocolBuffer $ getField $ activityP p + , T.prevActivity = Nothing -- not sent over the wire + , T.prevEntered = Nothing -- not sent over the wire + , T.elapsedTime = fromProtocolBuffer $ getField $ elapsedTimeP p + , T.activitySignature = fromProtocolBuffer $ getField $ activitySignatureP p + } + +instance ProtocolBuffer ControlP T.Control where + toProtocolBuffer t = ControlP + { controlP = putField $ toProtocolBuffer $ T.control t + , controlSignatureP = putField $ toProtocolBuffer $ T.controlSignature t + } + fromProtocolBuffer p = T.Control + { T.control = fromProtocolBuffer $ getField $ controlP p + , T.controlSignature = fromProtocolBuffer $ getField $ controlSignatureP p + } + +instance ProtocolBuffer ControlActionP T.ControlAction where + toProtocolBuffer t@(T.EnteredRejected {}) = EnteredRejectedP + { enteredRejectedP = putField $ toProtocolBuffer $ T.enteredRejected t + , enteredLastAcceptedP = putField $ toProtocolBuffer <$> T.enteredLastAccepted t + } + toProtocolBuffer (T.SessionKey t v) = SessionKeyP + { sessionKeyP = putField $ toProtocolBuffer t + , protocolVersionP = putField $ val v + } + toProtocolBuffer (T.SessionKeyAccepted t) = SessionKeyAcceptedP + { sessionKeyAcceptedP = putField $ toProtocolBuffer t } + toProtocolBuffer (T.SessionKeyRejected t) = SessionKeyRejectedP + { sessionKeyRejectedP = putField $ toProtocolBuffer t } + toProtocolBuffer (T.ChatMessage sendername t) = ChatMessageP + { chatMessageSenderName = putField (val sendername) + , chatMessage = putField (val t) + } + fromProtocolBuffer p@(EnteredRejectedP {}) = T.EnteredRejected + { T.enteredRejected = fromProtocolBuffer $ getField $ enteredRejectedP p + , T.enteredLastAccepted = fromProtocolBuffer <$> getField (enteredLastAcceptedP p) + } + fromProtocolBuffer p@(SessionKeyP {}) = T.SessionKey + (fromProtocolBuffer $ getField $ sessionKeyP p) + (Val $ getField $ protocolVersionP p) + fromProtocolBuffer p@(SessionKeyAcceptedP {}) = T.SessionKeyAccepted $ + fromProtocolBuffer $ getField $ sessionKeyAcceptedP p + fromProtocolBuffer p@(SessionKeyRejectedP {}) = T.SessionKeyRejected $ + fromProtocolBuffer $ getField $ sessionKeyRejectedP p + fromProtocolBuffer p@(ChatMessageP {}) = T.ChatMessage + (Val $ getField $ chatMessageSenderName p) + (Val $ getField $ chatMessage p) + +instance ProtocolBuffer SignatureP T.Signature where + toProtocolBuffer (T.Ed25519Signature t) = Ed25519SignatureP + { ed25519SignatureP = putField $ val t } + toProtocolBuffer (T.OtherSignature t) = OtherSignatureP + { otherSignatureP = putField $ val t } + fromProtocolBuffer p@(Ed25519SignatureP {}) = T.Ed25519Signature $ + Val $ getField $ ed25519SignatureP p + fromProtocolBuffer p@(OtherSignatureP {}) = T.OtherSignature $ + Val $ getField $ otherSignatureP p + +instance ProtocolBuffer HashP T.Hash where + toProtocolBuffer t = HashP + { hashMethodP = putField $ toProtocolBuffer $ T.hashMethod t + , hashValueP = putField $ val $ T.hashValue t + } + fromProtocolBuffer p = T.Hash + { T.hashMethod = fromProtocolBuffer $ getField $ hashMethodP p + , T.hashValue = Val $ getField $ hashValueP p + } + +instance ProtocolBuffer HashMethodP T.HashMethod where + toProtocolBuffer T.SHA512 = SHA512P { mkSHA512P = putField True } + toProtocolBuffer T.SHA3 = SHA3P { mkSHA3P = putField True } + fromProtocolBuffer (SHA512P {}) = T.SHA512 + fromProtocolBuffer (SHA3P {}) = T.SHA3 + +instance ProtocolBuffer PublicKeyP T.PublicKey where + toProtocolBuffer (T.PublicKey t) = PublicKeyP + { mkPublicKeyP = putField (val t) } + fromProtocolBuffer p = T.PublicKey $ Val $ getField $ mkPublicKeyP p + +instance ProtocolBuffer p t => ProtocolBuffer (PerhapsSignedP p) (T.PerhapsSigned t) where + toProtocolBuffer (T.GpgSigned tv tg tk) = GpgSignedP + { gpgSignedValP = putField $ toProtocolBuffer tv + , gpgSigP = putField $ toProtocolBuffer tg + , gpgKeyExportP = putField $ toProtocolBuffer tk + } + toProtocolBuffer (T.UnSigned tv) = UnSignedP + { mkUnSignedP = putField $ toProtocolBuffer tv + } + fromProtocolBuffer p@(GpgSignedP {}) = T.GpgSigned + (fromProtocolBuffer $ getField $ gpgSignedValP p) + (fromProtocolBuffer $ getField $ gpgSigP p) + (fromProtocolBuffer $ getField $ gpgKeyExportP p) + fromProtocolBuffer p@(UnSignedP {}) = T.UnSigned + (fromProtocolBuffer $ getField $ mkUnSignedP p) + +instance ProtocolBuffer GpgSigP T.GpgSig where + toProtocolBuffer (T.GpgSig t) = GpgSigP + { mkGpgSigP = putField ( val t) } + fromProtocolBuffer p = T.GpgSig $ Val $ getField $ mkGpgSigP p + +instance ProtocolBuffer GpgKeyExportP T.GpgKeyExport where + toProtocolBuffer (T.GpgKeyExport t) = GpgKeyExportP + { mkGpgKeyExportP = putField ( val t) } + fromProtocolBuffer p = T.GpgKeyExport $ Val $ getField $ mkGpgKeyExportP p + +instance ProtocolBuffer ElapsedTimeP T.ElapsedTime where + toProtocolBuffer (T.ElapsedTime t) = ElapsedTimeP + { mkElapsedTimeP = putField t } + fromProtocolBuffer p = T.ElapsedTime $ getField $ mkElapsedTimeP p + +instance ProtocolBuffer AnyMessageP T.AnyMessage where + toProtocolBuffer (T.User t) = UserP + { mkUserP = putField $ toProtocolBuffer t } + toProtocolBuffer (T.Developer t) = DeveloperP + { mkDeveloperP = putField $ toProtocolBuffer t } + fromProtocolBuffer p@(UserP {}) = T.User $ + fromProtocolBuffer $ getField $ mkUserP p + fromProtocolBuffer p@(DeveloperP {}) = T.Developer $ + fromProtocolBuffer $ getField $ mkDeveloperP p + +instance Encode SeenP +instance Decode SeenP +instance Encode EnteredP +instance Decode EnteredP +instance Encode ControlP +instance Decode ControlP +instance Encode ControlActionP +instance Decode ControlActionP +instance Encode HashP +instance Decode HashP +instance Encode HashMethodP +instance Decode HashMethodP +instance Encode SignatureP +instance Decode SignatureP +instance Encode PublicKeyP +instance Decode PublicKeyP +instance Encode GpgSigP +instance Decode GpgSigP +instance Encode GpgKeyExportP +instance Decode GpgKeyExportP +instance Encode ElapsedTimeP +instance Decode ElapsedTimeP +instance Encode AnyMessageP +instance Decode AnyMessageP +instance Encode a => Encode (MessageP a) +-- This is why UndecidableInstances is needed. The need +-- for a Monoid instance is an implementation detail of +-- Data.ProtocolBuffers. +instance (Monoid (Message a), Generic a, Decode a) => Decode (MessageP a) +instance Encode a => Encode (ActivityP a) +instance (Monoid (Message a), Generic a, Decode a) => Decode (ActivityP a) +instance Encode a => Encode (PerhapsSignedP a) +instance (Monoid (Message a), Generic a, Decode a) => Decode (PerhapsSignedP a) diff --git a/Pty.hs b/Pty.hs new file mode 100644 --- /dev/null +++ b/Pty.hs @@ -0,0 +1,93 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Pty ( + Pty, + runWithPty, + readPty, + writePty, + inRawMode, + withoutEcho, + withTerminalAttributes, +) where + +import System.Posix +import System.Posix.Pty +import qualified System.Console.Terminal.Size as Console +import System.Posix.Signals.Exts +import System.Process +import Control.Exception + +-- | Run a program on a Pty. +-- +-- While doing so, the outer pty has echo disabled (so the child can echo), +-- and has raw mode enabled (so the child pty can see all special characters). +-- +-- A SIGWINCH handler is installed, to forward resizes to the Pty. +runWithPty :: String -> [String] -> ((Pty, ProcessHandle) -> IO a) -> IO a +runWithPty cmd params a = bracket setup cleanup go + where + setup = do + as <- System.Posix.getTerminalAttributes stdInput + sz <- Console.size + (p, ph) <- spawnWithPty Nothing True cmd params + (maybe 80 Console.width sz, maybe 25 Console.height sz) + _ <- installHandler windowChange (Catch (forwardresize p)) Nothing + -- Set the pty's terminal attributes to the same ones that + -- the outer terminal had. + System.Posix.Pty.setTerminalAttributes p as Immediately + System.Posix.setTerminalAttributes stdInput (setRawMode as) Immediately + return (p, ph, as) + cleanup (p, ph, as) = do + -- Needed in case the provided action throws an exception + -- before it waits for the process. + terminateProcess ph + closePty p + _ <- installHandler windowChange Default Nothing + System.Posix.setTerminalAttributes stdInput as Immediately + go (p, ph, _) = a (p, ph) + forwardresize p = do + msz <- Console.size + case msz of + Nothing -> return () + Just sz -> resizePty p (Console.width sz, Console.height sz) + +withTerminalAttributes :: (TerminalAttributes -> TerminalAttributes) -> IO a -> IO a +withTerminalAttributes f a = bracket setup cleanup go + where + setup = do + as <- System.Posix.getTerminalAttributes stdInput + System.Posix.setTerminalAttributes stdInput (f as) Immediately + return as + cleanup as = System.Posix.setTerminalAttributes stdInput as Immediately + go _ = a + +-- | This is similar to cfmakeraw(3). +inRawMode :: IO a -> IO a +inRawMode = withTerminalAttributes setRawMode + +setRawMode :: TerminalAttributes -> TerminalAttributes +setRawMode as = as + `withoutMode` IgnoreBreak + `withoutMode` InterruptOnBreak + `withoutMode` CheckParity + `withoutMode` StripHighBit + `withoutMode` MapLFtoCR + `withoutMode` IgnoreCR + `withoutMode` MapCRtoLF + `withoutMode` StartStopOutput + `withoutMode` ProcessOutput + `withoutMode` EnableEcho + `withoutMode` EchoLF + `withoutMode` ProcessInput + `withoutMode` KeyboardInterrupts + `withoutMode` ExtendedFunctions + `withoutMode` EnableParity + +-- | Disable terminal echo. +withoutEcho :: IO a -> IO a +withoutEcho = withTerminalAttributes $ \as -> as + `withoutMode` EnableEcho + diff --git a/Replay.hs b/Replay.hs new file mode 100644 --- /dev/null +++ b/Replay.hs @@ -0,0 +1,46 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Replay where + +import Types +import Log +import CmdLine +import Pty + +import qualified Data.ByteString as B +import System.IO +import Control.Concurrent.Async +import Control.Concurrent.Thread.Delay + +replay :: ReplayOpts -> IO () +replay opts = do + hSetBuffering stdin NoBuffering + withoutEcho $ go =<< streamLog (replayLogFile opts) + where + go [] = return () + go (Right l:ls) = do + case loggedMessage l of + User (ActivityMessage a) -> do + _ <- realisticDelay (elapsedTime a) + `race` waitSpaceBar + B.hPut stdout $ val $ seenData $ activity a + hFlush stdout + User (ControlMessage _) -> return () + Developer _ -> return () + go ls + go (Left l:_) = error $ "Failed to parse a line of the log: " ++ l + +realisticDelay :: ElapsedTime -> IO () +realisticDelay (ElapsedTime n) + | n < 1 = return () + | otherwise = delay $ ceiling $ n * 1000000 + +waitSpaceBar :: IO () +waitSpaceBar = do + c <- getChar + if c == ' ' + then return () + else waitSpaceBar diff --git a/Role/Developer.hs b/Role/Developer.hs new file mode 100644 --- /dev/null +++ b/Role/Developer.hs @@ -0,0 +1,457 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Role.Developer ( + run, + run', + watchSessionReadOnly, + processSessionStart, + getServerMessage, + Output(..), + emitOutput, + DeveloperState, +) where + +import Types +import Hash +import Log +import Crypto +import Gpg +import CmdLine +import WebSockets +import SessionID +import Pty +import PrevActivity +import ControlSocket +import ControlWindow + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import System.IO +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.List +import Data.Maybe +import Control.Monad +import Data.Monoid +import Data.Time.Clock.POSIX +import Network.URI + +run :: DeveloperOpts -> IO () +run = run' developer . debugUrl + +run' :: (TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO ()) -> URI -> IO () +run' runner url = do + app <- do + let connect = ConnectMode $ T.pack $ show url + dsv <- newEmptyTMVarIO + return $ clientApp connect Developer Just $ runner dsv + void $ runClientApp url app + +developer :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () +developer dsv ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> do + sk <- genMySessionKey + spk <- myPublicKey sk (GpgSign True) + (controlinput, controloutput) <- openControlWindow + displayInControlWindow controlinput + "Connecting to the user's session ..." + inRawMode $ do + (devstate, startoutput) <- processSessionStart sk ochan logger dsv + displayInControlWindow controlinput + "Connected. You can now see what the user is doing." + displayInControlWindow controlinput + "(But, you can't type anything yet.)" + emitOutput startoutput + displayInControlWindow controlinput + "Waiting for the user to check your GnuPG key and grant write access ..." + authUser spk ichan ochan devstate logger + >>= go controlinput controloutput logger devstate + where + go controlinput controloutput logger devstate Authed = void $ do + displayInControlWindow controlinput + "Write access granted. You can now type into the user's shell." + displayInControlWindow controlinput + "(And, you can type in this window to chat with the user.)" + sendTtyInput ichan devstate logger + `race` sendTtyOutput ochan devstate controlinput logger + `race` sendControlOutput controloutput ichan devstate logger + go controlinput _controloutput logger devstate AuthFailed = do + displayInControlWindow controlinput + "User did not grant write access to their terminal. Watching session in read-only mode." + watchSessionReadOnly ochan logger devstate + go _ _ _ _ SessionEnded = + hPutStrLn stderr "\r\n** This debug-me session has already ended.\r" + +watchSessionReadOnly :: TMChan (MissingHashes AnyMessage) -> Logger -> TVar DeveloperState -> IO () +watchSessionReadOnly ochan logger st = loop + where + loop = do + ts <- getPOSIXTime + v <- atomically $ getServerMessage ochan st ts + case v of + Nothing -> return () + Just (o, msg) -> do + _ <- logger msg + emitOutput o + loop + +data DeveloperState = DeveloperState + { lastSeen :: Hash + -- ^ Last Seen value received from the user. + , sentSince :: [B.ByteString] + -- ^ Keys pressed since last Seen. + , enteredSince :: [Hash] + -- ^ Messages we've sent since the last Seen. + , lastActivity :: Hash + -- ^ Last Entered or Seen activity + , lastActivityTs :: POSIXTime + , lastEntered :: Maybe Hash + -- ^ Last Entered activity (either from us or another developer). + , fromOtherDevelopersSince :: [Hash] + -- ^ Messages received from other developers since the last Seen. + -- (The next Seen may chain from one of these.) + , developerSessionKey :: MySessionKey + -- ^ Our session key. + , userSigVerifier :: SigVerifier + -- ^ Used to verify signatures on messages from the user. + , developerSigVerifier :: SigVerifier + -- ^ Used to verify signatures on messages from other developers. + } + deriving (Show) + +-- | RecentActivity that uses the DeveloperState. +developerStateRecentActivity :: TVar DeveloperState -> RecentActivity +developerStateRecentActivity devstate = do + st <- readTVar devstate + let hs = lastSeen st : fromMaybe (lastSeen st) (lastEntered st) + : enteredSince st ++ fromOtherDevelopersSince st + return (userSigVerifier st <> developerSigVerifier st, hs) + +-- | Read things typed by the developer, and forward them to the TMChan. +sendTtyInput :: TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () +sendTtyInput ichan devstate logger = go + where + go = do + b <- B.hGetSome stdin 1024 + if b == B.empty + then return () + else send b + send b = do + ts <- getPOSIXTime + act <- atomically $ do + ds <- readTVar devstate + let ed = if lastActivity ds == lastSeen ds + then B.concat $ sentSince ds + else case reverse (sentSince ds) of + [] -> mempty + (lb:_) -> lb + let entered = Entered + { enteredData = Val b + , echoData = Val ed + } + let act = mkSigned (developerSessionKey ds) $ + Activity entered + (Just $ lastActivity ds) + (lastEntered ds) + (mkElapsedTime (lastActivityTs ds) ts) + writeTMChan ichan (ActivityMessage act) + let acth = hash act + let ds' = ds + { sentSince = sentSince ds ++ [b] + , enteredSince = enteredSince ds ++ [acth] + , lastActivity = acth + , lastActivityTs = ts + , lastEntered = Just acth + } + writeTVar devstate ds' + return act + logger $ Developer $ ActivityMessage act + go + +sendControlOutput :: TMChan ControlOutput -> TMChan (Message Entered) -> TVar DeveloperState -> Logger -> IO () +sendControlOutput controloutput ichan devstate logger = loop + where + loop = go =<< atomically (readTMChan controloutput) + go Nothing = return () + go (Just ControlWindowOpened) = loop + go (Just (ControlOutputAction c)) = do + msg <- atomically $ do + ds <- readTVar devstate + let msg = ControlMessage $ + mkSigned (developerSessionKey ds) (Control c) + writeTMChan ichan msg + return msg + logger (Developer msg) + loop + go (Just ControlWindowRequestedImmediateQuit) = return () + +-- | Read activity from the TMChan and display it to the developer. +-- +-- Control messages are forwarded on to the ControlInput. +sendTtyOutput :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> TMChan ControlInput -> Logger -> IO () +sendTtyOutput ochan devstate controlinput logger = go + where + go = do + ts <- getPOSIXTime + v <- atomically $ getServerMessage ochan devstate ts + case v of + Nothing -> return () + Just (o, msg) -> do + logger msg + emitOutput o + forwardcontrol msg + go + forwardcontrol msg = case msg of + User (ControlMessage c) -> fwd c + Developer (ControlMessage c) -> case control c of + EnteredRejected {} -> return () + SessionKey {} -> return () + SessionKeyAccepted {} -> return () + SessionKeyRejected {} -> return () + ChatMessage {} -> fwd c + _ -> return () + fwd = atomically . writeTMChan controlinput . ControlInputAction . control + +data AuthResult = Authed | AuthFailed | SessionEnded + +-- | Present our session key to the user. +-- Wait for them to accept or reject it, while displaying any Seen data +-- in the meantime. +authUser :: PerhapsSigned PublicKey -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> Logger -> IO AuthResult +authUser spk ichan ochan devstate logger = do + ds <- atomically $ readTVar devstate + let msg = ControlMessage $ mkSigned (developerSessionKey ds) + (Control (SessionKey spk currentProtocolVersion)) + atomically $ writeTMChan ichan msg + logger $ Developer msg + waitresp $ case spk of + -- Don't bother verifying the user's gpg public key; + -- normally users send UnSigned. + GpgSigned pk _ _ -> pk + UnSigned pk -> pk + where + waitresp pk = do + ts <- getPOSIXTime + v <- atomically (getServerMessage ochan devstate ts) + case v of + Nothing -> return SessionEnded + Just (o, msg) -> do + logger msg + emitOutput o + case o of + GotControl (SessionKeyAccepted pk') + | pk' == pk -> return Authed + GotControl (SessionKeyRejected pk') + | pk' == pk -> return AuthFailed + _ -> waitresp pk + +data Output + = TtyOutput B.ByteString + | Beep + | ProtocolError DeveloperState String + | GotControl ControlAction + | NoOutput + +emitOutput :: Output -> IO () +emitOutput (ProtocolError ds e) = + error ("Protocol error: " ++ e ++ "\nState: " ++ show ds) +emitOutput (TtyOutput b) = do + B.hPut stdout b + hFlush stdout +emitOutput Beep = do + B.hPut stdout "\a" + hFlush stdout +emitOutput (GotControl _) = + return () +emitOutput NoOutput = + return () + +-- | Get messages from server, check their signature, and make sure that they +-- are properly chained from past messages, before returning. +getServerMessage :: TMChan (MissingHashes AnyMessage) -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) +getServerMessage ochan devstate ts = do + mwiremsg <- readTMChan ochan + case mwiremsg of + Nothing -> return Nothing + Just msg -> process =<< restoreHashes recentactivity msg + where + recentactivity = developerStateRecentActivity devstate + + process (User msg) = do + ds <- readTVar devstate + -- Check user's signature before doing anything else. + if verifySigned (userSigVerifier ds) msg + then do + o <- processuser ds msg + return (Just (o, User msg)) + else return $ Just (ProtocolError ds $ "Bad signature on message from user: " ++ show msg, User msg) + -- When other developers connect, learn their SessionKeys. + process (Developer msg@(ControlMessage (Control (SessionKey spk _) _))) = do + let sigverifier = mkSigVerifier $ case spk of + GpgSigned pk _ _ -> pk + UnSigned pk -> pk + if verifySigned sigverifier msg + then do + ds <- readTVar devstate + let sv = developerSigVerifier ds + let sv' = sv `mappend` sigverifier + writeTVar devstate $ ds + { developerSigVerifier = sv' + } + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + process (Developer msg) = do + ds <- readTVar devstate + if verifySigned (developerSigVerifier ds) msg + then do + processdeveloper ds msg + return (Just (NoOutput, Developer msg)) + else ignore + + ignore = getServerMessage ochan devstate ts + + processuser ds (ActivityMessage act@(Activity (Seen (Val b)) _ _ _ _)) = do + let (legal, ds') = isLegalSeen act ds ts + if legal + then do + writeTVar devstate ds' + return (TtyOutput b) + else return (ProtocolError ds $ "Illegal Seen value: " ++ show act) + processuser ds (ControlMessage (Control (er@EnteredRejected {}) _)) = do + -- When they rejected a message we sent, + -- anything we sent subsequently will + -- also be rejected, so forget about it. + let ds' = ds + { sentSince = mempty + , enteredSince = mempty + , lastEntered = enteredLastAccepted er + } + writeTVar devstate ds' + return Beep + processuser _ (ControlMessage (Control c@(SessionKey _ _) _)) = + return (GotControl c) + processuser _ (ControlMessage (Control c@(SessionKeyAccepted _) _)) = + return (GotControl c) + processuser _ (ControlMessage (Control c@(SessionKeyRejected _) _)) = + return (GotControl c) + processuser _ (ControlMessage (Control c@(ChatMessage _ _) _)) = + return (GotControl c) + + processdeveloper ds (ActivityMessage a) = do + let msghash = hash a + let ss = msghash : fromOtherDevelopersSince ds + writeTVar devstate (ds { fromOtherDevelopersSince = ss }) + processdeveloper _ (ControlMessage _) = return () + +-- | Check if the Seen activity is legal, forming a chain with previous +-- ones, and returns an updated DeveloperState. +-- +-- Does not check the signature. +isLegalSeen :: Activity Seen -> DeveloperState -> POSIXTime -> (Bool, DeveloperState) +isLegalSeen (Activity _ Nothing _ _ _) ds _ = (False, ds) +isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _ _) ds ts + -- Does it chain to the last Seen activity or to + -- something sent by another developer since the last Seen? + | hp == lastSeen ds || hp `elem` fromOtherDevelopersSince ds = + -- Trim sentSince and enteredSince to + -- values after the Seen value. + let ss = sentSince ds + es = enteredSince ds + n = B.length b + (ss', es') = if b `B.isPrefixOf` mconcat ss + then (drop n ss, drop n es) + else (mempty, mempty) + in yes ds + { lastSeen = acth + , sentSince = ss' + , enteredSince = es' + , lastActivity = acth + , lastActivityTs = ts + , lastEntered = newlastentered + , fromOtherDevelopersSince = mempty + } + -- Does it chain to something we've entered since the last Seen + -- value? Eg, user sent A, we replied B C, and the user has + -- now replied to B. + -- If so, we can drop B (and anything before it) from + -- enteredSince and sentSince. + | otherwise = case elemIndex hp (enteredSince ds) of + Nothing -> (False, ds) + Just i -> + let ss = sentSince ds + es = enteredSince ds + ss' = drop (i+1) ss + es' = drop (i+1) es + in yes ds + { lastSeen = acth + , sentSince = ss' + , enteredSince = es' + , lastActivity = acth + , lastActivityTs = ts + , lastEntered = newlastentered + , fromOtherDevelopersSince = mempty + } + where + acth = hash act + yes ds' = (True, ds') + + -- If there are multiple developers, need to set our lastEntered + -- to the prevEntered from the Activity Seen, so we can follow on to + -- another developer's activity. + -- + -- But, if there's lag, we may have sent some Activity Entered + -- that had not reached the user yet when it constructed the + -- Activity Seen, so check if the prevEntered is one of the + -- things we've enteredSince; if so keep our lastEntered. + newlastentered = case prevEntered act of + Just v | v `notElem` enteredSince ds -> Just v + _ -> lastEntered ds + +-- | Start by reading the initial two messages from the user, +-- their session key and the startup message. +processSessionStart :: MySessionKey -> TMChan (MissingHashes AnyMessage) -> Logger -> TMVar (TVar DeveloperState) -> IO (TVar DeveloperState, Output) +processSessionStart sk ochan logger dsv = do + MissingHashes sessionmsg <- fromMaybe (error "Did not get session initialization message") + <$> atomically (readTMChan ochan) + logger sessionmsg + sigverifier <- case sessionmsg of + User (ControlMessage c@(Control (SessionKey spk _) _)) -> do + let pk = case spk of + GpgSigned k _ _ -> k + UnSigned k -> k + let sv = mkSigVerifier pk + if verifySigned sv c + then return sv + else error "Badly signed session initialization message" + _ -> error $ "Unexpected session initialization message: " ++ show sessionmsg + ts <- getPOSIXTime + MissingHashes startmsg <- fromMaybe (error "Did not get session startup message") + <$> atomically (readTMChan ochan) + logger startmsg + let (starthash, output) = case startmsg of + User (ActivityMessage act@(Activity (Seen (Val b)) Nothing Nothing _ _)) + | verifySigned sigverifier act -> + (hash act, TtyOutput b) + | otherwise -> + error "Bad signature on startup message" + _ -> error $ "Unexpected startup message: " ++ show startmsg + st <- newTVarIO $ DeveloperState + { lastSeen = starthash + , sentSince = mempty + , enteredSince = mempty + , lastActivity = starthash + , lastActivityTs = ts + , lastEntered = Nothing + , fromOtherDevelopersSince = mempty + , developerSessionKey = sk + , userSigVerifier = sigverifier + , developerSigVerifier = mempty + } + atomically $ putTMVar dsv st + return (st, output) diff --git a/Role/Downloader.hs b/Role/Downloader.hs new file mode 100644 --- /dev/null +++ b/Role/Downloader.hs @@ -0,0 +1,42 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Role.Downloader where + +import Types +import Log +import CmdLine +import SessionID +import Crypto +import Role.Developer + +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Data.Time.Clock.POSIX + +run :: DownloadOpts -> IO () +run = run' downloader . downloadUrl + +downloader :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () +downloader dsv _ichan ochan sid = do + let logfile = sessionLogFile "." sid + putStrLn $ "Starting download to " ++ logfile + putStrLn "(Will keep downloading until the debug-me session is done.)" + withLogger logfile $ \logger -> do + sk <- genMySessionKey + (st, _startoutput) <- processSessionStart sk ochan logger dsv + go logger st + putStrLn $ "Finished download to " ++ logfile + where + go logger st = do + ts <- getPOSIXTime + v <- atomically $ getServerMessage ochan st ts + case v of + Nothing -> return () + Just (o, msg) -> do + _ <- logger msg + case o of + ProtocolError {} -> emitOutput o + _ -> go logger st diff --git a/Role/User.hs b/Role/User.hs new file mode 100644 --- /dev/null +++ b/Role/User.hs @@ -0,0 +1,374 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, TupleSections #-} + +module Role.User where + +import Types +import Pty +import Memory +import Log +import Session +import Hash +import Crypto +import Gpg +import CmdLine +import WebSockets +import SessionID +import PrevActivity +import ControlSocket +import ControlWindow + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import System.Process +import System.Exit +import qualified Data.Text.IO as T +import qualified Data.ByteString as B +import Data.List.NonEmpty (NonEmpty(..), toList) +import Data.Monoid +import Data.Maybe +import Data.Time.Clock.POSIX +import System.IO +import System.Environment + +run :: UserOpts -> IO ExitCode +run os = fromMaybe (ExitFailure 101) <$> connect + where + connect = do + putStrLn "A debug-me session lets someone else run commands on your computer" + putStrLn "to debug your problem. A log of this session can be emailed to you" + putStrLn "at the end, which you can use to prove what they did in this session." + putStr "Enter your email address: " + hFlush stdout + email <- T.getLine + (controlinput, controloutput) <- openControlWindow + putStr "Connecting to debug-me server..." + hFlush stdout + usv <- newEmptyTMVarIO + let app = clientApp (InitMode email) User developerMessages + runClientApp (useServer os) $ app $ \ochan ichan sid -> do + let url = sessionIDUrl sid (useServer os) + putStrLn "" + putStrLn "Others can connect to this session and help you debug by running:" + putStrLn $ " debug-me " ++ show url + hFlush stdout + withSessionLogger Nothing sid $ + go ochan ichan usv controlinput controloutput + go ochan ichan usv controlinput controloutput logger = do + (cmd, cmdparams) <- shellCommand os + runWithPty cmd cmdparams $ \(p, ph) -> do + us <- startProtocol startSession ochan logger + atomically $ putTMVar usv us + workers <- mapM async + [ sendPtyOutput p ochan us logger + , sendControlOutput controloutput ochan us logger ph + ] + mainworker <- async $ sendPtyInput ichan ochan controlinput p us logger + `race` forwardTtyInputToPty p + exitstatus <- waitForProcess ph + displayOutput ochan us logger $ + rawLine "" <> + rawLine (endSession exitstatus) + atomically $ do + closeTMChan ichan + closeTMChan controlinput + closeTMChan controloutput + mapM_ cancel workers + _ <- waitCatch mainworker + return exitstatus + +developerMessages :: AnyMessage -> Maybe (Message Entered) +developerMessages (Developer m) = Just m +developerMessages (User _) = Nothing + +shellCommand :: UserOpts -> IO (String, [String]) +shellCommand os = case cmdToRun os of + Just v -> return (v, []) + Nothing -> maybe ("bash", ["-l"]) (, []) <$> lookupEnv "SHELL" + +-- | Log of recent Activity, with the most recent first. +type Backlog = NonEmpty Log + +data UserState = UserState + { backLog :: Backlog + , userSessionKey :: MySessionKey + , sigVerifier :: SigVerifier + , lastSeenTs :: POSIXTime + , lastAcceptedEntered :: Maybe Hash + } + +-- | RecentActivity that uses the UserState. +userStateRecentActivity :: TVar UserState -> RecentActivity +userStateRecentActivity us = do + st <- readTVar us + let hs = catMaybes $ lastAcceptedEntered st + : map loggedHash (toList (backLog st)) + return (sigVerifier st, hs) + +-- | Start by establishing our session key, and displaying the starttxt. +startProtocol :: B.ByteString -> TMChan (Message Seen) -> Logger -> IO (TVar UserState) +startProtocol starttxt ochan logger = do + let initialmessage msg = do + atomically $ writeTMChan ochan msg + logger $ User msg + sk <- genMySessionKey + pk <- myPublicKey sk (GpgSign False) + let c = mkSigned sk $ Control (SessionKey pk currentProtocolVersion) + initialmessage $ ControlMessage c + let starttxt' = rawLine starttxt + let act = mkSigned sk $ Activity + (Seen (Val starttxt')) + Nothing Nothing mempty + let startmsg = ActivityMessage act + B.hPut stdout starttxt' + hFlush stdout + initialmessage startmsg + now <- getPOSIXTime + let l = mkLog (User startmsg) now + newTVarIO $ UserState + { backLog = l :| [] + , userSessionKey = sk + , sigVerifier = mempty + , lastSeenTs = now + , lastAcceptedEntered = Nothing + } + +-- | Forward things the user types to the Pty. +forwardTtyInputToPty :: Pty -> IO () +forwardTtyInputToPty p = do + b <- B.hGetSome stdin 1024 + if B.null b + then return () + else do + writePty p b + forwardTtyInputToPty p + +-- | Forward things written to the Pty out the TMChan, and also display +-- it on their Tty. +sendPtyOutput :: Pty -> TMChan (Message Seen) -> TVar UserState -> Logger -> IO () +sendPtyOutput p ochan us logger = go + where + go = do + displayOutput ochan us logger =<< readPty p + go + +-- | Display to Tty and send out the TMChan. +displayOutput :: TMChan (Message Seen) -> TVar UserState -> Logger -> B.ByteString -> IO () +displayOutput ochan us logger b = do + B.hPut stdout b + hFlush stdout + now <- getPOSIXTime + l <- atomically $ do + let seen = Seen (Val b) + sendDeveloper ochan us seen now + logger $ User l + +-- | Since the Tty is in raw mode, need \r before \n +rawLine :: B.ByteString -> B.ByteString +rawLine b = b <> "\r\n" + +class SendableToDeveloper t where + sendDeveloper :: TMChan (Message Seen) -> TVar UserState -> t -> POSIXTime -> STM (Message Seen) + +instance SendableToDeveloper Seen where + sendDeveloper ochan us seen now = do + st <- readTVar us + let bl@(prev :| _) = backLog st + let msg = ActivityMessage $ + mkSigned (userSessionKey st) $ + Activity seen + (loggedHash prev) + (lastAcceptedEntered st) + (mkElapsedTime (lastSeenTs st) now) + let l = mkLog (User msg) now + writeTMChan ochan msg + writeTVar us $ st + { backLog = l :| toList bl + , lastSeenTs = now + } + return msg + +instance SendableToDeveloper ControlAction where + sendDeveloper ochan us c _now = do + st <- readTVar us + let msg = ControlMessage $ + mkSigned (userSessionKey st) (Control c) + -- Control messages are not kept in the backlog. + writeTMChan ochan msg + return msg + +-- | Read things to be entered from the TMChan, verify if they're legal, +-- and send them to the Pty. Also handles control messages from the +-- developer. +sendPtyInput :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TMChan ControlInput -> Pty -> TVar UserState -> Logger -> IO () +sendPtyInput ichan ochan controlinput p us logger = go + where + go = do + now <- getPOSIXTime + v <- atomically $ getDeveloperMessage ichan ochan us now + case v of + Nothing -> return () + Just (InputMessage msg@(ActivityMessage entered)) -> do + logger $ Developer msg + writePty p $ val $ enteredData $ activity entered + go + Just (InputMessage msg@(ControlMessage (Control c _))) -> do + logger $ Developer msg + atomically $ writeTMChan controlinput (ControlInputAction c) + go + Just (RejectedMessage ent rej) -> do + logger $ Developer ent + logger $ User rej + go + Just (BadlySignedMessage _) -> go + +data Input + = InputMessage (Message Entered) + | RejectedMessage (Message Entered) (Message Seen) + | BadlySignedMessage (Message Entered) + +-- Get message from developer, verify its signature is from a developer we +-- have allowed (unless it's a SessionKey control message, then the +-- signature of the message is only verified against the key in it), and +-- make sure it's legal before returning it. If it's not legal, sends a +-- Reject message. +getDeveloperMessage :: TMChan (MissingHashes (Message Entered)) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM (Maybe Input) +getDeveloperMessage ichan ochan us now = maybe + (return Nothing) + (\msg -> Just <$> getDeveloperMessage' msg ochan us now) + =<< readTMChan ichan + +getDeveloperMessage' :: MissingHashes (Message Entered) -> TMChan (Message Seen) -> TVar UserState -> POSIXTime -> STM Input +getDeveloperMessage' (MissingHashes wiremsg) ochan us now = do + st <- readTVar us + Developer msg <- restoreHashes (userStateRecentActivity us) (MissingHashes (Developer wiremsg)) + case msg of + ControlMessage (Control (SessionKey spk _) _) -> do + let sigverifier = mkSigVerifier $ case spk of + GpgSigned pk _ _ -> pk + UnSigned pk -> pk + if verifySigned sigverifier msg + then return (InputMessage msg) + else return (BadlySignedMessage msg) + _ -> if verifySigned (sigVerifier st) msg + then case msg of + ActivityMessage entered -> do + -- Don't need to retain backlog + -- before the Activity that entered + -- references. + let bl' = reduceBacklog $ + truncateBacklog (backLog st) entered + if isLegalEntered entered (st { backLog = bl' }) + then do + let l = mkLog (Developer msg) now + writeTVar us $ st + { backLog = l :| toList bl' + , lastAcceptedEntered = Just (hash entered) + } + return (InputMessage msg) + else do + let reject = EnteredRejected + { enteredRejected = hash entered + , enteredLastAccepted = lastAcceptedEntered st + } + RejectedMessage msg + <$> sendDeveloper ochan us reject now + ControlMessage (Control _ _) -> + return (InputMessage msg) + else return (BadlySignedMessage msg) + +-- | Truncate the Backlog to remove entries older than the one +-- that the Activity Entered refers to, but only if the referred +-- to Activity is an Activity Seen. +-- +-- Once the developer has referred to a given Activity Seen in +-- their Activity Entered, they cannot refer backwards to anything +-- that came before it. +-- +-- If the Activity refers to an item not in the backlog, no truncation is +-- done. +truncateBacklog :: Backlog -> Activity Entered -> Backlog +truncateBacklog (b :| l) (Activity _ (Just hp) _ _ _) + | truncationpoint b = b :| [] + | otherwise = b :| go [] l + where + go c [] = reverse c + go c (x:xs) + | truncationpoint x = reverse (x:c) + | otherwise = go (x:c) xs + truncationpoint x@(Log { loggedMessage = User {}}) = loggedHash x == Just hp + truncationpoint _ = False +truncateBacklog bl (Activity _ Nothing _ _ _) = bl + +-- | To avoid DOS attacks that try to fill up the backlog and so use all +-- memory, don't let the backlog contain more than 1000 items, or +-- more than 16 megabytes of total data. (Excluding the most recent +-- item). +reduceBacklog :: Backlog -> Backlog +reduceBacklog (b :| l) = b :| go 0 (take 1000 l) + where + go _ [] = [] + go n (x:xs) + | n > 16777216 = [] + | otherwise = x : go (n + dataSize x) xs + +-- | Entered activity is legal when its prevActivity points to the last +-- logged activity, because this guarantees that the person who entered +-- it saw the current state of the system before manipulating it. +-- +-- To support typeahead on slow links, some echoData may be provided +-- in the Entered activity. If the Entered activity points +-- to an older prevActivity, then the echoData must match the +-- concatenation of all Seen activities after that one, up to the +-- last logged activity. +-- +-- Also, the prevEntered field must point to the last accepted +-- Entered activity. +-- +-- Does not check the signature. +isLegalEntered :: Activity Entered -> UserState -> Bool +isLegalEntered (Activity _ Nothing _ _ _) _ = False +isLegalEntered (Activity a (Just hp) lastentered _ _) us + | lastentered /= lastAcceptedEntered us = False + | loggedHash lastact == Just hp = True + | B.null (val (echoData a)) = False -- optimisation + | any (== Just hp) (map loggedHash bl) = + let sincehp = reverse (lastact : takeWhile (\l -> loggedHash l /= Just hp) bl) + in echoData a == mconcat (map (getseen . loggedMessage) sincehp) + | otherwise = False + where + (lastact :| bl) = backLog us + getseen (User (ActivityMessage as)) = seenData $ activity as + getseen _ = mempty + +-- | Forward messages from the control window to the developer. +-- +-- When the control window sends a SessionKeyAccepted, add it to the +-- sigVerifier. +sendControlOutput :: TMChan ControlOutput -> TMChan (Message Seen) -> TVar UserState -> Logger -> ProcessHandle -> IO () +sendControlOutput controloutput ochan us logger ph = loop + where + loop = go =<< atomically (readTMChan controloutput) + go Nothing = return () + go (Just ControlWindowOpened) = loop + go (Just (ControlOutputAction c)) = do + case c of + SessionKeyAccepted pk -> atomically $ do + st <- readTVar us + let sv = sigVerifier st + let sv' = sv `mappend` mkSigVerifier pk + let st' = st { sigVerifier = sv' } + writeTVar us st' + _ -> return () + now <- getPOSIXTime + l <- atomically $ sendDeveloper ochan us c now + logger (User l) + loop + go (Just ControlWindowRequestedImmediateQuit) = do + terminateProcess ph + return () diff --git a/Role/Watcher.hs b/Role/Watcher.hs new file mode 100644 --- /dev/null +++ b/Role/Watcher.hs @@ -0,0 +1,27 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Role.Watcher where + +import Types +import Log +import Pty +import CmdLine +import SessionID +import Crypto +import Role.Developer + +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan + +run :: WatchOpts -> IO () +run = run' watcher . watchUrl + +watcher :: TMVar (TVar DeveloperState) -> TMChan (Message Entered) -> TMChan (MissingHashes AnyMessage) -> SessionID -> IO () +watcher dsv _ichan ochan sid = withSessionLogger (Just "remote") sid $ \logger -> inRawMode $ do + sk <- genMySessionKey + (st, startoutput) <- processSessionStart sk ochan logger dsv + emitOutput startoutput + watchSessionReadOnly ochan logger st diff --git a/Server.hs b/Server.hs new file mode 100644 --- /dev/null +++ b/Server.hs @@ -0,0 +1,268 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, BangPatterns #-} + +module Server where + +import Types +import CmdLine +import WebSockets +import SessionID +import Log + +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WebSockets +import Network.WebSockets hiding (Message) +import qualified Network.WebSockets as WS +import Network.HTTP.Types +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Data.Maybe +import qualified Data.Map as M +import qualified Data.Text as T +import Data.Time.Clock.POSIX +import System.IO +import System.Directory +import System.Mem.Weak +import Network.Mail.Mime + +type ServerState = M.Map SessionID Session + +newServerState :: IO (TVar ServerState) +newServerState = newTVarIO M.empty + +-- | A session consists of a broadcast TMChan, which both users and +-- developers write messages to. Writes are stored in the log file, +-- and a log lock allows atomic access to the log file for replays. +data Session = Session (TMChan (Broadcast Log)) (TVar Handle) (TMVar LogLock) + +data LogLock = LogLock + +-- | A broadcast message, with the ThreadId of the sending thread +-- (which probably wants to ignore the message it sent). +data Broadcast a = Broadcast a (Weak ThreadId) + +newSession :: TVar Handle -> IO Session +newSession loghv = Session + <$> newBroadcastTMChanIO + <*> pure loghv + <*> newTMVarIO LogLock + +listenSession :: Session -> STM (TMChan (Broadcast Log)) +listenSession (Session bchan _ _) = dupTMChan bchan + +-- | While writing a log to the session the LogLock is drained until +-- the write has reached the log file. This prevents concurrent writes +-- to the file, and allows writes to be blocked while reading the log file. +writeSession :: Weak ThreadId -> Session -> Log -> IO () +writeSession tid (Session bchan loghv loglock) l = do + (ll, logh) <- atomically $ (,) + <$> takeTMVar loglock + <*> readTVar loghv + writeLogHandle l logh + atomically $ do + putTMVar loglock ll + writeTMChan bchan (Broadcast l tid) + +-- | Run an action with the log file quiescent (and its write handle closed), +-- and nothing being added to the session's broadcast TMChan. +preventWriteWhile :: Session -> ServerOpts -> SessionID -> IO a -> IO a +preventWriteWhile (Session _ loghv loglock) o sid a = bracket setup cleanup go + where + setup = do + (ll, logh) <- atomically $ (,) + <$> takeTMVar loglock + <*> readTVar loghv + hClose logh + return ll + cleanup ll = do + let f = sessionLogFile (serverDirectory o) sid + h <- openFile f AppendMode + atomically $ do + putTMVar loglock ll + writeTVar loghv h + go _ = a + +closeSession :: Session -> STM () +closeSession (Session bchan _ _) = closeTMChan bchan + +server :: ServerOpts -> IO () +server o = runSettings settings . app o =<< newServerState + where + settings = + -- Prefer IPv6 but allow IPv4 as well + -- (Workaround for + -- https://github.com/jaspervdj/websockets/issues/140) + setHost "*6" $ + setPort (serverPort o) $ + defaultSettings + +app :: ServerOpts -> TVar ServerState -> Application +app o ssv = websocketsOr connectionOptions (websocketApp o ssv) webapp + where + webapp _ respond = respond $ + responseLBS status400 [] "This is a debug-me server, it does not serve any html pages." + +websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp +websocketApp o ssv pending_conn = do + conn <- WS.acceptRequest pending_conn + _v <- negotiateWireVersion conn + r <- receiveData conn + case r of + SelectMode ClientSends (InitMode email) -> user email o ssv conn + SelectMode ClientSends (ConnectMode t) -> + case mkSessionID (T.unpack t) of + Nothing -> protocolError conn "Invalid session id!" + Just sid -> developer o ssv sid conn + _ -> protocolError conn "Expected SelectMode" + +user :: EmailAddress -> ServerOpts -> TVar ServerState -> WS.Connection -> IO () +user email o ssv conn = do + sid <- withSessionID (serverDirectory o) $ \(loghv, sid) -> do + sendBinaryData conn (Ready ServerSends sid) + bracket (setup sid loghv) (cleanup sid) go + return sid + doneSessionLog email o sid + where + setup sid loghv = do + session <- newSession loghv + atomically $ modifyTVar' ssv $ M.insert sid session + return session + + cleanup sid session = do + atomically $ do + closeSession session + modifyTVar' ssv $ M.delete sid + + go session = do + mytid <- mkWeakThreadId =<< myThreadId + userchan <- atomically $ listenSession session + _ <- relaytouser userchan + `race` relayfromuser mytid session + return () + + -- Relay all messages from the user's websocket to the + -- session broadcast channel. + -- (The user is allowed to send Developer messages too.. perhaps + -- they got them from a developer connected to them some other + -- way.) + relayfromuser mytid session = relayFromSocket conn $ \msg -> do + l <- mkLog msg <$> getPOSIXTime + writeSession mytid session l + + -- Relay Developer messages from the channel to the user's websocket. + relaytouser userchan = do + v <- atomically $ readTMChan userchan + case v of + Just (Broadcast l _from) -> case loggedMessage l of + Developer m -> do + sendBinaryData conn (AnyMessage (Developer m)) + relaytouser userchan + User _ -> relaytouser userchan + Nothing -> return () + +developer :: ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO () +developer o ssv sid conn = bracket setup cleanup go + where + setup = atomically $ M.lookup sid <$> readTVar ssv + cleanup _ = return () + go Nothing = do + exists <- doesFileExist $ + sessionLogFile (serverDirectory o) sid + if exists + then do + sendBinaryData conn (Ready ServerSends sid) + replayBacklog o sid conn + sendBinaryData conn Done + else protocolError conn "Unknown session ID" + go (Just session) = do + sendBinaryData conn (Ready ServerSends sid) + devchan <- replayBacklogAndListen o sid session conn + mytid <- mkWeakThreadId =<< myThreadId + _ <- relayfromdeveloper mytid session + `concurrently` relaytodeveloper mytid devchan + return () + + -- Relay all Developer amessages from the developer's websocket + -- to the broadcast channel. + relayfromdeveloper mytid session = relayFromSocket conn + $ \msg -> case msg of + Developer _ -> do + l <- mkLog msg <$> getPOSIXTime + writeSession mytid session l + -- developer cannot send User messages + User _ -> return () + + -- Relay user messages from the developer's clone of the + -- broadcast channel to the developer's websocket. + relaytodeveloper mytid devchan = do + v <- atomically $ readTMChan devchan + case v of + Just (Broadcast l from) -> do + let sendit = sendBinaryData conn + (AnyMessage $ loggedMessage l) + case loggedMessage l of + User _ -> sendit + -- Relay messages from other + -- developers, without looping + -- back the developer's own messages. + Developer _ -> do + rfrom <- deRefWeak from + rmy <- deRefWeak mytid + if rfrom == rmy + then return () + else sendit + relaytodeveloper mytid devchan + Nothing -> do + sendBinaryData conn Done + return () + +-- | Replay the log of what's happened in the session so far, +-- and return a channel that will get new session activity. +-- +-- This is done atomically; even if new activity arrives while it's +-- running nothing more will be logged until the log file has been +-- replayed and the channel set up. +-- +-- Note that the session may appear to freeze for other users while +-- this is running. +replayBacklogAndListen :: ServerOpts -> SessionID -> Session -> WS.Connection -> IO (TMChan (Broadcast Log)) +replayBacklogAndListen o sid session conn = + preventWriteWhile session o sid $ do + replayBacklog o sid conn + atomically $ listenSession session + +replayBacklog :: ServerOpts -> SessionID -> WS.Connection -> IO () +replayBacklog o sid conn = do + ls <- streamLog (sessionLogFile (serverDirectory o) sid) + forM_ ls $ \l -> case loggedMessage <$> l of + Right m -> sendBinaryData conn (AnyMessage m) + Left _ -> return () + +doneSessionLog :: EmailAddress -> ServerOpts -> SessionID -> IO () +doneSessionLog email o sid = do + let logfile = sessionLogFile (serverDirectory o) sid + emailSessionLog email o logfile + if serverDeleteOldLogs o + then removeFile logfile + else return () + +emailSessionLog :: EmailAddress -> ServerOpts -> FilePath -> IO () +emailSessionLog email o logfile + | isemail = renderSendMail + =<< simpleMail to from subject body body [("text/plain", logfile)] + | otherwise = return () + where + to = Address Nothing email + from = Address Nothing $ fromMaybe "unknown@server" (serverEmail o) + subject = "Your recent debug-me session" + body = "Attached is the log from your recent debug-me session." + isemail = "@" `T.isInfixOf` email diff --git a/ServerList.hs b/ServerList.hs new file mode 100644 --- /dev/null +++ b/ServerList.hs @@ -0,0 +1,13 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module ServerList where + +import Network.URI +import Data.Maybe + +defaultServerUrl :: URI +defaultServerUrl = fromMaybe (error "internal url parse error") $ + parseURI "http://debug-me.joeyh.name:8081/" diff --git a/Session.hs b/Session.hs new file mode 100644 --- /dev/null +++ b/Session.hs @@ -0,0 +1,23 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, RankNTypes, FlexibleContexts #-} + +module Session where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import System.Exit +import Data.Monoid + +startSession :: B.ByteString +startSession = "** debug-me session started" + +endSession :: ExitCode -> B.ByteString +endSession ec = "** debug-me session ended (" <> B8.pack (show n) <> ")" + where + n = case ec of + ExitSuccess -> 0 + ExitFailure c -> c diff --git a/SessionID.hs b/SessionID.hs new file mode 100644 --- /dev/null +++ b/SessionID.hs @@ -0,0 +1,81 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} + +module SessionID ( + SessionID, + mkSessionID, + sessionLogFile, + withSessionID, + sessionIDUrl, +) where + +import JSON + +import System.FilePath +import System.IO +import System.Directory +import Data.List +import Data.UUID +import Data.UUID.V4 +import Network.URI +import Control.Concurrent.STM +import Control.Exception + +-- | A SessionID is the base name of the log file to use, +-- and may not contain any path information. +newtype SessionID = SessionID FilePath + deriving (Show, Eq, Ord, Generic) + +-- | Custom JSON deserialization so we can check smart constructor +-- to verify it's legal. +instance FromJSON SessionID where + parseJSON v = verify =<< genericParseJSON defaultOptions v + where + verify (SessionID unverified) = + maybe (fail "illegal SessionID") return + (mkSessionID unverified) +instance ToJSON SessionID + +-- | Smart constructor that enforces legal SessionID contents. +-- +-- The passed String can either be the bare SessionID, or it can be an URL +-- which ends with the SessionID. +mkSessionID :: String -> Maybe SessionID +mkSessionID s + | "http" `isPrefixOf` s = Just $ SessionID $ takeFileName s + | takeFileName s == s = Just $ SessionID s + | otherwise = Nothing + +sessionLogFile :: FilePath -> SessionID -> FilePath +sessionLogFile dir (SessionID f) = dir "debug-me." ++ f ++ ".log" + +-- | Allocate a new SessionID open a Handle to its log file. +-- +-- A UUID is used, to avoid ever generating a SessionID that has been used +-- before. +withSessionID :: FilePath -> ((TVar Handle, SessionID) -> IO a) -> IO a +withSessionID dir a = do + createDirectoryIfMissing False dir + sid <- SessionID . toString <$> nextRandom + let f = sessionLogFile dir sid + -- File should not already exist, but just in case we get + -- spectacularly unlucky (or the RNG is broken..), + -- avoid overwriting a log, and try again. + exists <- doesFileExist f + if exists + then withSessionID dir a + else bracket (setup f) cleanup (go sid) + where + setup f = do + h <- openFile f WriteMode + hv <- newTVarIO h + return hv + cleanup hv = hClose =<< atomically (readTVar hv) + go sid hv = a (hv, sid) + +sessionIDUrl :: SessionID -> URI -> URI +sessionIDUrl (SessionID f) serverurl = serverurl { uriPath = "/" ++ f } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,35 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.Simple.Utils (installOrdinaryFiles, rawSystemExit) +import Distribution.PackageDescription (PackageDescription(..)) +import Distribution.Verbosity (Verbosity) +import System.Info +import System.FilePath + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { postCopy = myPostCopy + } + +myPostCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () +myPostCopy _ flags pkg lbi = if System.Info.os /= "mingw32" + then installManpages dest verbosity pkg lbi + else return () + where + dest = fromFlag $ copyDest flags + verbosity = fromFlag $ copyVerbosity flags + +{- See http://www.haskell.org/haskellwiki/Cabal/Developer-FAQ#Installing_manpages -} +installManpages :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +installManpages copyDest verbosity pkg lbi = + installOrdinaryFiles verbosity dstManDir [(".", "debug-me.1")] + where + dstManDir = mandir (absoluteInstallDirs pkg lbi copyDest) "man1" diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,271 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, OverloadedStrings #-} + +{- | Main types for debug-me + - + - Note that changing types in ways that change the JSON serialization + - changes debug-me's log format. + -} + +module Types ( + module Types, + Val(..) +) where + +import Val +import Memory +import JSON + +import qualified Data.Text as T +import Data.Time.Clock.POSIX + +-- | Things that the developer sees. +data Seen = Seen + { seenData :: Val + } + deriving (Show, Generic) + +instance DataSize Seen where + dataSize = dataSize . seenData + +-- | Things that the developer enters. +data Entered = Entered + { enteredData :: Val + , echoData :: Val + -- ^ Data that is expected to be Seen, but has not been received + -- at the time this was entered. + } + deriving (Show, Generic) + +instance DataSize Entered where + dataSize e = dataSize (enteredData e) + dataSize (echoData e) + +-- | A message in the protocol. +data Message a + = ActivityMessage (Activity a) + | ControlMessage Control + deriving (Show, Generic) + +instance DataSize a => DataSize (Message a) where + dataSize (ActivityMessage a) = dataSize a + dataSize (ControlMessage c) = dataSize c + +-- | An activity (either Entered or Seen) with a pointer +-- to a previous Activity, and the amount of time elapsed since the +-- previous Activity. +-- +-- The Signature is over both the data in the activity, and its pointer. +-- +-- The Signature is included in the Hash of an Activity, +-- which is why it's part of the Activity. +data Activity a = Activity + { activity :: a + , prevActivity :: Maybe Hash + -- ^ Pointer to previous activity Seen/Entered + , prevEntered :: Maybe Hash + -- ^ Pointer to previous activity Entered + , elapsedTime :: ElapsedTime + , activitySignature :: Signature + } + deriving (Show, Generic) + +-- | Used when a value has had its hashes erased for more efficient +-- transfer over the wire. +data MissingHashes a = MissingHashes a + +instance DataSize a => DataSize (Activity a) where + dataSize a = dataSize (activity a) + + maybe 0 dataSize (prevActivity a) + + dataSize (elapsedTime a) + + dataSize (activitySignature a) + +-- | A control message, which can be sent asynchronously. +data Control = Control + { control :: ControlAction + , controlSignature :: Signature + } + deriving (Show, Generic) + +instance DataSize Control where + dataSize c = dataSize (control c) + + dataSize (controlSignature c) + +data ControlAction + = EnteredRejected + { enteredRejected :: Hash + -- ^ Entered value that was rejected. + , enteredLastAccepted :: Maybe Hash + -- ^ The last Entered value that was accepted. + } + | SessionKey (PerhapsSigned PublicKey) ProtocolVersion + -- ^ sent by user at start, and later by developer, + -- to indicate their session key + | SessionKeyAccepted PublicKey + -- ^ sent by the user to in response to SessionKey + | SessionKeyRejected PublicKey + -- ^ sent by the user to in response to SessionKey + | ChatMessage SenderName Val + -- ^ sent by user or developer at any time + deriving (Show, Generic) + +type ProtocolVersion = Val + +currentProtocolVersion :: ProtocolVersion +currentProtocolVersion = Val "1" + +type SenderName = Val + +instance DataSize ControlAction where + dataSize (EnteredRejected h1 h2) = dataSize h1 + + maybe 0 dataSize h2 + dataSize (SessionKey k v) = dataSize k + dataSize v + dataSize (SessionKeyAccepted k) = dataSize k + dataSize (SessionKeyRejected k) = dataSize k + dataSize (ChatMessage s m) = dataSize s + dataSize m + +data Hash = Hash + { hashMethod :: HashMethod + , hashValue :: Val + } + deriving (Show, Generic, Eq) + +instance DataSize Hash where + dataSize (Hash { hashMethod = SHA512 }) = 128 + dataSize (Hash { hashMethod = SHA3 }) = 56 + +-- | We use SHA512. (SHA3 is included to future proof, and because it +-- improves the generated JSON.) +data HashMethod = SHA512 | SHA3 + deriving (Show, Generic, Eq) + +type EmailAddress = T.Text + +data Signature + = Ed25519Signature Val + | OtherSignature Val + -- ^ Not used, but included to future-proof the JSON format. + deriving (Show, Generic) + +instance DataSize Signature where + dataSize (Ed25519Signature v) = dataSize v + dataSize (OtherSignature v) = dataSize v + +-- | A public key used for a debug-me session. +data PublicKey = PublicKey Val + deriving (Show, Generic, Eq) + +instance DataSize PublicKey where + -- ed25519 public keys are 32 bytes + dataSize (PublicKey _) = 32 + +-- | A value that may be gpg signed. +data PerhapsSigned a + = GpgSigned a GpgSig GpgKeyExport + | UnSigned a + deriving (Show, Generic, Eq) + +instance DataSize a => DataSize (PerhapsSigned a) where + dataSize (GpgSigned a sig export) = + dataSize a + dataSize sig + dataSize export + dataSize (UnSigned a) = dataSize a + +-- | A signature made with a gpg key. +newtype GpgSig = GpgSig Val + deriving (Show, Generic, Eq) + +instance DataSize GpgSig where + dataSize (GpgSig s) = dataSize s + +-- | An export of a gpg public key. +newtype GpgKeyExport = GpgKeyExport Val + deriving (Show, Generic, Eq) + +instance DataSize GpgKeyExport where + dataSize (GpgKeyExport k) = dataSize k + +-- | Elapsed time in seconds. +newtype ElapsedTime = ElapsedTime Double + deriving (Show, Generic, Eq) + +mkElapsedTime :: POSIXTime -> POSIXTime -> ElapsedTime +mkElapsedTime start end = ElapsedTime $ fromRational $ toRational (end - start) + +instance Monoid ElapsedTime where + mempty = ElapsedTime 0 + mappend (ElapsedTime a) (ElapsedTime b) = ElapsedTime (a+b) + +instance DataSize ElapsedTime where + dataSize _ = 16 -- 128 bit Double + +instance ToJSON ElapsedTime +instance FromJSON ElapsedTime + +data AnyMessage + = User (Message Seen) + | Developer (Message Entered) + deriving (Show, Generic) + +instance DataSize AnyMessage where + dataSize (User a) = dataSize a + dataSize (Developer a) = dataSize a + +instance ToJSON AnyMessage where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON AnyMessage where + parseJSON = genericParseJSON sumOptions + +instance ToJSON Seen +instance FromJSON Seen +instance ToJSON Entered +instance FromJSON Entered +instance ToJSON (Activity Seen) +instance FromJSON (Activity Seen) +instance ToJSON (Activity Entered) +instance FromJSON (Activity Entered) +instance ToJSON Control +instance FromJSON Control +instance ToJSON Hash +instance FromJSON Hash +instance ToJSON HashMethod +instance FromJSON HashMethod +instance ToJSON PublicKey +instance FromJSON PublicKey +instance ToJSON GpgSig +instance FromJSON GpgSig +instance ToJSON GpgKeyExport +instance FromJSON GpgKeyExport + +instance ToJSON (Message Seen) where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON (Message Seen) where + parseJSON = genericParseJSON sumOptions + +instance ToJSON (Message Entered) where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON (Message Entered) where + parseJSON = genericParseJSON sumOptions + +instance ToJSON Signature where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON Signature where + parseJSON = genericParseJSON sumOptions + +instance ToJSON ControlAction where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON ControlAction where + parseJSON = genericParseJSON sumOptions + +instance ToJSON (PerhapsSigned PublicKey) where + toJSON = genericToJSON sumOptions + toEncoding = genericToEncoding sumOptions +instance FromJSON (PerhapsSigned PublicKey) where + parseJSON = genericParseJSON sumOptions diff --git a/Val.hs b/Val.hs new file mode 100644 --- /dev/null +++ b/Val.hs @@ -0,0 +1,48 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, FlexibleInstances, OverloadedStrings #-} + +module Val where + +import Memory +import JSON + +import GHC.Generics (Generic) +import Data.Aeson.Types +import qualified Codec.Binary.Base64 as B64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B + +-- | Newtype of ByteString so we can have JSON instances without orphans. +newtype Val = Val { val :: B.ByteString } + deriving (Show, Generic, Eq, Monoid) + +instance DataSize Val where + dataSize (Val b) = fromIntegral (B.length b) + +-- | JSON instances for Val, using base64 encoding when the value +-- is not utf-8 encoded, and otherwise using a more efficient encoding. +instance ToJSON Val where + toJSON (Val b) = case T.decodeUtf8' b of + Right v -> object [ "v" .= v ] + Left _ -> object [ "b64" .= b64 b ] +instance FromJSON Val where + parseJSON (Object o) = do + mv <- o .:? "v" + case mv of + Just v -> return $ Val $ T.encodeUtf8 v + Nothing -> Val <$> (unb64 =<< o .: "b64") + parseJSON invalid = typeMismatch "ByteString" invalid + +b64 :: B.ByteString -> T.Text +b64 = T.decodeUtf8 . B64.encode + +unb64 :: Monad m => T.Text -> m B.ByteString +unb64 t = either + (\_ -> fail "bad base64 data") + return + ( B64.decode $ T.encodeUtf8 t) diff --git a/VirtualTerminal.hs b/VirtualTerminal.hs new file mode 100644 --- /dev/null +++ b/VirtualTerminal.hs @@ -0,0 +1,46 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module VirtualTerminal where + +import System.FilePath +import System.Directory +import System.Process +import System.Environment + +-- | Finds a virtual termianl program that looks like it will work +-- to run a command with some parameters. +-- +-- Note that the parameters are exposed to the shell by some virtual +-- termianls, but not by others. +runInVirtualTerminal :: String -> String -> [String] -> IO (Maybe CreateProcess) +runInVirtualTerminal title cmd params = do + path <- getSearchPath + mdisplay <- lookupEnv "DISPLAY" + possibles <- case mdisplay of + Just _ -> return $ do + p <- path + c <- xtermcmds + return (p, c) + Nothing -> return [] + find possibles + where + find [] = return Nothing + find ((d, (c, ps)):rest) = do + exists <- doesFileExist (d c) + if exists + then return $ Just $ proc (d c) ps + else find rest + + -- Ordered list; generally xfce user may have gnome stuff + -- installed, and only fall back to the older terminals when + -- nothing else is available. + xtermcmds = + [ ("xfce4-terminal", std) + , ("gnome-terminal", ["-e", unwords (cmd:params)]) + , ("xterm", std) + , ("rxvt", ["-T", title, "-e", cmd]) + ] + std = ["-T", title, "-e", unwords (cmd:params)] diff --git a/WebSockets.hs b/WebSockets.hs new file mode 100644 --- /dev/null +++ b/WebSockets.hs @@ -0,0 +1,244 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings, DeriveGeneric, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module WebSockets ( + connectionOptions, + runClientApp, + clientApp, + protocolError, + relayFromSocket, + relayToSocket, + negotiateWireVersion, + WireProtocol(..), + Mode(..), + EmailAddress, + ClientSends(..), + ServerSends(..), +) where + +import Types +import SessionID +import ProtocolBuffers +import PrevActivity + +import Network.WebSockets hiding (Message) +import Control.Concurrent.STM +import Control.Concurrent.STM.TMChan +import Control.Concurrent.Async +import Control.Exception +import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.ProtocolBuffers +import qualified Data.Aeson +import qualified Data.Serialize +import qualified Data.Text as T +import qualified Data.ByteString.Lazy as L +import Data.List +import Data.Monoid +import Data.Maybe +import Text.Read +import Control.Monad +import Network.URI +import System.IO + +-- | Framing protocol used over a websocket connection. +-- +-- This is an asynchronous protocol; both client and server can send +-- messages at the same time. +-- +-- Messages that only one can send are tagged with ClientSends or +-- ServerSends. +data WireProtocol + = Version [WireVersion] + | SelectMode ClientSends Mode + | Ready ServerSends SessionID + | AnyMessage AnyMessage + | Done + | WireProtocolError String + +data ServerSends = ServerSends +data ClientSends = ClientSends + +instance WebSocketsData WireProtocol where + toLazyByteString (Version v) = "V" <> Data.Aeson.encode v + toLazyByteString (SelectMode _ m) = "M" <> Data.Aeson.encode m + toLazyByteString (Ready _ sid) = "R" <> Data.Aeson.encode sid + toLazyByteString (AnyMessage msg) = "L" <> + let pmsg = toProtocolBuffer msg :: AnyMessageP + in Data.Serialize.runPutLazy (encodeMessage pmsg) + toLazyByteString Done = "D" + toLazyByteString (WireProtocolError s) = "E" <> Data.Aeson.encode s + fromLazyByteString b = case L.splitAt 1 b of + ("V", v) -> maybe (WireProtocolError "invalid JSON in Version") + Version + (Data.Aeson.decode v) + ("M", m) -> maybe (WireProtocolError "invalid JSON in Mode") + (SelectMode ClientSends) + (Data.Aeson.decode m) + ("R", sid) -> maybe (WireProtocolError "invalid JSON in SessionID") + (Ready ServerSends) + (Data.Aeson.decode sid) + ("L", l) -> case Data.Serialize.runGetLazy decodeMessage l of + Left err -> WireProtocolError $ "Protocol buffers decode error: " ++ err + Right (pmsg :: AnyMessageP) -> AnyMessage (fromProtocolBuffer pmsg) + ("D", "") -> Done + ("E", s) -> maybe (WireProtocolError "invalid JSON in WireProtocolError") + WireProtocolError + (Data.Aeson.decode s) + _ -> WireProtocolError "received unknown websocket message" +#if MIN_VERSION_websockets(0,10,0) + fromDataMessage = fromLazyByteString . fromDataMessage +#endif + +-- | Modes of operation that can be requested for a websocket connection. +data Mode + = InitMode EmailAddress + -- ^ initialize a new debug-me session. + | ConnectMode T.Text + -- ^ Text specifies the SessionID to connect to + deriving (Show, Eq, Generic) + +instance FromJSON Mode +instance ToJSON Mode where + +newtype WireVersion = WireVersion T.Text + deriving (Show, Eq, Generic, Ord) + +instance FromJSON WireVersion +instance ToJSON WireVersion + +supportedWireVersions :: [WireVersion] +supportedWireVersions = [WireVersion "1"] + +connectionOptions :: ConnectionOptions +connectionOptions = defaultConnectionOptions +#if MIN_VERSION_websockets(0,10,0) + -- Enable compression. + { connectionCompressionOptions = + PermessageDeflateCompression defaultPermessageDeflate + } +#endif + +-- For some reason, runClient throws ConnectionClosed +-- when the server hangs up cleanly. Catch this unwanted exception. +-- See https://github.com/jaspervdj/websockets/issues/142 +runClientApp :: URI -> ClientApp a -> IO (Maybe a) +runClientApp serverurl app = do + rv <- newEmptyTMVarIO + let go conn = do + r <- app conn `catch` showerr + atomically $ putTMVar rv r + catchJust catchconnclosed + (runClientWith host port endpoint connectionOptions [] go) + (\_ -> return ()) + atomically (tryReadTMVar rv) + where + serverauth = fromMaybe (error "bad server url") (uriAuthority serverurl) + host = uriRegName serverauth + port = case uriPort serverauth of + (':':s) -> fromMaybe 80 (readMaybe s) + _ -> 80 + endpoint = uriPath serverurl + + catchconnclosed ConnectionClosed = Just () + catchconnclosed _ = Nothing + + showerr :: SomeException -> IO a + showerr e = do + hPutStrLn stderr (show e) + throwIO e + +-- | Make a client that sends and receives AnyMessages over a websocket. +clientApp + :: Mode + -> (sent -> AnyMessage) + -> (AnyMessage -> Maybe received) + -> (TMChan sent -> TMChan (MissingHashes received) -> SessionID -> IO a) + -> ClientApp a +clientApp mode mksent filterreceived a conn = do + -- Ping every 30 seconds to avoid timeouts caused by proxies etc. + forkPingThread conn 30 + _v <- negotiateWireVersion conn + sendBinaryData conn (SelectMode ClientSends mode) + r <- receiveData conn + case r of + Ready ServerSends sid -> bracket setup cleanup (go sid) + WireProtocolError e -> error e + _ -> protocolError conn "Did not get expected Ready message from server" + where + setup = do + schan <- newTMChanIO + rchan <- newTMChanIO + sthread <- async $ relayToSocket conn mksent $ + atomically (readTMChan schan) + rthread <- async $ do + relayFromSocket conn $ \v -> do + case filterreceived v of + Nothing -> return () + Just r -> atomically $ writeTMChan rchan (MissingHashes r) + -- Server sent Done, so close channels. + atomically $ do + closeTMChan schan + closeTMChan rchan + return (schan, rchan, sthread, rthread) + cleanup (schan, _, sthread, rthread) = do + sendBinaryData conn Done + atomically $ closeTMChan schan + -- Wait for any more data from the server. + -- These often die with a ConnectionClosed. + void $ waitCatch sthread + cancel rthread + void $ waitCatch rthread + go sid (schan, rchan, _, _) = a schan rchan sid + +relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO () +relayFromSocket conn sender = go + where + go = do + r <- receiveData conn + case r of + AnyMessage msg -> do + sender msg + go + Done -> return () + WireProtocolError e -> protocolError conn e + _ -> protocolError conn "Protocol error" + +relayToSocket :: Connection -> (received -> AnyMessage) -> IO (Maybe received) -> IO () +relayToSocket conn mksent getter = go + where + go = do + mmsg <- getter + case mmsg of + Nothing -> return () + Just msg -> do + let MissingHashes wiremsg = + removeHashes $ mksent msg + sendBinaryData conn $ AnyMessage wiremsg + go + +-- | Send supportedWireVersions and at the same time receive it from +-- the remote side. The highest version present in both lists will be used. +negotiateWireVersion :: Connection -> IO WireVersion +negotiateWireVersion conn = do + (_, resp) <- concurrently + (sendBinaryData conn $ Version supportedWireVersions) + (receiveData conn) + case resp of + Version remoteversions -> case reverse (intersect (sort supportedWireVersions) (sort remoteversions)) of + (v:_) -> return v + [] -> protocolError conn $ + "Unable to negotiate protocol Version. I support: " ++ show supportedWireVersions ++ " They support: " ++ show remoteversions + _ -> protocolError conn "Protocol error, did not receive Version" + +protocolError :: Connection -> String -> IO a +protocolError conn err = do + sendBinaryData conn (WireProtocolError err) + sendClose conn Done + error err diff --git a/debug-me.1 b/debug-me.1 new file mode 100644 --- /dev/null +++ b/debug-me.1 @@ -0,0 +1,104 @@ +.\" -*- nroff -*- +.TH debug-me 1 "Commands" +.SH NAME +debug-me \- secure remote debugging +.SH SYNOPSIS +.B debug-me [options] +.SH DESCRIPTION +Debugging a problem over email is slow, tedious, and hard. The developer +needs to see the your problem to understand it. Debug-me aims to make +debugging fast, fun, and easy, by letting the developer access your +computer remotely, so they can immediately see and interact with the +problem. Making your problem their problem gets it fixed fast. +.PP +A debug-me session is logged and signed with the developer's GnuPG +key, producing a chain of evidence of what they saw and what they did. +So the developer's good reputation is leveraged to make debug-me secure. +.PP +When you start debug-me without any options, it will connect to a debug-me +server, and print out an url that you can give to the developer to get +them connected to you. Then debug-me will show you their GnuPG key and who +has signed it. If the developer has a good reputation, you can proceed +to let them type into your console in a debug-me session. Once the +session is done, the debug-me server will email you the signed +evidence of what the developer did in the session. +.PP +It's a good idea to watch the debug-me session. The developer should be +running their buggy program in different ways, perhaps running a debugger, +or looking at configuration files. They should *not* be looking at your +personal files without asking you first in the debug-me chat window. +They should not be downloading or installing other software. If you see +them do anything you don't expect, you can enter "/quit" in the control +window to immediately end the debug-me session. +.PP +If the developer did do something bad, you'd have proof that they cannot +be trusted, which you can share with the world. Knowing that is the case +will keep most developers honest. +.SH USER OPTIONS +.IP "--run cmd" +Normally debug-me will run your login shell. To run some other command, +use this option. +.IP "--use-server url" +Specify a debug-me server to use. Not normally needed since there is a +default server. +.SH DEVELOPER OPTIONS +.IP url +Connect to a debug-me session on the specified url, to see and interact +with the user's bug. You need a GnuPG key to use this. +.IP "--watch url" +Connect to a debug-me session on the specified url and display what +happens in the session. Your keystrokes will not be sent to the session. +.SH COMMON SESSION OPTIONS +.IP "--control" +debug-me uses a separate window than the one displaying the debug-me +session, to control the session. This control window is where debug-me +shows the user what developers want to connect to the session. +The user and developer can also chat using the control window. +.IP +Normally, the control window will be opened when debug-me starts, +by running a terminal emulator (xterm or gnome-terminal, etc). +If debug-me is not being run in a graphical environment, that won't work, +and you'll need to open another shell prompt and +run "debug-me --control" to see it. +.SH LOG FILE OPTIONS +.IP "--download url" +Download a debug-me log file from the specified url. Note that if the +debug-me session is still in progress, this will continue downloading +until the session ends. The signature chain in the log file is verified +as it is downloaded, but developer gpg signatures are not verified. +.IP "--replay logfile" +Replay a debug-me log file with realistic pauses. +.IP +While this is running, you can press Space to skip forward in the +recording to the next point, which is useful when there are long pauses in +the recording. +.IP "--verify logfile" +Verify that the log file contains a valid chain of hashes, and valid +signatures. Will exit nonzero if any problem is detected. Displays the +gpg public keys of any developers who interacted with the debug-me session. +.IP "--graphviz logfile" +Uses graphviz to generate a visualization of a debug-me log file. +.IP "--show-hashes" +Include hashes in the graphviz visualization. +.SH SERVER OPTIONS +.IP "--server logdir" +Run a debug-me server, logging to the specified directory. +.IP "--port N" +Specify a port for the debug-me server to listen to. +.IP "--from-email address" +The server will email session logs to users. It's a good idea to +provide a real email address, otherwise a dummy one will be used. +.IP "--delete-old-logs" +Normally the server will retain old log files so that users and developers +can refer to them. This option makes it delete the log file once the +session is done. +.SH FILES +.IP "~/.debug-me/log/" +Sessions are logged to here. The log file name is displayed when debug-me +exits. +.SH SEE ALSO + +.PP +.BR gnupg (1) +.SH AUTHOR +Joey Hess diff --git a/debug-me.cabal b/debug-me.cabal new file mode 100644 --- /dev/null +++ b/debug-me.cabal @@ -0,0 +1,117 @@ +Name: debug-me +Version: 1.20170505 +Cabal-Version: >= 1.8 +Maintainer: Joey Hess +Author: Joey Hess +Stability: Experimental +Copyright: 2017 Joey Hess +License: AGPL-3 +Homepage: https://debug-me.branchable.com/ +Category: Utility +Build-Type: Custom +Synopsis: secure remote debugging +Description: + Debugging a problem over email is slow, tedious, and hard. The developer + needs to see your problem to understand it. Debug-me aims to make debugging + fast, fun, and easy, by letting the developer access your computer remotely, + so they can immediately see and interact with the problem. Making your + problem their problem gets it fixed fast. + . + A debug-me session is logged and signed with the developer's GnuPG + key, producing a chain of evidence of what they saw and what they did. + So the developer's good reputation is leveraged to make debug-me secure. + . + When you start debug-me without any options, it will connect to a debug-me + server, and print out an url that you can give to the developer to get + them connected to you. Then debug-me will show you their GnuPG key and who + has signed it. If the developer has a good reputation, you can proceed + to let them type into your console in a debug-me session. Once the + session is done, the debug-me server will email you the signed + evidence of what the developer did in the session. + . + If the developer did do something bad, you'd have proof that they cannot + be trusted, which you can share with the world. Knowing that is the case + will keep most developers honest. +License-File: AGPL +Extra-Source-Files: + CHANGELOG + Makefile + debug-me.1 + debug-me.service + debug-me.init + debug-me.default + +Executable debug-me + Main-Is: debug-me.hs + GHC-Options: -threaded -Wall -fno-warn-tabs -O2 + Build-Depends: + base (>= 4.9 && < 5.0) + , network (>= 2.6) + , bytestring == 0.10.* + , cryptonite (>= 0.20) + , unix (>= 2.7) + , process (>= 1.4) + , async (>= 2.1) + , stm (>= 2.4) + , stm-chans (>= 3.0) + , posix-pty (>= 0.2.1) + , terminal-size (>= 0.3) + , aeson (>= 0.11 && < 1.1) + , sandi (>= 0.4) + , text (>= 1.2.2) + , optparse-applicative (>= 0.12) + , graphviz (== 2999.18.*) + , time (>= 1.6) + , filepath (>= 1.4) + , directory (>= 1.2) + , containers (>= 0.5) + , unordered-containers (>= 0.2) + , unbounded-delays (>= 0.1) + , memory (>= 0.13) + , warp (>= 3.2) + , wai (>= 3.2) + , http-types (>= 0.9) + , http-client (>= 0.4) + , http-client-tls (>= 0.2) + , websockets (>= 0.9) + , wai-websockets (>= 3.0) + , uuid (>= 1.3) + , protobuf (>= 0.2) + , cereal (>= 0.5) + , utf8-string (>= 1.0) + , network-uri (>= 2.6) + , mime-mail (>= 0.4) + Other-Modules: + ControlWindow + ControlSocket + CmdLine + Crypto + DotDir + Graphviz + Gpg + Gpg.Wot + Hash + JSON + Log + Memory + Output + Pty + PrevActivity + ProtocolBuffers + Replay + Role.Developer + Role.Downloader + Role.User + Role.Watcher + Session + Server + ServerList + SessionID + Types + Val + VirtualTerminal + WebSockets + +source-repository head + type: git + location: git://debug-me.branchable.com/ diff --git a/debug-me.default b/debug-me.default new file mode 100644 --- /dev/null +++ b/debug-me.default @@ -0,0 +1,2 @@ +# Parameters to pass to debug-me when it's started as a daemon. +DAEMON_PARAMS="--server /var/log/debug-me/ --delete-old-logs" diff --git a/debug-me.hs b/debug-me.hs new file mode 100644 --- /dev/null +++ b/debug-me.hs @@ -0,0 +1,34 @@ +{- Copyright 2017 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Main where + +import CmdLine +import Graphviz +import Replay +import Verify +import Server +import ControlWindow +import qualified Role.User +import qualified Role.Developer +import qualified Role.Downloader +import qualified Role.Watcher + +import Network.Socket +import System.Exit + +main :: IO () +main = withSocketsDo $ do + c <- getCmdLine + case mode c of + UserMode o -> Role.User.run o >>= exitWith + DeveloperMode o -> Role.Developer.run o + DownloadMode o -> Role.Downloader.run o + WatchMode o -> Role.Watcher.run o + GraphvizMode o -> graphviz o + ReplayMode o -> replay o + VerifyMode o -> verify o + ServerMode o -> server o + ControlMode o -> controlWindow o diff --git a/debug-me.init b/debug-me.init new file mode 100644 --- /dev/null +++ b/debug-me.init @@ -0,0 +1,61 @@ +#!/bin/sh + +### BEGIN INIT INFO +# Provides: debug-me +# Required-Start: $network $remote_fs +# Required-Stop: $network $remote_fs +# Default-Start: 2 3 4 5 +# Default-Stop: 0 1 6 +# Short-Description: debug-me server +# Description: Starts debug-me in server mode +### END INIT INFO + +PATH=/bin:/usr/bin:/sbin:/usr/sbin +NAME=debug-me +DESC="debug-me server" +DAEMON="/usr/bin/debug-me" +PIDFILE=/var/run/"$NAME".pid + +test -x /usr/bin/debug-me || exit 0 + +. /lib/lsb/init-functions + +# Parameters to pass to debug-me. +# This can be overridden in /etc/default/debug-me +DAEMON_PARAMS="--server /var/log/debug-me/ --delete-old-logs" +if [ -e /etc/default/debug-me ]; then + . /etc/default/debug-me +fi + +case "$1" in + start) + log_daemon_msg "Starting $DESC" "$NAME" + start-stop-daemon --start --quiet --oknodo \ + --background --no-close \ + --pidfile "$PIDFILE" --make-pidfile \ + --chuid debug-me:debug-me \ + --exec "$DAEMON" -- $DAEMON_PARAMS \ + > /var/log/debug-me.log + log_end_msg $? + ;; + stop) + log_daemon_msg "Stopping $DESC" "$NAME" + killproc -p "$PIDFILE" "$DAEMON" + RETVAL=$? + [ $RETVAL -eq 0 ] && [ -e "$PIDFILE" ] && rm -f $PIDFILE + log_end_msg $RETVAL + ;; + restart|reload|force-reload) + log_daemon_msg "Restarting $DESC" "$NAME" + $0 stop + $0 start + ;; + status) + status_of_proc -p $PIDFILE "$DAEMON" "$NAME" && exit 0 || exit $? + ;; + *) + log_action_msg "Usage: /etc/init.d/debug-me {start|stop|status|restart|reload|force-reload}" + exit 2 + ;; +esac +exit 0 diff --git a/debug-me.service b/debug-me.service new file mode 100644 --- /dev/null +++ b/debug-me.service @@ -0,0 +1,18 @@ +[Unit] +Description=debug-me server +Documentation=https://debug-me.branchable.com/ + +[Service] +Environment='DAEMON_PARAMS=--server /var/log/debug-me/ --delete-old-logs' +EnvironmentFile=-/etc/default/debug-me +ExecStart=/usr/bin/debug-me $DAEMON_PARAMS +InaccessiblePaths=/home /etc +ReadWritePaths=/var/log/debug-me +User=debug-me +Group=debug-me +StandardInput=null +StandardOutput=journal +StandardError=journal + +[Install] +WantedBy=multi-user.target