debug-me (empty) → 1.20170505

raw patch · 39 files changed

+4815/−0 lines, 39 filesdep +aesondep +asyncdep +basebuild-type:Customsetup-changed

Dependencies added: aeson, async, base, bytestring, cereal, containers, cryptonite, directory, filepath, graphviz, http-client, http-client-tls, http-types, memory, mime-mail, network, network-uri, optparse-applicative, posix-pty, process, protobuf, sandi, stm, stm-chans, terminal-size, text, time, unbounded-delays, unix, unordered-containers, utf8-string, uuid, wai, wai-websockets, warp, websockets

Files

• AGPL +661/−0
• CHANGELOG +5/−0
• CmdLine.hs +176/−0
• ControlSocket.hs +130/−0
• ControlWindow.hs +195/−0
• Crypto.hs +99/−0
• DotDir.hs +17/−0
• Gpg.hs +164/−0
• Gpg/Wot.hs +119/−0
• Graphviz.hs +137/−0
• Hash.hs +92/−0
• JSON.hs +18/−0
• Log.hs +101/−0
• Makefile +84/−0
• Memory.hs +14/−0
• Output.hs +15/−0
• PrevActivity.hs +58/−0
• ProtocolBuffers.hs +326/−0
• Pty.hs +93/−0
• Replay.hs +46/−0
• Role/Developer.hs +457/−0
• Role/Downloader.hs +42/−0
• Role/User.hs +374/−0
• Role/Watcher.hs +27/−0
• Server.hs +268/−0
• ServerList.hs +13/−0
• Session.hs +23/−0
• SessionID.hs +81/−0
• Setup.hs +35/−0
• Types.hs +271/−0
• Val.hs +48/−0
• VirtualTerminal.hs +46/−0
• WebSockets.hs +244/−0
• debug-me.1 +104/−0
• debug-me.cabal +117/−0
• debug-me.default +2/−0
• debug-me.hs +34/−0
• debug-me.init +61/−0
• debug-me.service +18/−0

@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU 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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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 <http://www.gnu.org/licenses/>.++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+<http://www.gnu.org/licenses/>.

@@ -0,0 +1,5 @@+debug-me (1.20170505) unstable; urgency=medium++  * First release of debug-me.++ -- Joey Hess <id@joeyh.name>  Thu, 04 May 2017 17:03:19 -0400

@@ -0,0 +1,176 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,130 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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')

@@ -0,0 +1,195 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,99 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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 _ = "<MySessionKey>"++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)

@@ -0,0 +1,17 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,164 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,119 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,137 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,92 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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)

@@ -0,0 +1,18 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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 }

@@ -0,0 +1,101 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -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

@@ -0,0 +1,14 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,15 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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 = '?'

@@ -0,0 +1,58 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,326 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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)

@@ -0,0 +1,93 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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+

@@ -0,0 +1,46 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,457 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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)

@@ -0,0 +1,42 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,374 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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 ()

@@ -0,0 +1,27 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,268 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,13 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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/"

@@ -0,0 +1,23 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,81 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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 }

@@ -0,0 +1,35 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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"

@@ -0,0 +1,271 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -0,0 +1,48 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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)

@@ -0,0 +1,46 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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)]

@@ -0,0 +1,244 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -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+<https://debug-me.branchable.com/>+.PP+.BR gnupg (1)+.SH AUTHOR +Joey Hess <id@joeyh.name>

@@ -0,0 +1,117 @@+Name: debug-me+Version: 1.20170505+Cabal-Version: >= 1.8+Maintainer: Joey Hess <joey@kitenet.net>+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/

@@ -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"

@@ -0,0 +1,34 @@+{- Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - 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

@@ -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

@@ -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