diohsc (empty) → 0.1.1
raw patch · 35 files changed
+4952/−0 lines, 35 filesdep +asn1-typesdep +basedep +bytestringsetup-changed
Dependencies added: asn1-types, base, bytestring, containers, cryptonite, data-default-class, data-hash, directory, drunken-bishop, exceptions, filepath, haskeline, hourglass, iconv, magic, mime, mtl, network, network-uri, parsec, pem, process, regex-compat, safe, temporary, terminal-size, text, tls, transformers, unix, x509, x509-store, x509-validation
Files
- ANSIColour.hs +127/−0
- ActiveIdentities.hs +64/−0
- Alias.hs +42/−0
- BStack.hs +41/−0
- BoundedBSChan.hs +68/−0
- COPYING +674/−0
- ClientCert.hs +133/−0
- ClientSessionManager.hs +54/−0
- Command.hs +475/−0
- CommandLine.hs +203/−0
- Fingerprint.hs +28/−0
- GeminiProtocol.hs +392/−0
- Identity.hs +81/−0
- Makefile +50/−0
- Marks.hs +87/−0
- MetaString.hs +24/−0
- Mundanities.hs +57/−0
- Opts.hs +54/−0
- Pager.hs +60/−0
- Prompt.hs +86/−0
- README.md +82/−0
- Request.hs +43/−0
- RunExternal.hs +110/−0
- ServiceCerts.hs +50/−0
- Setup.hs +2/−0
- Slurp.hs +63/−0
- THANKS +8/−0
- TextGemini.hs +164/−0
- URI.hs +167/−0
- Util.hs +39/−0
- Version.hs +19/−0
- diohsc.1.md +115/−0
- diohsc.cabal +107/−0
- diohsc.hs +1125/−0
- diohscrc.sample +58/−0
+ ANSIColour.hs view
@@ -0,0 +1,127 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe #-}++-- Basic ansi attributes, using only most widely supported ansi terminal codes+module ANSIColour+ ( applyIf+ , resetCode+ , withColour+ , withBold+ , withUnderline+ , withColourStr+ , withBoldStr+ , withUnderlineStr+ , stripCSI+ , visibleLength+ , escapePromptCSI+ , sanitiseNonCSI+ , Colour(..)+ ) where++import Control.Exception.Base (bracket_)++import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T++import MetaString++data Colour = Black | Red | Green | Yellow+ | Blue | Magenta | Cyan | White+ | BoldBlack | BoldRed | BoldGreen | BoldYellow+ | BoldBlue | BoldMagenta | BoldCyan | BoldWhite+ deriving (Eq,Ord,Show,Read)++resetCode,boldCode,underlineCode :: MetaString a => a+resetCode = "\ESC[0m"+boldCode = "\ESC[1m"+underlineCode = "\ESC[4m"+colourCode :: MetaString a => Colour -> a+colourCode c = (if isBold c then boldCode else "") <> "\ESC[3" <> fromString (colNum c) <> "m"+ where+ isBold = flip elem [BoldBlack, BoldRed, BoldGreen, BoldYellow,+ BoldBlue, BoldMagenta, BoldCyan, BoldWhite]+ colNum Black = "0"+ colNum Red = "1"+ colNum Green = "2"+ colNum Yellow = "3"+ colNum Blue = "4"+ colNum Magenta = "5"+ colNum Cyan = "6"+ colNum White = "7"+ colNum BoldBlack = "0"+ colNum BoldRed = "1"+ colNum BoldGreen = "2"+ colNum BoldYellow = "3"+ colNum BoldBlue = "4"+ colNum BoldMagenta = "5"+ colNum BoldCyan = "6"+ colNum BoldWhite = "7"++thenReset :: IO () -> IO a -> IO a+thenReset = (`bracket_` T.putStr resetCode)++withColour :: Colour -> IO a -> IO a+withColour c = thenReset $ T.putStr (colourCode c)+withBold :: IO a -> IO a+withBold = thenReset $ T.putStr boldCode+withUnderline :: IO a -> IO a+withUnderline = thenReset $ T.putStr underlineCode++withColourStr :: MetaString a => Colour -> a -> a+withColourStr c s = colourCode c <> s <> resetCode+withBoldStr :: MetaString a => a -> a+withBoldStr s = boldCode <> s <> resetCode+withUnderlineStr :: MetaString a => a -> a+withUnderlineStr s = underlineCode <> s <> resetCode++-- |"applyIf cond f" is shorthand for "if cond then f else id"+applyIf :: Bool -> (a -> a) -> (a -> a)+applyIf True = id+applyIf False = const id+++endCSI :: Char -> Bool+endCSI c = '@' <= c && c <= '~'++-- |strip all CSI escape sequences+stripCSI :: T.Text -> T.Text+stripCSI s =+ let (pre,post) = T.breakOn "\ESC[" s+ in if T.null post then pre+ else (pre <>) . stripCSI . T.drop 1 .+ T.dropWhile (not . endCSI) $ T.drop 2 post++visibleLength :: (Integral i) => T.Text -> i+visibleLength = fromIntegral . T.length . stripCSI++-- |sanitise non-CSI escape sequences by turning \ESC into \\ESC+-- (buggy terminals make these sequences a potential security hole;+-- see e.g. https://nvd.nist.gov/vuln/detail/CVE-2020-9366 )+sanitiseNonCSI :: T.Text -> T.Text+sanitiseNonCSI s =+ let (pre,post) = T.breakOn "\ESC" s+ in if T.null post then pre else+ let post' = T.drop 1 post+ isCSI = T.take 1 post' == "["+ in pre <> (if isCSI then "\ESC" else "\\ESC") <> sanitiseNonCSI post'++-- |append \STX to each CSI sequence, as required in Haskeline prompts.+-- See https://github.com/judah/haskeline/wiki/ControlSequencesInPrompt+escapePromptCSI :: String -> String+escapePromptCSI s = case break (== '\ESC') s of+ (pre,'\ESC':'[':post) -> ((pre <> "\ESC[") <>) $+ case break endCSI post of+ (pre',e:post') -> (pre' <>) $ e : '\STX' : escapePromptCSI post'+ (pre',[]) -> pre'+ (pre,[]) -> pre+ (pre,e:post) -> (pre <>) $ e : escapePromptCSI post
+ ActiveIdentities.hs view
@@ -0,0 +1,64 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE TupleSections #-}++module ActiveIdentities where++import Control.Monad (mplus)+import Data.Hourglass (Elapsed(..))+import Data.Maybe (fromJust)+import Time.System (timeCurrent)++import qualified Data.Map as Map++import Identity (Identity(..), isTemporary, showIdentity)+import Prompt+import Request+import URI++type ActiveIdentities = Map.Map Request (Identity, Elapsed)++insertIdentity :: Request -> Identity -> ActiveIdentities -> IO ActiveIdentities+insertIdentity (NetworkRequest host uri) ident ais = do+ let req = NetworkRequest host $ stripUri uri+ currentTime <- timeCurrent+ return $ Map.insert req (ident, currentTime) ais+insertIdentity _ _ ais = return ais++deleteIdentity :: Request -> ActiveIdentities -> ActiveIdentities+deleteIdentity = Map.delete++findIdentityRoot :: ActiveIdentities -> Request -> Maybe (Request, (Identity, Elapsed))+findIdentityRoot ais (NetworkRequest host reqUri) = findIdentity' $ stripUri reqUri+ where findIdentity' uri =+ let req = NetworkRequest host uri+ uri' = stripUri $ (fromJust . parseUriReference $ ".") `relativeTo` uri+ in ((req,) <$> Map.lookup req ais) `mplus`+ if uri' == uri then Nothing else findIdentity' uri'+findIdentityRoot _ _ = Nothing++findIdentity :: ActiveIdentities -> Request -> Maybe Identity+findIdentity ais req = fst . snd <$> findIdentityRoot ais req++useActiveIdentity :: Bool -> Bool -> Request -> ActiveIdentities -> IO (Maybe Identity, ActiveIdentities)+useActiveIdentity noConfirm ansi req ais =+ case findIdentityRoot ais req of+ Nothing -> return (Nothing, ais)+ Just (root, (ident, lastUsed)) -> do+ currentTime <- timeCurrent+ use <- if currentTime - lastUsed > Elapsed 1800+ then promptYN (not noConfirm) False $ if isTemporary ident+ then "Reuse old anonymous identity?"+ else "Continue to use identity " ++ showIdentity ansi ident ++ "?"+ else return True+ return $ if use+ then (Just ident, Map.insert root (ident, currentTime) ais)+ else (Nothing, Map.delete root ais)
+ Alias.hs view
@@ -0,0 +1,42 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE Safe #-}++module Alias where++import Data.Bifunctor (second)+import Data.List (isPrefixOf)+import Safe (headMay)++import CommandLine++data Alias = Alias String CommandLine+ deriving (Eq,Ord,Show)++type Aliases = [(String,Alias)]++emptyAliases :: Aliases+emptyAliases = []++defaultAliases :: Aliases+defaultAliases = second aliasOf <$>+ [ ("back", "<") , ("forward", ">") , ("next", "~") ]+ where aliasOf s = let Right cl = parseCommandLine s in Alias s cl++lookupAlias :: String -> Aliases -> Maybe Alias+lookupAlias s aliases = + headMay [ alias | (a,alias) <- aliases, s `isPrefixOf` a ]++insertAlias :: String -> Alias -> Aliases -> Aliases+insertAlias a alias = (++ [(a, alias)])++deleteAlias :: String -> Aliases -> Aliases+deleteAlias a = filter $ (/= a) . fst
+ BStack.hs view
@@ -0,0 +1,41 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++-- |Simple dirty bounded stack based on Data.Sequence+module BStack where++import Prelude hiding (truncate)+import Data.Sequence (Seq(..)) -- , (:<|), (:|>))+import qualified Data.Sequence as S+import qualified Data.Foldable as F++data BStack a = BStack (Seq a) Int++fromList :: [a] -> BStack a+fromList as = BStack (S.fromList as) $ length as++empty :: BStack a+empty = BStack Empty 0++toList :: BStack a -> [a]+toList (BStack as _) = F.toList as++push :: Int -> a -> BStack a -> BStack a+push l a s@(BStack as n)+ | l <= 0 = empty+ | n < l = BStack (a :<| as) $ n + 1+ | n > l = push l a $ truncate l s+ | Empty <- as = BStack (S.singleton a) 1+ | (as' :|> _) <- as = BStack (a :<| as') n++truncate :: Int -> BStack a -> BStack a+truncate l s@(BStack as n)+ | l >= n = s+ | otherwise = BStack (S.take l as) l
+ BoundedBSChan.hs view
@@ -0,0 +1,68 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++-- |Wrapper around `Chan ByteString` which bounds the total size of the +-- bytestring in the queue.+--+-- WARNING: this is not a general solution, you probably do not want to use +-- this in your project! It handles only the simplest case of a single reader +-- and a single writer, and will fail horribly in more general cases.+-- One thread must only call writeChan, while the other only calls +-- getBSChanContents.+--+-- Note also that only the lengths of the bytestrings in the chan count +-- towards the total, so it will accept unboundedly many `BS.empty`s +-- (consuming unbounded memory!)+--+-- If you're reading this and know of a nice light library I could have used +-- instead of hacking this together, please let me know!+-- There's stm-sbchan, but it seems a bit heavy, and would add stm as a +-- dependency.+module BoundedBSChan+ ( newBSChan+ , writeBSChan+ , getBSChanContents+ ) where++import Control.Concurrent+import Control.Monad+import Data.Maybe (fromMaybe)+import System.IO.Unsafe (unsafeInterleaveIO)++import qualified Data.ByteString as BS++data BoundedBSChan = BoundedBSChan+ Int -- ^bound+ (MVar Int) -- ^tally of bytes in queue+ (MVar Int) -- ^bytes removed from queue, not yet incorporated into tally+ (Chan BS.ByteString) -- ^underlying unbounded chan++newBSChan :: Int -> IO BoundedBSChan+newBSChan maxSize = liftM3 (BoundedBSChan maxSize) (newMVar 0) (newMVar 0) newChan++writeBSChan :: BoundedBSChan -> BS.ByteString -> IO ()+writeBSChan c@(BoundedBSChan maxSize wv rv ch) b = do+ let len = BS.length b+ done <- modifyMVar wv $ \w ->+ if w > 0 && w + len > maxSize+ then takeMVar rv >>= \r -> return (w - r, False)+ else writeChan ch b >> return (w + len, True)+ unless done $ writeBSChan c b++readBSChan :: BoundedBSChan -> IO BS.ByteString+readBSChan (BoundedBSChan _ _ rv ch) = do+ b <- readChan ch+ r <- fromMaybe 0 <$> tryTakeMVar rv+ putMVar rv $ r + BS.length b+ return b++getBSChanContents :: BoundedBSChan -> IO [BS.ByteString]+getBSChanContents c = unsafeInterleaveIO $+ liftM2 (:) (readBSChan c) (getBSChanContents c)
+ COPYING view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <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 General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ ClientCert.hs view
@@ -0,0 +1,133 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module ClientCert where++import Control.Applicative (liftA2)+import Crypto.Hash.Algorithms (SHA256(..))+import Crypto.PubKey.RSA+import Crypto.PubKey.RSA.PKCS15+import Data.ASN1.OID+import Data.ASN1.Types.String (ASN1StringEncoding(UTF8))+import Data.Either (fromRight)+import Data.Hourglass+import Data.PEM+import Data.X509+import Network.TLS (PrivKey(PrivKeyRSA))+import Safe+import System.FilePath+import Time.System++import qualified Data.ByteString as BS+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS++import Fingerprint+import Mundanities+import Util++#ifndef WINDOWS+import System.Posix.Files+#endif++-- |Certificate chain with secret key for tail cert+data ClientCert = ClientCert CertificateChain PrivKey+ deriving (Eq,Show)++clientCertFingerprint :: ClientCert -> Fingerprint+clientCertFingerprint (ClientCert (CertificateChain chain) _) =+ fingerprint $ head chain++loadClientCert :: FilePath -> String -> IO (Maybe ClientCert)+loadClientCert path name =+ let certpath = path </> name <.> "crt"+ keypath = path </> name <.> "rsa"+ in ignoreIOErrAlt $ do+ chain <- pemParseBS <$> BS.readFile certpath >>= \pem -> return $ case pem of+ Right pems -> case decodeCertificateChain . CertificateChainRaw $ map pemContent pems of+ Right chain -> Just chain+ _ -> Nothing+ _ -> Nothing+ key <- (PrivKeyRSA <$>) . readMay <$> readFile keypath+ return $ liftA2 ClientCert chain key++saveClientCert :: FilePath -> String -> ClientCert -> IO ()+saveClientCert path name (ClientCert chain (PrivKeyRSA key)) =+ let filepath = path </> name+ certpath = filepath <.> "crt"+ keypath = filepath <.> "rsa"+ in isSubPath path filepath >>? ignoreIOErr $ do+ let CertificateChainRaw rawCerts = encodeCertificateChain chain+ chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts+ BS.writeFile certpath $ BS.intercalate "\n" chainPEMs+ writeFile keypath $ show key+#ifndef WINDOWS+ setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600+#endif+saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type"++-- |generate 2048bit RSA key with (-1y,+2y) validity+-- FIXME: these choices fingerprint the client+generateSelfSigned :: String -> IO ClientCert+generateSelfSigned cn = do+ (pubKey, secKey) <- generate 256 65537+ blinder <- generateBlinder $ public_n pubKey+ currentTime <- timeConvert <$> timeCurrent+ let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]+ sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA+ to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 2, periodMonths = 0, periodDays = 0}+ from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0}+ cert = Certificate+ { certVersion = 3+ , certSerial = 0+ , certSignatureAlg = sigAlg+ , certIssuerDN = dn+ , certSubjectDN = dn+ , certValidity = (from, to)+ , certPubKey = PubKeyRSA pubKey+ , certExtensions = Extensions Nothing+ }+ signed = fst $ objectToSignedExact+ (\b -> (fromRight BS.empty $ sign (Just blinder) (Just SHA256) secKey b, sigAlg, ()))+ cert+ return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey)++{- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for +-- gemini, we should use this?+import qualified Data.ByteArray as BA++generateSelfSigned :: String -> IO ClientCert+generateSelfSigned cn = do+ secKey <- generateSecretKey+ currentTime <- timeConvert <$> timeCurrent+ let pubKey = toPublic secKey+ dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]+ sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519+ -- TODO: think about correct validity dates+ to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 1, periodMonths = 0, periodDays = 0}+ from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0}+ cert = Certificate+ { certVersion = 3+ , certSerial = 0+ , certSignatureAlg = sigAlg+ , certIssuerDN = dn+ , certSubjectDN = dn+ , certValidity = (from, to)+ , certPubKey = PubKeyEd25519 pubKey+ , certExtensions = Extensions Nothing+ }+ signed = fst $ objectToSignedExact+ (\b -> (BS.pack . BA.unpack $ sign secKey pubKey b, sigAlg, ()))+ cert+ return (CertificateChain [signed], PrivKeyEd25519 secKey)+-}
+ ClientSessionManager.hs view
@@ -0,0 +1,54 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module ClientSessionManager+ ( clientSessionManager+ , ClientSessions+ , newClientSessions+ , lookupClientSession+ ) where++import Control.Concurrent+import Data.Map (fromAscList, toAscList)+import Network.TLS++import Data.Hourglass (timeAdd)+import Time.System (timeCurrent)+import Time.Types (Elapsed(..), Seconds(..))++import qualified Data.Map as Map++import Fingerprint++type ClientSessions = MVar (Map.Map (HostName, Maybe Fingerprint) (Elapsed, (SessionID, SessionData)))++newClientSessions :: IO ClientSessions+newClientSessions = newMVar Map.empty++clientSessionManager :: Int -> ClientSessions -> Maybe Fingerprint -> SessionManager+clientSessionManager lifetime sess fp = SessionManager+ (\_ -> return Nothing)+ (\_ -> return Nothing)+ insert+ delete+ where+ insert sid sd@SessionData{ sessionClientSNI = Just sni } = do+ now <- timeCurrent+ let expire = now `timeAdd` Seconds (fromIntegral lifetime)+ modifyMVar_ sess $ return .+ Map.insert (sni, fp) (expire,(sid,sd)) .+ fromAscList . filter (\(_,(t,(_,_))) -> t >= now) . toAscList+ insert _ _ = return ()+ delete sid =+ modifyMVar_ sess $ return .+ fromAscList . filter (\(_,(_,(sid',_))) -> sid /= sid') . toAscList++lookupClientSession :: HostName -> Maybe Fingerprint -> ClientSessions -> IO (Maybe (SessionID, SessionData))+lookupClientSession sni fp sess = (snd <$>) . Map.lookup (sni,fp) <$> readMVar sess
+ Command.hs view
@@ -0,0 +1,475 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-}++module Command+ ( commands+ , normaliseCommand+ , helpText+ , helpOn+ , expandHelp+ , showMinPrefix+ ) where++import Control.Monad (msum)+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe, isNothing)+import Safe (atMay, headMay, maximumBound, readMay)+import System.FilePath ((</>))++import qualified Data.Text.Lazy as T++import ANSIColour++commands :: Bool -> [String]+commands restricted = metaCommands ++ navCommands ++ infoCommands +++ actionCommands restricted ++ otherCommands+ where+ metaCommands = ["help", "quit"]+ navCommands = ["repeat", "mark", "inventory", "identify", "add", "delete"]+ infoCommands = ["show", "page", "uri", "links", "mime"]+ unsafeActionCommands = ["save", "view", "browse", "!", "|", "||", "||-"]+ safeActionCommands = ["cat"]+ actionCommands True = safeActionCommands+ actionCommands False = unsafeActionCommands ++ safeActionCommands+ otherCommands = ["commands", "log", "repl", "alias", "set", "at"]++normaliseCommand :: String -> Maybe String+normaliseCommand partial =+ headMay . filter (isPrefixOf partial) $ commands False++helpText :: [String]+helpText =+ [ withBoldStr "Navigation"+ , "----------"+ , "Enter a URI to go to it, then enter numbers to follow links."+ , ""+ , "You can navigate to other locations as follows:"+ , " ../foo.gmi : Relative URI"+ , " < , {-back} : Back"+ , " > , {-forward} : Forward"+ , " 'foo : Marked location"+ , " ~ , {-next} : Next queue item"+ , " } : Next unvisited link"+ , " <} : Next unvisited link of parent"+ , ""+ , "See \"help targets\" for more."+ , ""+ , withBoldStr "Commands"+ , "--------"+ , "Meta commands:"+ , " {-quit} : Quit"+ , " {-help [TOPIC]} : This help, or help on a command or other topic"+ , "Navigation commands:"+ , " {-mark MARK} : Mark location as \"'MARK\""+ , " 3-5 {-add} : Append links to queue"+ , " {-repeat} : Make fresh request for current location"+ , " {-inventory} : Show history and queue"+ , " {-identify [ID]} : Select/create identity (client certificate)"+ , " {-repl} : Enter loop making queries at current uri"+ , "Action commands:"+ , " {-show} : Print text"+ , " {-page} : Page text"+ , " {-links} : Show links"+ , " {-uri} : Show uri"+ , " {-save [FILENAME]} : Save data, by default in {~/saves/}"+ , " {-| CMD} : Pipe data to shell command"+ , " {-! CMD} : Run shell command on data"+ , " {-|| [CMD]} : Pipe rendered text to $PAGER or command"+ , " {-view} : Run mailcap command on data"+ , " {-browse [CMD] [ARGS]} : Run command on uri (default: $BROWSER)"+ , ""+ , "Commands and marks may be abbreviated; e.g. \"l\" is short for {links}."+ , ""+ , "Commands which act on the current location by default"+ , "can also be given a target before the command, e.g.:"+ , " 3 {|} mpv - : Request link 3 and pipe the stream to command 'mpv -'"+ , " << {save} blah : Save data from history item before last"+ , " 2 {browse} lynx : Run \"lynx [uri-of-link-2]\""+ , " / {mark} root : Mark the root of the current site as 'root"+ , " / {identify} asdf : Use identity \"asdf\" for all of current site"+ , "Use \"help targets\" to get full details on this notation."+ , ""+ , "Spaces around the command can often be omitted, e.g.:"+ , " 2a0 : Add link 2 to start of queue"+ , ""+ , withBoldStr "Miscellaneous"+ , "-------------"+ , "Use ^C to interrupt requests and abort prompts and so forth."+ , "^C will never quit the program."+ , ""+ , "Use enter or 'q' to quit the pager, and space or 1-9 or 'h' to advance,"+ , "and '>' to queue commands. See \"{help} {pager}\" for further details and commands."+ , ""+ , "There are a few more obscure commands;"+ , "use {commands} to show them all, and \"{help} [command]\" for information."+ , ""+ , "Use \"{help} {topics}\" for a list of further help topics."+ , ""+#ifdef WINDOWS+ , withBoldStr "Windows"+ , "-------------"+ , "diohsc was written with unix-like systems in mind."+ , "Various commands may not work well on Windows,"+ , "and some of the help text may be unhelpful. Sorry about that."+ , "Please do write to mbays@sdf.org with your complaints/bugreports."+#endif+ ]++topics :: [String]+topics = ["targets", "queue", "pager", "trust", "configuration"+ , "default_action", "proxies", "geminators", "render_filter"+ , "pre_display", "log_length", "max_wrap_width", "no_confirm"+ , "copying", "topics"]++helpOn :: String -> [String]+helpOn s =+ fromMaybe ["Unknown command/topic; use {commands} and \"{help} {topics}\" for lists."] $ msum+ [ commandHelp <$> normaliseCommand s+ , topicHelp <$> completeTopic ]+ where+ completeTopic = headMay . filter (isPrefixOf s) $ topics ++ topicSynonyms+ topicSynonyms = ["geminator", "proxy"]+ topicHelp = \case+ "topics" -> ('{' :) . (++"}") <$> topics+ "targets" ->+ [ "Many commands can be given a target or targets to operate on."+ , "These are written before the command."+ , "A target consists of an optional base target optionally followed by modifiers."+ , ""+ , "Base target:"+ , " example.com , gemini://example.com : absolute URI"+ , " 3 : link from current"+ , " .. , ./foo , ../foo , /foo , ?foo : URI relative to current location"+ , " 'example , 'ex , 'e : location marked with \"mark example\""+ , " '' : location last jumped away from"+ , " ~ , {-next} : next queue item"+ , " $5 : log item"+ , " If no base target is given, the current location is used as the base."+ , ""+ , "Modifiers"+ , " /foo , ?foo : URI relative to base"+ , " _3 : link from base"+ , " < , {-back} : origin of base"+ , " > , {-forward} : location of which base is the origin (if any)"+ , " ] : link after \">\""+ , " [ : link before \">\""+ , " The \"origin\" of a location reached via a link is the link's source."+ , " Similarly for relative URIs. Other locations have no origin."+ , ""+ , "Example session demonstrating basic navigation:"+ , " 'ex?foo : Go to mark \"'example\", but with query string set to \"foo\"."+ , " 5 : Go to link 5 from 'ex?foo."+ , " < : Go back to 'ex?foo."+ , " ] : Go to link 6 from 'ex?foo."+ , " <_2 : Go to link 2 from 'ex?foo."+ , " <] : Go to link 3 from 'ex?foo. Call this location B."+ , " 7 : Go to link 7 from B. Call this location C."+ , " <<] : Go to link 4 from 'ex?foo. C is now set as the jump mark \"''\"."+ , " ''<] : Go to link 8 from B."+ , ""+ , "Numbered, range, and search targets:"+ , " The specifiers \"$\", \"~\", \"<\", \">\", \"[\" and \"]\" all accept"+ , " a number, or repetition of the symbol, to specify a particular item."+ , " e.g \"~~~\" and \"~3\" both refer to the third queue entry."+ , ""+ , " Specify ranges with \"-\"; start and/or end may be omitted."+ , " Specify first match of pattern with \"^pattern^\","+ , " or all matches with \"^^pattern^\"."+ , " Specify multiple items or ranges by separating with \",\"."+ , " Examples: \"1,3-5,^pattern^-\" refers to links 1,3,4,5 and all links from the"+ , " the first match of pattern onwards, and \"~-\" refers to the whole queue."+ , ""+ , " Patterns are (extended) regular expressions (see `man 7 regex`)."+ , " Matching is case-insensitive unless pattern contains an uppercase character."+ , " Space and '^' in patterns must be backslash-escaped."+ , " The terminating \"^\" may be omitted."+ , ""+ , "Restricting to unvisited:"+ , " \"}\", \"{\", and \"*\" work like \"]\", \"[\", and \"_\","+ , " but consider only unvisited links. Example: \"*-a\" adds all unvisited links."+ , ""+ , "See also: {mark}, {queue}, {alias}"+ ]+ "queue" ->+ [ "The queue is a list of uris, which you can add to with \"add\""+ , "and visit using {next} or by referring to them as \"~\", \"~3\", etc."+ , ""+ , "One way to use this: Whenever you see multiple links you would like to read,"+ , "where in a tabbed browser you might open a new background tab for each,"+ , "you can add them to the queue and then read each in turn."+ , "A queue item is deleted by {delete} or any command which requests the uri;"+ , "use marks and history (including \"$^pattern\") to revisit old entries."+ , ""+ , "You can use e.g. \"-a0\" to add all links to the *start* of the queue."+ , "The queue can be manipulated with {add}; e.g."+ , "\"~4-a0\" shifts queue entries ~4 onwards to the start of the queue."+ , "The queue can also be used to build a list of targets for batch processing;"+ , "e.g. you can add the desired uris to the queue then use \"~-|grep pattern\"."+ , ""+ , "Any uris written to {~/queue} (one uri per line)"+ , "will be added to the queue, after which that file will be deleted."+ , "This allows e.g. an rss reader to add to the queue of a diohsc instance." ]+ "pager" ->+ [ "Keys for the inbuilt pager:"+ , " space : advance one page"+ , " h : advance half a page"+ , " 1-9 : advance by the specified number of lines"+ , " c : continue to end"+ , " q, enter : quit pager"+ , " :, > : enter a diohsc command to be executed after quitting the pager"+ , " example: \":3a\" adds link 3 to the uri queue"+ , "There is no way to go back."+ , "The {||} command can be used to invoke an alternative pager."+ , "See also: {default_action}" ]+ "proxies" ->+ [ "{set} {proxy} SCHEME HOST:PORT : Set proxy for requests using given scheme"+ , "{set} {proxy} SCHEME : unset proxy"+ , ""+ , "Example:"+ , " set proxy gopher 127.0.0.1:1965"+ , "to use an Agena ({%Yellow%https://tildegit.org/solderpunk/agena}) instance"+ , "running locally with its default configuration." ]+ "proxy" -> topicHelp "proxies"+ "trust" ->+ [ "A valid certificate chain presented by a server will be trusted if the root"+ , "is a Certificate Authority certificate found under {~/trusted_certs/}."+ , "Otherwise you will be asked whether to trust the server certificate."+ , "If you accept, it will be saved in {~/known_hosts/},"+ , "and you will be warned if the server ever presents a different certificate." ]+ "configuration" ->+ [ "There are some commandline options; try \"diohsc --help\"."+ , ""+ , "There are also some options which can be set at run-time;"+ , "use {set} for a list and their current values. Each option is a help topic."+ , ""+ , "{~/diohscrc} may contain commands to run at startup,"+ , "e.g. setting aliases and identities and the options mentioned above;"+ , "each line of the file is interpreted as a command."+ , "See diohscrc.sample in the source distribution for some suggestions."+ , ""+ , "The files in {~/} can be edited."+ , "To change the default save directory,"+ , "make {~/saves} a symlink."+ , "To disable command history, make {~/commandHistory}"+ , "a symlink to /dev/null ; similarly for inputHistory and log."+ , "(Alternatively, use the --ghost commandline option.)"+ , ""+ , "The line editor can be configured:"+ , "see {%Yellow%https://github.com/judah/haskeline/wiki/UserPreferences}"+ , ""+ , "See also: {alias}, {identify}, {set}, {trust}" ]+ "default_action" ->+ [ "{set} {default_action} COMMAND [ARGS]: set action used on going to a new location."+ , "The default is \"page\". You may prefer \"||\", or e.g. \"|| less\"."+ , "See also: {configuration}" ]+ "geminator" -> topicHelp "geminators"+ "geminators" ->+ [ "{set} {geminators} MIMETYPE COMMAND: set shell command for conversion to text/gemini."+ , "{set} {geminators} MIMETYPE: unset geminator."+ , ""+ , "The body of a response with a matching mimetype is piped through the command,"+ , "and the output used as gemini text for rendering (\"page\", \"||\", etc),"+ , "and for obtaining links."+ , ""+ , "Mimetype is a regular expression. The first matching geminator will be used."+ , ""+ , "Examples:"+ , " set gem text/markdown md2gemini -l paragraph"+ , " (see {%Yellow%https://github.com/makeworld-the-better-one/md2gemini})"+ , " set gem (text|application)/(html|xml|xhtml.*) html2gmi -me"+ , " (see {%Yellow%https://github.com/LukeEmmet/html2gmi})"+ , " set gem image/jpeg echo '```' && jp2a --colors - && echo '```'"+ , " set gem image/.* echo '```' && convert - jpeg:- | jp2a --colors - && echo '```'"+ , " (ascii-art preview of images)" ]+ "render_filter" ->+ [ "{set} {render_filter} COMMAND: set shell command to filter rendered text through."+ , "{set} {render_filter}: unset render_filter."+ , ""+ , "Whenever the rendered text of a page would be used (\"page\", \"||\", etc),"+ , "it will be piped through this command first."+ , ""+ , "Example:"+ , " set render_filter stdbuf -o0 uni2ascii -BPq"+ , " (best-effort substitution of utf8 with pure-ascii equivalents)" ]+ "pre_display" ->+ [ "{set} {pre_display} pre: suppress alt text of preformatted blocks"+ , "{set} {pre_display} alt: display only alt text of preformatted blocks"+ , "{set} {pre_display} both: display alt text and contents of preformatted blocks" ]+ "log_length" ->+ [ "{set} {log_length} N: set number of items to store in log"+ , "{set} {log_length} 0: clear log and disable logging"+ , "see also: {log}" ]+ "max_wrap_width" ->+ [ "{set} {max_wrap_width} N: set maximum width for text wrapping" ]+ "no_confirm" ->+ [ "{set} {no_confirm} true: disable confirmation prompts for certain commands"+ , "{set} {no_confirm} false: re-enable confirmation prompts"+ , ""+ , "You are advised not to enable this until you are familiar with the behaviour of"+ , "the potentially dangerous commands like \"|\" and \"!\"" ]+ "copying" ->+ [ "diohsc is free software, released under the terms of the GNU GPL v3 or later."+ , "You should have obtained a copy of the licence as the file COPYING."+ , "This version of diohsc is copyright Martin Bays <mbays@sdf.org> 2020." ]+ t -> ["No help on topic \"" <> t <> "\"."]+ commandHelp = \case+ "help" ->+ [ "help: show general help"+ , "help COMMAND: show help on command" ]+ "quit" -> ["quit"]+ "repeat" -> ["TARGET repeat: request target"]+ "mark" ->+ [ "TARGET {mark} MARK: mark target, which can subsequently be specified as 'MARK."+ , "Marks are saved in {~/marks}. To delete a mark, remove the corresponding file."+ , ""+ , "Marks '0 to '9 are special per-session marks:"+ , "they are not saved, and they are listed in the output of \"inventory\"" ]+ "inventory" ->+ [ "{inventory}: show current queue (~N), path (<N,>N), and session marks ('N)."+ , "see also: {log}" ]+ "log" ->+ [ "{log}: show log."+ , "TARGETS {log}: add targets to log."+ , ""+ , "The \"log\" is a list of visited URIs."+ , "Its entries can be referenced with \"$\"."+ , ""+ , "URIs added to the log are considered \"visited\"; they are shown in a"+ , "different colour and can be referenced with \"*\", \"{\", and \"}\"."+ , ""+ , "The log is saved in {~/log}."+ , "To prevent excessive resource use and limit the privacy implications,"+ , "the length of the log is bounded by the option {log_length}." ]+ "identify" ->+ [ "TARGET {identify} [IDENTITY]: identify (as identity) for all future"+ , " requests to target and to paths below target."+ , " If identity doesn't exist, create a new identity."+ , ""+ , "An \"identity\" is a cryptographic certificate,"+ , "sent to the server to securely identify you to the server."+ , "An identity which will be used for a request is indicated as \"{%Yellow%uri}[{%Green%identity}]\"."+ , "See also: {configuration}" ]+ "add" ->+ [ "TARGETS {add}: add targets to the end of the queue."+ , "TARGETS {add} 0: add targets to the start of the queue."+ , "TARGETS {add} N: add targets to the queue after entry ~N."+ , "See also: {queue}, {targets}." ]+ "delete" ->+ [ "TARGETS {delete}: delete specified uris from queue."+ , "e.g. \"~3-5,7d\" to delete certain entries, or \"~-d\" to clear the queue,"+ , "or \"-d\" to delete all queue entries which are links from the current location." ]+ "show" -> ["TARGET {show}: show rendered text of target, without paging."]+ "page" -> [ "TARGET {page}: page rendered text of target."+ , "See also: {pager}, {default_action}" ]+ "uri" -> ["TARGET {uri}: show absolute uri of target."]+ "links" -> ["TARGET {links}: show list of links of target."]+ "mime" -> [ "TARGET {mime}: show mime type of target."+ , "Note: any request this causes will be closed after receiving the header." ]+ "save" -> [ "TARGET {save} [PATH]: save body."+ , "If path is omitted or relative, it is based on {~/saves/} ."+ , "The last segment of the uri path is used as a default filename." ]+ "view" -> [ "TARGET {view}: run \"run-mailcap --view\" on body."+ , "The action is determined by the mime-type; see the run-mailcap manpage." ]+ "browse" -> [ "TARGET {browse}: run command given by environment variable $BROWSER on uri."+ , "TARGET {browse} COMMAND: run given shell command on uri."+ , "%s is substituted with the uri"+ , "if no %s appears, the uri is used as an additional final argument."+ , "A literal '%' can be escaped as '%%'." ]+ "!" -> [ "TARGET {!} COMMAND: run shell command on body."+ , "The line after '!' is used as a shell command after transforming as follows:"+ , "%s is substituted with the path to a temporary file containing the target;"+ , "if no %s appears, this path is appended to the end (separated by a space)."+ , "A literal '%' can be escaped as '%%'."+ , "Environment variables $URI and $MIMETYPE are set to correspond to the target." ]+ "|" -> [ "TARGET {|} COMMAND: pipe body through shell command."+ , "Environment variables $URI and $MIMETYPE are set to correspond to the target." ]+ "||" -> [ "TARGET {||} [COMMAND]: pipe rendered text through shell command."+ , "The default command is the contents of the environment variable $PAGER."+ , "Environment variables $URI and $MIMETYPE are set to correspond to the target."+ , "See {||-} for a variant which does not produce ansi escapes."+ , "See also: {default_action}, {||-}" ]+ "||-" -> [ "TARGET {||-} [COMMAND]: pipe plain rendered text through shell command."+ , "This is the same as {||}, but no ansi escapes are included in the text." ]+ "cat" -> [ "TARGET {cat}: print raw contents of location" ]+ "commands" -> [ "{commands}: show list of commands and aliases,"+ , "in order of priority when expanding abbreviations,"+ , "and show the shortest permissible abbreviations."+ , "See also: {alias}"]+ "repl" -> [ "TARGET {repl}: enter read-eval-print-loop,"+ , "in which each line of input is used as a query string at the target."+ , "To return to normal command mode, enter an empty query or ^C or ^D." ]+ "alias" ->+ [ "{alias} ALIAS COMMANDLINE: add an alias"+ , "{alias} ALIAS: delete an existing alias"+ , "The commandline may include targets and/or a command."+ , "Examples:"+ , " alias up .. : then \"up\" translates to \"..\", and e.g. \"u add\" to \".. add\""+ , " alias Mpv |mpv --cache-secs 5 - : then \"2M\" will stream link 2 to mpv"+ , " with this sane caching (mpv's default cache size is 150M!)"+ , "You can put alias commands in {~/diohscrc};"+ , "see \"{help} {configuration}\"." ]+ "set" -> [ "{set}: show settable options and their current values"+ , "{set} OPTION VALUE [..]: set option"+ , "Try using {help} on the options."+ , "See also: {configuration}"+ ]+ "at" -> [ "TARGET {at} COMMANDLINE: request target then execute commandline based there."+ , ""+ , "Example: 'example at *- add: add all unvisited links from 'example to queue." ]+ c -> ["No help on command \"" <> c <> "\"."]++showMinPrefix :: Bool -> [String] -> String -> String+showMinPrefix ansi ss s =+ let n = maximumBound 0 $ commonPrefLen s <$> takeWhile (/= s) ss+ (s',s'') = splitAt (n+1) s+ in if n == length s+ then s <> applyIf ansi (withColourStr Red) " [Not typable!]"+ else applyIf ansi withBoldStr s' <>+ applyIf (not $ ansi || null s'') (('[':) . (++"]")) s''+ where+ commonPrefLen :: Eq a => [a] -> [a] -> Int+ commonPrefLen bs cs = head [ n+ | n <- [0..]+ , let mb = atMay bs n+ , let mc = atMay cs n+ , isNothing mb || isNothing mc || mb /= mc+ ]++-- indicate initial prefix of commands/aliases in string, marked as {command},+-- and topics marked as {topic},+-- and path from userdir, marked as {~/path}.+-- Use {-command blah} in a table, it adds spaces as necessary.+-- e.g. {%Yellow%str} prints str in yellow (when ansi).+-- (if '{' is used in another way, give up and acts as the identity)+expandHelp :: Bool -> [String] -> String -> String -> String+expandHelp ansi aliases userDir = expandHelp' where+ cs = aliases ++ commands False+ expandHelp' s+ | (pre,'{':s') <- break (== '{') s+ , (twixt,'}':post) <- break (== '}') s'+ = let sub = case twixt of+ '~':'/':path -> userDir </> path+ '-':cBlah | (c,blah) <- break (== ' ') cBlah+ , c `elem` cs ->+ let c' = showMinPrefix ansi cs c+ missing = length c + 3 - visibleLength (T.pack c')+ in c' <> blah <> replicate missing ' '+ '%':t' | (colStr,'%':str) <- break (== '%') t'+ , Just col <- readMay colStr ->+ applyIf ansi (withColourStr col) str+ c | c `elem` cs -> showMinPrefix ansi cs c+ t | t `elem` topics -> showMinPrefix ansi (cs ++ topics) t+ _ -> twixt+ in pre <> sub <> expandHelp' post+ | otherwise = s
+ CommandLine.hs view
@@ -0,0 +1,203 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Safe #-}++module CommandLine+ ( CommandLine(..)+ , CommandArg(..)+ , ElemsSpecs+ , PTarget(..)+ , parseCommandLine+ , parseCommand+ , resolveElemsSpecs+ ) where++import Control.Monad (guard, liftM2, mzero)+import Data.Bifunctor (first)+import Data.Char (isAlphaNum)+import Data.List (foldl')+import Data.Maybe (maybeToList)+import Safe (atMay, headMay)+import Text.Parsec+import Text.Parsec.String (Parser)++data ElemSpec+ = ESNum Int+ | ESSearch String+ deriving (Eq,Ord,Show)++data ElemsSpec+ = EsSElemSpec ElemSpec+ | EsSRange (Maybe ElemSpec) (Maybe ElemSpec)+ | EsSSearch String+ deriving (Eq,Ord,Show)++type ElemsSpecs = [ElemsSpec]++elemsSpecsNum :: Int -> ElemsSpecs+elemsSpecsNum = (:[]) . EsSElemSpec . ESNum++resolveElemsSpecs :: String -> (String -> a -> Bool) -> [a] -> ElemsSpecs -> Either String [a]+resolveElemsSpecs typeStr match as ess =+ concat <$> mapM resolveElemsSpec ess >>= \case+ [] -> Left $ "No such " <> typeStr+ as' -> return as'+ where+ resolveElemsSpec (EsSElemSpec es) =+ maybeToList . atMay as <$> resolveES es+ resolveElemsSpec (EsSRange mes1 mes2) = do+ mns1 <- mapM resolveES mes1+ mns2 <- mapM resolveES mes2+ return $ case liftM2 (>) mns1 mns2 of+ Just True -> reverse . maybe id drop mns2 $ maybe id (take . (+ 1)) mns1 as+ _ -> maybe id drop mns1 $ maybe id (take . (+ 1)) mns2 as+ resolveElemsSpec (EsSSearch s) = return $ filter (s `match`) as++ resolveES :: ElemSpec -> Either String Int+ resolveES (ESNum n) = return $ n - 1+ resolveES (ESSearch s) =+ maybe (Left $ "No " <> typeStr <> " matches pattern: " ++ s) Right $+ headMay . map fst . filter snd . zip [0..] $ (s `match`) <$> as++data PTarget+ = PTargetCurr+ | PTargetJumpBack+ | PTargetMark String+ | PTargetAbs String+ | PTargetLog ElemsSpecs+ | PTargetQueue ElemsSpecs+ | PTargetAncestors PTarget ElemsSpecs+ | PTargetDescendants PTarget ElemsSpecs+ | PTargetChild+ { ptcIncreasing :: Bool, ptcNoVisited :: Bool+ , ptcTarget :: PTarget, ptcSpecs :: ElemsSpecs }+ | PTargetLinks+ { ptlNoVisited :: Bool+ , ptlTarget :: PTarget, ptlSpecs :: ElemsSpecs }+ | PTargetRef PTarget String+ deriving (Eq,Ord,Show)++data CommandArg = CommandArg+ { commandArgArg :: String+ , commandArgLiteralTail :: String+ } deriving (Eq,Ord,Show)++data CommandLine+ = CommandLine (Maybe PTarget) (Maybe (String,[CommandArg]))+ deriving (Eq,Ord,Show)++parseCommandLine :: String -> Either String CommandLine+parseCommandLine = first show . parse (spaces >> commandLine <* eof) ""++parseCommand :: String -> Either String String+parseCommand = first show . parse command ""++commandLine :: Parser CommandLine+commandLine = choice+ [ char '#' >> many anyChar >> return (CommandLine Nothing Nothing)+ , liftM2 CommandLine (optionMaybe target) $ spaces >> optionMaybe commandAndArgs+ ]++commandAndArgs :: Parser (String, [CommandArg])+commandAndArgs =+ liftM2 (,) command $ spaces >> commandArgs++commandArgs :: Parser [CommandArg]+commandArgs = liftM2 (flip CommandArg)+ (lookAhead $ many1 anyChar) commandArg `sepEndBy` spaces++command :: Parser String+command = choice+ [ liftM2 (:) (oneOf "|!") (many $ oneOf "|!-")+ , many1 letter ]++commandArg :: Parser String+commandArg = escapedArg++escapedArg :: Parser String+escapedArg = escapedWhile $ noneOf " "++escapedWhile :: Parser Char -> Parser String+escapedWhile c = many1 $ (char '\\' >> anyChar) <|> c++nat :: Parser Int+nat = read <$> many1 digit++countMany :: Parser String -> Parser Int+countMany s = (s >> (+ 1) <$> countMany s) <|> return 0++patt :: Parser String+patt = escapedWhile (noneOf "^ ") <* optional (char '^')++elemSpec :: Parser ElemSpec+elemSpec = choice+ [ ESNum <$> nat+ , char '^' >> ESSearch <$> patt ]++elemsSpec :: Parser ElemsSpec+elemsSpec = choice+ [ try $ string "^^" >> EsSSearch <$> patt+ , do+ mess1 <- optionMaybe elemSpec+ choice+ [ char '-' >> EsSRange mess1 <$> optionMaybe elemSpec+ , maybe mzero (return . EsSElemSpec) mess1 ]+ ]++elemsSpecs :: Parser ElemsSpecs+elemsSpecs = sepBy1 elemsSpec (char ',')++elemsSpecsBy :: Parser String -> Parser ElemsSpecs+elemsSpecsBy s = s >> choice+ [ elemsSpecs+ , elemsSpecsNum . (+ 1) <$> countMany s ]++escapedArgStartingWith :: Parser Char -> Parser String+escapedArgStartingWith p = liftM2 (:) p (escapedArg <|> return "")++ref :: String -> Parser String+ref = escapedArgStartingWith . oneOf++baseTarget :: Parser PTarget+baseTarget = choice+ [ PTargetLinks False PTargetCurr <$> elemsSpecs+ , PTargetRef PTargetCurr <$> ref "./?"+ , PTargetLog <$> elemsSpecsBy (string "$")+ , PTargetQueue <$> elemsSpecsBy (string "~")+ , char '\'' >> choice+ [ char '\'' >> return PTargetJumpBack+ , PTargetMark <$> many1 alphaNum ]+ , try $ do+ s <- escapedArgStartingWith alphaNum -- scheme required for other uris+ guard . not $ all (\c -> c `elem` "!|-" || isAlphaNum c) s+ return $ PTargetAbs s+ , return PTargetCurr ]++targetMod :: Parser (PTarget -> PTarget)+targetMod = choice+ [ flip PTargetAncestors <$> elemsSpecsBy (string "<")+ , flip PTargetDescendants <$> elemsSpecsBy (string ">")+ , flip (PTargetChild True False) <$> elemsSpecsBy (string "]")+ , flip (PTargetChild True True) <$> elemsSpecsBy (string "}")+ , flip (PTargetChild False False) <$> elemsSpecsBy (string "[")+ , flip (PTargetChild False True) <$> elemsSpecsBy (string "{")+ , optional (char '_') >> flip (PTargetLinks False) <$> elemsSpecs+ , char '*' >> flip (PTargetLinks True) <$> elemsSpecs+ , flip PTargetRef <$> ref "/?"+ ]++target :: Parser PTarget+target = do+ base <- baseTarget+ mods <- many targetMod+ guard . not $ base == PTargetCurr && null mods+ return $ foldl' (flip ($)) base mods
+ Fingerprint.hs view
@@ -0,0 +1,28 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++-- | Stupid module to avoid orphan instances, redefining Fingerprint from +-- x509-validation to have an Ord instance.+module Fingerprint (Fingerprint(..), fingerprint) where++import Data.ASN1.Types (ASN1Object)++import qualified Data.X509 as X+import qualified Data.X509.Validation as X+import qualified Data.ByteString as BS++newtype Fingerprint = Fingerprint BS.ByteString+ deriving (Eq,Ord,Show)++getFingerprint :: (Show a, Eq a, ASN1Object a) => X.SignedExact a -> X.HashALG -> Fingerprint+getFingerprint s a = let X.Fingerprint fp = X.getFingerprint s a in Fingerprint fp++fingerprint :: X.SignedCertificate -> Fingerprint+fingerprint = (`getFingerprint` X.HashSHA256)
+ GeminiProtocol.hs view
@@ -0,0 +1,392 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}++module GeminiProtocol where++import Control.Concurrent+import Control.Exception+import Control.Monad (guard, mplus, unless, when)+import Data.Default.Class (def)+import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix, transpose)+import Data.Maybe (fromMaybe)+import Data.Hourglass+import Data.X509+import Data.X509.Validation hiding (Fingerprint(..), getFingerprint)+import Data.X509.CertificateStore+import Network.Socket (AddrInfo(..), Socket, SocketType(..), SocketOption(..)+ , close, connect, defaultHints, getAddrInfo, setSocketOption, socket)+import Network.TLS as TLS+import Network.TLS.Extra.Cipher+import Safe+import System.FilePath+import Time.System++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC++import qualified Codec.MIME.Type as MIME+import qualified Codec.MIME.Parse as MIME+import qualified Data.Map as M+import qualified Data.Set as Set+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T++import BoundedBSChan+import ClientCert+import ClientSessionManager+import Fingerprint+import Identity+import Mundanities+import Request+import ServiceCerts++import URI++import Data.Digest.DrunkenBishop++defaultGeminiPort :: Int+defaultGeminiPort = 1965++data MimedData = MimedData {mimedMimetype :: MIME.Type, mimedBody :: BL.ByteString}+ deriving (Eq,Ord,Show)++showMimeType :: MimedData -> String+showMimeType = TS.unpack . MIME.showMIMEType . MIME.mimeType . mimedMimetype++data ResponseMalformation+ = BadHeaderTermination+ | BadStatus String+ | BadMetaSeparator+ | BadMetaLength+ | BadUri String+ | BadMime String+ deriving (Eq,Ord,Show)++data Response+ = Input { inputHidden :: Bool, inputPrompt :: String }+ | Success { successData :: MimedData }+ | Redirect { permanent :: Bool, redirectTo :: URIRef }+ | Failure { failureCode :: Int, failureInfo :: String }+ | MalformedResponse { responseMalformation :: ResponseMalformation }+ deriving (Eq,Ord,Show)++data InteractionCallbacks = InteractionCallbacks+ { icbDisplayInfo :: [String] -> IO ()+ , icbDisplayWarning :: [String] -> IO ()+ , icbWaitKey :: String -> IO Bool -- ^return False on interrupt, else True+ , icbPromptYN :: Bool -- ^default answer+ -> String -- ^prompt+ -> IO Bool+ }++-- Note: we're forced to resort to mvars because the tls library (tls-1.5.4 at+-- least) uses IO rather than MonadIO in the onServerCertificate callback.+data RequestContext = RequestContext+ InteractionCallbacks+ CertificateStore+ (MVar (Set.Set Fingerprint))+ (MVar (Set.Set Fingerprint))+ FilePath+ Bool+ ClientSessions++initRequestContext :: InteractionCallbacks -> FilePath -> Bool -> IO RequestContext+initRequestContext callbacks path readOnly =+ let certPath = path </> "trusted_certs"+ serviceCertsPath = path </> "known_hosts"+ in do+ mkdirhier certPath+ mkdirhier serviceCertsPath+ certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath+ mTrusted <- newMVar Set.empty+ mIgnoredErrors <- newMVar Set.empty+ RequestContext callbacks certStore mTrusted mIgnoredErrors serviceCertsPath readOnly <$> newClientSessions++requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request+requestOfProxiesAndUri proxies uri =+ let scheme = uriScheme uri+ in if scheme == "file"+ then let filePath path+ | ('/':_) <- path = Just path+ | Just path' <- stripPrefix "localhost" path, ('/':_) <- path' = Just path'+ | otherwise = Nothing+ in LocalFileRequest . unescapeUriString <$> filePath (uriPath uri)+ else do+ host <- M.lookup scheme proxies `mplus` do+ guard $ scheme == "gemini" || "gemini+" `isPrefixOf` scheme+ -- ^people keep suggesting "gemini+foo" schemes for variations + -- on gemini. On the basis that this naming convention should + -- indicate that the scheme is backwards-compatible with + -- actual gemini, we handle them the same as gemini.+ hostname <- uriRegName uri+ let port = fromMaybe defaultGeminiPort $ uriPort uri+ return $ Host hostname port+ return . NetworkRequest host $ uri+++newtype RequestException = ExcessivelyLongUri Int+ deriving Show+instance Exception RequestException++-- |On success, returns `Right lazyResp terminate`. `lazyResp` is a `Response` +-- with lazy IO, so attempts to read it may block while data is received. If +-- the full response is not needed, for example because of an error, the IO +-- action `terminate` should be called to close the connection.+makeRequest :: RequestContext+ -> Maybe Identity -- ^client certificate to offer+ -> Int -- ^bound in bytes for response stream buffering+ -> Request -> IO (Either SomeException (Response, IO ()))+makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)+ certStore mTrusted mIgnoredErrors serviceCertsPath readOnly clientSessions) mIdent bound (NetworkRequest (Host hostname port) uri) =+ let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n"+ uriLength = BS.length requestBytes - 2+ ccfp = clientCertFingerprint . identityCert <$> mIdent+ in if uriLength > 1024 then return . Left . toException $ ExcessivelyLongUri uriLength+ else handle handleAll $ do+ session <- lookupClientSession hostname ccfp clientSessions+ let serverId = if port == defaultGeminiPort then BS.empty else TS.encodeUtf8 . TS.pack . (':':) $ show port+ sessionManager = clientSessionManager 3600 clientSessions ccfp+ params = (TLS.defaultParamsClient hostname serverId)+ { clientSupported = def { supportedCiphers = gemini_ciphersuite }+ , clientHooks = def+ { onServerCertificate = checkServerCert+ , onCertificateRequest = \(_,pairs,_) -> case mIdent of+ Nothing -> return Nothing+ Just ident@(Identity idName (ClientCert chain key)) -> do+ let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs+ conf <- if isTemporary ident || is13 then return True else do+ displayWarning ["Pre-TLS1.3 server: identity " <> idName <> " might be revealed to eavesdroppers!"]+ promptYN False "Identify anyway?"+ return $ if conf then Just (chain,key) else Nothing+ }+ , clientShared = def+ { sharedCAStore = certStore+ , sharedSessionManager = sessionManager }+ , clientEarlyData = Just requestBytes -- ^Send early data (RTT0) if server session allows it+ , clientWantSessionResume = session+ }+ sock <- openSocket+ context <- TLS.contextNew sock params+ handshake context+ sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context+ unless sentEarly . sendData context $ BL.fromStrict requestBytes+ -- print =<< (infoTLS13HandshakeMode <$>) <$> contextGetInformation context+ chan <- newBSChan bound+ let recvAllLazily = do+ r <- recvData context+ unless (BS.null r) $ writeBSChan chan r >> recvAllLazily+ recvThread <- forkFinally recvAllLazily $ \_ ->+ -- |XXX: note that writeBSChan can't block when writing BS.empty+ writeBSChan chan BS.empty >> bye context >> close sock+ lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan+ return $ Right (lazyResp, killThread recvThread)+ where+ handleAll :: SomeException -> IO (Either SomeException a)+ handleAll = return . Left++ openSocket :: IO Socket+ openSocket = do+ let hints = defaultHints { addrSocketType = Stream }+ addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port)+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ ignoreIOErr $+ -- set SO_KEEPALIVE so we detect when a stream connection goes down:+ setSocketOption sock KeepAlive 1+ connect sock $ addrAddress addr+ return sock++ checkServerCert store cache service chain@(CertificateChain signedCerts) = do+ errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks+ (defaultChecks { checkExhaustive = True }) store cache service chain+ if null errors || exists isTrustError errors || null signedCerts+ then return errors+ else do+ ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredErrors+ if ignored then return [] else do+ displayWarning [+ "Certificate chain has trusted root, but validation errors: "+ ++ show errors ]+ displayWarning $ showChain signedCerts+ ignore <- promptYN False "Ignore errors?"+ if ignore+ then modifyMVar_ mIgnoredErrors (return . Set.insert tailFingerprint) >> return []+ else return errors+ where+ exists p = not . all (not . p)++ isTrustError = (`elem` [UnknownCA, SelfSigned])++ -- |error pertaining to the tail certificate, to be ignored if the + -- user explicitly trusts the certificate for this service.+ isTrustableError LeafNotV3 = True+ isTrustableError (NameMismatch _) = True+ isTrustableError _ = False++ tailSigned = head signedCerts+ tailFingerprint = fingerprint tailSigned++ doTofu errors = if not . exists isTrustError $ errors+ then return errors+ else do+ trust <- checkTrust $ filter isTrustableError errors+ return $ if trust+ then filter (\e -> not $ isTrustError e || isTrustableError e) errors+ else errors++ checkTrust :: [FailedReason] -> IO Bool+ checkTrust errors = do+ trusted <- (tailFingerprint `Set.member`) <$> readMVar mTrusted+ if trusted then return True else do+ trust <- checkTrust' errors+ when trust $ modifyMVar_ mTrusted (return . Set.insert tailFingerprint)+ return trust+ checkTrust' :: [FailedReason] -> IO Bool+ checkTrust' errors = do+ let certs = map getCertificate signedCerts+ tailCert = head certs+ serviceString = serviceToString service+ warnErrors = unless (null errors) . displayWarning $+ [ "WARNING: tail certificate has verification errors: " <> show errors ]+ known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr)+ if known == Just tailSigned then do+ displayInfo $ fingerprintPicture tailFingerprint ++ [ "Expires " ++ printExpiry tailCert ]+ return True+ else do+ displayInfo $ showChain signedCerts+ trust <- case known of+ Nothing -> do+ displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]+ warnErrors+ promptYN (null errors) $+ "Trust provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?"+ Just trustedSignedCert -> do+ currentTime <- timeConvert <$> timeCurrent+ let trustedCert = getCertificate trustedSignedCert+ expired = currentTime > (snd . certValidity) trustedCert+ samePubKey = certPubKey trustedCert == certPubKey tailCert+ oldFingerprint = fingerprint trustedSignedCert+ oldInfo = [ "Fingerprint of old certificate: " ++ fingerprintHex oldFingerprint ]+ ++ fingerprintPicture oldFingerprint+ ++ [ "Old certificate " ++ (if expired then "expired" else "expires") +++ ": " ++ printExpiry trustedCert ]+ if expired || samePubKey+ then displayInfo $+ ("A different " ++ (if expired then "expired " else "non-expired ") +++ "certificate " ++ (if samePubKey then "with the same public key " else "") +++ "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo+ else displayWarning $+ ("CAUTION: A certificate with a different public key for " ++ serviceString +++ " was previously explicitly trusted and has not expired!") : oldInfo+ warnErrors+ promptYN (expired || samePubKey) $ "Trust new certificate" <>+ (if readOnly then "" else " (and delete old certificate)") <> "?"+ when (trust && not readOnly) $+ saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr+ return trust++ printExpiry :: Certificate -> String+ printExpiry = timePrint ISO8601_Date . snd . certValidity++ showChain :: [SignedCertificate] -> [String]+ showChain [] = [""]+ showChain signed = let+ sigChain = reverse signed+ certs = map getCertificate sigChain+ showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName+ issuerCN = showCN . certIssuerDN $ head certs+ subjectCNs = map (showCN . certSubjectDN) certs+ hexes = map (fingerprintHex . fingerprint) sigChain+ pics = map (fingerprintPicture . fingerprint) sigChain+ expStrs = map (("Expires " ++) . printExpiry) certs+ picsWithInfo = map (map $ centre 23) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]+ centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' '+ tweenCol = replicate 6 " " ++ [" >>> "] ++ replicate 6 " "+ sideBySide = map concat . transpose+ in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ]+ ++ (sideBySide . intersperse tweenCol $ picsWithInfo)+ ++ zipWith (++) ("": repeat ">>> ") hexes++ printIOErr :: IOError -> IO ()+ printIOErr = displayWarning . (:[]) . show++ fingerprintHex :: Fingerprint -> String+ fingerprintHex (Fingerprint fp) = concat $ hexWord8 <$> BS.unpack fp+ where hexWord8 w =+ let (a,b) = quotRem w 16+ hex = ("0123456789abcdef" !!) . fromIntegral+ in hex a : hex b : ""+ fingerprintPicture :: Fingerprint -> [String]+ fingerprintPicture (Fingerprint fp) = boxedDrunkenBishop fp where+ boxedDrunkenBishop :: BS.ByteString -> [String]+ boxedDrunkenBishop s = ["+-----[X509]------+"]+ ++ (map (('|':) . (++"|")) . lines $ drunkenBishopPreHashed s)+ ++ ["+----[SHA256]-----+"]+ drunkenBishopPreHashed :: BS.ByteString -> String+ drunkenBishopPreHashed = drunkenBishopWithOptions $+ drunkenBishopDefaultOptions { drunkenBishopHash = id }++ -- |those ciphers from ciphersuite_default fitting the requirements+ -- recommended by the gemini "best practices" document:+ -- require ECDHE/DHE (for PFS), and >=SHA2, and AES/CHACHA20.+ gemini_ciphersuite :: [Cipher]+ gemini_ciphersuite =+ [ -- First the PFS + GCM + SHA2 ciphers+ cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384+ , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256+ , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384+ , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256+ , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384+ , cipher_DHE_RSA_CHACHA20POLY1305_SHA256+ , -- Next the PFS + CCM + SHA2 ciphers+ cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256+ , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256+ -- Next the PFS + CBC + SHA2 ciphers+ , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256+ -- TLS13 (listed at the end but version is negotiated first)+ , cipher_TLS13_AES128GCM_SHA256+ , cipher_TLS13_AES256GCM_SHA384+ , cipher_TLS13_CHACHA20POLY1305_SHA256+ , cipher_TLS13_AES128CCM_SHA256+ ]++ parseResponse :: BL.ByteString -> Response+ parseResponse resp =+ let (header, rest) = BLC.break (== '\r') resp+ body = BL.drop 2 rest+ statusString = T.unpack . T.decodeUtf8 . BL.take 2 $ header+ separator = BL.take 1 . BL.drop 2 $ header+ meta = T.unpack . T.decodeUtf8 . BL.drop 3 $ header+ in+ if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination+ else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec+ then MalformedResponse BadMetaSeparator+ else if BL.length header > 1024+3 then MalformedResponse BadMetaLength+ else case readMay statusString of+ Just status | status >= 10 && status < 80 ->+ let (status1,status2) = divMod status 10+ in case status1 of+ 1 -> Input (status2 == 1) meta+ 2 -> maybe (MalformedResponse (BadMime meta))+ (\mime -> Success $ MimedData mime body) $+ MIME.parseMIMEType (TS.pack $+ if null meta then "text/gemini; charset=utf-8" else meta)+ 3 -> maybe (MalformedResponse (BadUri meta))+ (Redirect (status2 == 1)) $ parseUriReference meta+ _ -> Failure status meta+ _ -> MalformedResponse (BadStatus statusString)++makeRequest _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest"
+ Identity.hs view
@@ -0,0 +1,81 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}++module Identity where++import Control.Monad (guard, msum)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (mapMaybe)+import Safe+import System.Directory (listDirectory)++import ANSIColour+import ClientCert+import Prompt+import MetaString+import Mundanities++data Identity = Identity { identityName :: String, identityCert :: ClientCert }+ deriving (Eq,Show)++isTemporary :: Identity -> Bool+isTemporary = null . identityName++normaliseIdName :: String -> Maybe String+normaliseIdName n = headMay (words n)++showIdentity :: MetaString a => Bool -> Identity -> a+showIdentity ansi = showIdentityName ansi . fromString . identityName++showIdentityName :: MetaString a => Bool -> String -> a+showIdentityName ansi name = applyIf ansi (withColourStr Green) $+ "[" <> fromString name <> "]"++loadIdentity :: FilePath -> String -> IO (Maybe Identity)+loadIdentity idsPath idName = (Identity idName <$>) <$> loadClientCert idsPath idName++getIdentity :: Bool -> Bool -> FilePath -> String -> IO (Maybe Identity)+getIdentity noConfirm _ _ "" = runMaybeT $ do+ (guard =<<) $ lift . promptYN (not noConfirm) True $ "Create and use new temporary anonymous identity?"+ Identity "" <$> liftIO (generateSelfSigned "")+getIdentity _ ansi idsPath idName' = runMaybeT $ do+ idName <- MaybeT . return $ normaliseIdName idName'+ msum [ MaybeT $ loadIdentity idsPath idName+ , do+ lift $ do+ putStrLn "Creating a new long-term identity."+ putStrLn $ "We will refer to it as " <> showIdentityName ansi idName <> ", but you may also set a \"Common Name\";"+ putStrLn "this is recorded in the identity certificate, and may be interpreted by the server as a username."+ putStrLn "The common name may be left blank. Use ^C to cancel identity generation."+ clientCert <- liftIO . generateSelfSigned =<< MaybeT (promptLine "Common Name: ")+ liftIO $ mkdirhier idsPath+ lift $ saveClientCert idsPath idName clientCert+ return $ Identity idName clientCert+ ]++getIdentityRequesting :: Bool -> FilePath -> IO (Maybe Identity)+getIdentityRequesting ansi idsPath = runMaybeT $ do+ liftIO . putStrLn $ "Enter the name of an existing identity to use (tab completes),\n\t" +++ "or a name for a new identity to create and use,\n\t" +++ "or nothing to create and use a temporary anonymous identity,\n\t" +++ "or use ^C to abort."+ let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": " + idName <- MaybeT $ promptLineWithCompletions prompt =<< listIdentities idsPath+ MaybeT $ getIdentity True ansi idsPath idName++listIdentities :: FilePath -> IO [String]+listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path)+ where stripCrtExt s = case splitAt (length s - 4) s of+ (s', ".crt") -> Just s'+ _ -> Nothing
+ Makefile view
@@ -0,0 +1,50 @@+VERSION=0.1.1++GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa++.PHONY: build install clean+build:+ @echo "NOTE: All haskell dependencies must be installed for this to build." 1>&2+ @echo "Probably you want to skip directly to \"make install\"" 1>&2+ @echo "" 1>&2+ cabal build+install:+ cabal update && cabal install++diohsc: *.hs+ ghc --make -Wall ${GHCOPTS} diohsc.hs+diohsc-O: *.hs+ ghc -o $@ --make -O -Wall ${GHCOPTS} diohsc.hs+diohsc-dynamic: *.hs+ ghc -o $@ --make -dynamic -Wall ${GHCOPTS} diohsc.hs+diohsc-static:+ ghc -o $@ --make ${GHCOPTS} -optl-static -optl-pthread diohsc.hs+diohsc-prof: *.hs+ ghc -o $@ --make ${GHCOPTS} -rtsopts -prof -fprof-auto diohsc.hs+clean:+ rm diohsc *.hi *.o++dioshc.1: dioshc.1.md+ pandoc --standalone -f markdown -t man < diohsc.1.md >| diohsc.1++dist/diohsc-${VERSION}.tar.gz: *.hs README.md COPYING *.cabal *.sample diohsc.1+ cabal sdist++diohsc-${VERSION}-src.tgz: dist/diohsc-${VERSION}.tar.gz+ cp $< $@++index.gmi: index.md+ cat $< | sed s/README.md/README.gmi/g | sed 's/\$$VERSION/${VERSION}/g' | md2gemini > $@++index.html: index.md+ cat $< | sed s/README.md/README.html/g | sed 's/\$$VERSION/${VERSION}/g' | pandoc --ascii -f markdown -t html > $@++%.gmi: %.md+ md2gemini < $< > $@++%.html: %.md+ pandoc --ascii -f markdown -t html < $< > $@++publish: diohsc-${VERSION}-src.tgz index.gmi index.html README.md README.gmi README.html tutorial/diohsc-tutorial.cast tutorial/diohsc-tutorial.txt+ cp $^ /var/gemini/gemini.thegonz.net/diohsc/+ scp $^ sverige:html/diohsc/
+ Marks.hs view
@@ -0,0 +1,87 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings, TupleSections #-}+{-# LANGUAGE Safe #-}++module Marks where++import Control.Exception (handle)+import Control.Monad (guard, msum)+import Data.Either (partitionEithers)+import Data.List (isPrefixOf)+import System.Directory+import System.FilePath++import qualified Data.Map as Map+import qualified Data.ByteString as BS+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS++import Mundanities+import URI+import Util++data URIWithIdName = URIWithIdName { uriIdUri :: URI, uriIdId :: Maybe String }+ deriving (Eq,Show)++showUriWithId :: URIWithIdName -> String+showUriWithId (URIWithIdName uri Nothing) = show uri+showUriWithId (URIWithIdName uri (Just idName)) = show uri ++ "[" ++ idName ++ "]"++readUriWithId :: TS.Text -> Maybe URIWithIdName+readUriWithId s = msum [ do+ s' <- TS.stripSuffix "]" s+ let (u,i) = TS.breakOn "[" s'+ idName = TS.drop 1 i+ guard . not $ TS.null idName+ uri <- parseUriAsAbsolute $ TS.unpack u+ return . URIWithIdName uri . Just $ TS.unpack idName+ , (`URIWithIdName` Nothing) <$> parseUriAsAbsolute (TS.unpack s) ]++type Marks = Map.Map String URIWithIdName++emptyMarks :: Marks+emptyMarks = Map.empty++lookupMark :: String -> Marks -> Maybe URIWithIdName+lookupMark s marks = do+ (s',uriId) <- Map.lookupGE s marks+ guard $ s `isPrefixOf` s'+ return uriId++insertMark :: String -> URIWithIdName -> Marks -> Marks+insertMark = Map.insert++loadMarks :: FilePath -> IO ([String], Marks)+loadMarks path =+ mapSnd Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path))+ where+ loadMark :: FilePath -> IO (Either String (String, URIWithIdName))+ loadMark filename =+ let filepath = path </> filename+ onIOErr :: IOError -> IO (Either String a)+ onIOErr e = return . Left $+ "Error loading mark from " ++ path ++ ": " ++ show e++ in handle onIOErr $ maybe (Left $+ "Failed to decode uri in:" ++ show filepath)+ (Right . (filename,)) . readUriWithId . TS.strip . TS.decodeUtf8 <$> BS.readFile filepath++saveMark :: FilePath -> String -> URIWithIdName -> IO ()+saveMark path mark uriId =+ let filepath = path </> mark+ in isSubPath path filepath >>? mkdirhierto filepath >> writeFile filepath (showUriWithId uriId)++marksWithUri :: URI -> Marks -> [(String,URIWithIdName)]+marksWithUri uri = Map.toList . Map.filter ((==uri) . uriIdUri)++tempMarks :: [String]+tempMarks = (:[]) <$> ['0'..'9']
+ MetaString.hs view
@@ -0,0 +1,24 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE Safe #-}++-- | Wrap Monoid and IsString into a single typeclass, for convenient+-- polymorphism between Text and String+module MetaString (MetaString, fromString) where++import Data.String (IsString, fromString)+import qualified Data.Text.Lazy as T++class (Monoid a, IsString a) => MetaString a++instance MetaString String+instance MetaString T.Text
+ Mundanities.hs view
@@ -0,0 +1,57 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE Safe #-}++module Mundanities where++import Control.Applicative (Alternative, empty)+import Control.Monad.Catch (MonadMask, handle)+import System.Directory+import System.FilePath+import Control.Monad.IO.Class (MonadIO, liftIO)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.Text as TS+import qualified Data.Text.IO as TS++mkdirhierto :: FilePath -> IO ()+mkdirhierto = mkdirhier . takeDirectory+mkdirhier :: FilePath -> IO ()+mkdirhier = createDirectoryIfMissing True++-- |returns true iff path is contained within the directory dir+isSubPath :: FilePath -> FilePath -> IO Bool+isSubPath dir path = isRelative . makeRelative dir <$> canonicalizePath path++ignoreIOErr :: (MonadIO m, MonadMask m, Monoid a) => m a -> m a+ignoreIOErr = handle ((\_ -> return mempty) :: (Monad m, Monoid a) => IOError -> m a)++warnIOErr :: (MonadIO m, MonadMask m, Monoid a) => m a -> m a+warnIOErr = handle ((\e -> liftIO (print e) >> return mempty) :: (MonadIO m, Monoid a) => IOError -> m a)++ignoreIOErrAlt :: (MonadIO m, MonadMask m, Alternative f) => m (f a) -> m (f a)+ignoreIOErrAlt = handle ((\_ -> return empty) :: (Monad m, Alternative f) => IOError -> m (f a))++warnIOErrAlt :: (MonadIO m, MonadMask m, Alternative f) => m (f a) -> m (f a)+warnIOErrAlt = handle ((\e -> liftIO (print e) >> return empty) :: (MonadIO m, Alternative f) => IOError -> m (f a))++readFileLines :: FilePath -> IO [T.Text]+readFileLines path = ignoreIOErr $+ map T.strip . T.lines . T.decodeUtf8 . BL.fromStrict <$> BS.readFile path++-- delete all but last n lines of file+truncateToEnd :: Int -> FilePath -> IO ()+truncateToEnd n path =+ TS.unlines . dropAllBut n . TS.lines <$> TS.readFile path >>= TS.writeFile path+ where dropAllBut m as = drop (length as - m) as
+ Opts.hs view
@@ -0,0 +1,54 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE Safe #-}++module Opts (usage, parseArgs, Opt(..)) where++import System.Console.GetOpt++import Version++data Opt+ = Restricted+ | Interactive+ | ScriptFile FilePath+ | OptCommand String+ | DataDir FilePath+ | Ghost+ | Ansi+ | NoAnsi+ | Help+ | Version+ deriving (Eq, Ord, Show)++options :: [OptDescr Opt]+options =+ [ Option ['d'] ["datadir"] (ReqArg DataDir "PATH") "data and config directory (default: ~/.diohsc)"+ , Option ['e'] ["command"] (ReqArg OptCommand "COMMAND") "execute command"+ , Option ['f'] ["file"] (ReqArg ScriptFile "PATH") "execute commands from file (\"-\" for stdin)"+ , Option ['i'] ["interact"] (NoArg Interactive) "interactive mode (assumed unless -e/-f used)"+ , Option ['c'] ["colour"] (NoArg Ansi) "use ANSI colour (assumed if stdout is term)"+ , Option ['C'] ["no-colour"] (NoArg NoAnsi) "do not use ANSI colour"+ , Option ['g'] ["ghost"] (NoArg Ghost) "write nothing to filesystem (unless commanded)"+ , Option ['r'] ["restricted"] (NoArg Restricted) "disallow shell and filesystem access"+ , Option ['v'] ["version"] (NoArg Version) "show version information"+ , Option ['h'] ["help"] (NoArg Help) "show usage information"+ ]++usage :: String+usage = usageInfo header options+ where header = "Usage: " ++ programName ++ " [OPTION...] [URI|PATH]"++parseArgs :: [String] -> IO ([Opt],[String])+parseArgs argv =+ case getOpt Permute options argv of+ (o,n,[]) -> return (o,n)+ (_,_,errs) -> ioError (userError (concat errs ++ usage))
+ Pager.hs view
@@ -0,0 +1,60 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}++module Pager where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Writer (WriterT, execWriterT, tell)+import Data.Char (toLower)+import Data.Maybe (fromMaybe, isJust, maybeToList)+import Safe (readMay)+import System.IO (hFlush, stdout)++import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T++import ANSIColour+import Prompt++printLinesPaged :: Int -> Int -> Int -> [T.Text] -> IO [String]+printLinesPaged wrapCol termWidth perpage+ | perpage <= 0 = \_ -> return []+ | otherwise = execWriterT . printLinesPaged' perpage Nothing+ where+ printLinesPaged' :: Int -> Maybe Int -> [T.Text] -> WriterT [String] IO ()+ printLinesPaged' _ mcol [] =+ when (isJust mcol) . liftIO $ putStrLn ""+ printLinesPaged' n mcol (l:ls) =+ let physLines = (+ 1) . max 0 $ (visibleLength l - 1) `div` termWidth+ endCol = visibleLength l `mod` termWidth+ in if n >= physLines+ then do+ when (isJust mcol) . liftIO $ putStrLn ""+ liftIO $ T.putStr l >> hFlush stdout+ printLinesPaged' (n - physLines) (Just endCol) ls+ else do+ let col = fromMaybe 0 mcol+ liftIO . T.putStr $ T.replicate (fromIntegral $ wrapCol - col) " "+ c <- liftIO . promptChar . withBoldStr $ drop (col + 4 - termWidth) " --"+ let rest = l:ls+ case toLower <$> c of+ Nothing -> return ()+ Just 'q' -> return ()+ Just c' | c' == '\n' || c' == '\r' -> return ()+ Just c' | Just m <- readMay (c':""), m > 0 -> printLinesPaged' m Nothing rest+ Just 'c' -> printLinesPaged' 9999 Nothing rest+ Just 'h' -> printLinesPaged' (perpage `div` 2) Nothing rest+ Just c' | c' == ':' || c' == '>' ->+ liftIO (promptLine "Queue command: ") >>= tell . maybeToList >>+ printLinesPaged' 0 Nothing rest+ _ -> printLinesPaged' perpage Nothing rest
+ Prompt.hs view
@@ -0,0 +1,86 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module Prompt+ ( waitKey+ , promptChar+ , promptYN+ , promptPassword+ , promptLine+ , promptLineWithCompletions+ , promptLineWithHistoryFile+ , promptLineInputT+ ) where++import Control.Exception.Base (bracket)+import Control.Monad (void)+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans (lift)+import Data.Bits (xor)+import Data.List (isPrefixOf)+import System.IO++import qualified System.Console.Haskeline as HL++import ANSIColour+import Util++defaultInputSettings :: HL.Settings IO+defaultInputSettings = (HL.defaultSettings :: HL.Settings IO) {HL.complete = HL.noCompletion}++runInputTDefWithAbortValue :: a -> HL.InputT IO a -> IO a+runInputTDefWithAbortValue = runInputTWithAbortValue defaultInputSettings++runInputTWithAbortValue :: HL.Settings IO -> a -> HL.InputT IO a -> IO a+runInputTWithAbortValue settings abortValue =+ HL.handleInterrupt (return abortValue) . HL.runInputT settings . HL.withInterrupt+++waitKey :: String -> IO Bool+waitKey prompt = runInputTDefWithAbortValue False $+ (HL.haveTerminalUI >>? void . HL.waitForAnyKey $ escapePromptCSI prompt) >> return True++promptChar :: String -> IO (Maybe Char)+promptChar prompt = bracketSet (hGetEcho stdin) (hSetEcho stdin) False .+ bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ do+ putStr prompt+ hFlush stdout+ c <- runInputTDefWithAbortValue Nothing . lift $ Just <$> getChar+ putStrLn ""+ return c+ where bracketSet get set v f = bracket get set $ \_ -> set v >> f++promptYN :: Bool -> Bool -> String -> IO Bool+promptYN False def _ = return def+promptYN True def prompt =+ xor def . (`elem` map Just (if def then "nN" else "yY"))+ <$> promptChar (prompt ++ if def then " [Y/n] " else " [y/N] ")++promptPassword :: String -> IO (Maybe String)+promptPassword = runInputTDefWithAbortValue Nothing . HL.getPassword (Just '*') . escapePromptCSI++promptLineInputT :: (MonadIO m, MonadMask m) => String -> HL.InputT m (Maybe String)+promptLineInputT = HL.handleInterrupt (return Nothing) . HL.withInterrupt . HL.getInputLine . escapePromptCSI++promptLine :: String -> IO (Maybe String)+promptLine = HL.runInputT defaultInputSettings . promptLineInputT++promptLineWithCompletions :: String -> [String] -> IO (Maybe String)+promptLineWithCompletions prompt completions =+ HL.runInputT settings $ promptLineInputT prompt+ where settings = defaultInputSettings+ { HL.complete = HL.completeWord Nothing " " $ \w ->+ return . map HL.simpleCompletion $ filter (isPrefixOf w) completions }++promptLineWithHistoryFile :: FilePath -> String -> IO (Maybe String)+promptLineWithHistoryFile path =+ HL.runInputT settings . promptLineInputT+ where settings = defaultInputSettings { HL.historyFile = Just path }
+ README.md view
@@ -0,0 +1,82 @@+# Diohsc: Denotationally Intricate Obedient Haskell Smallnet Client++diohsc [URI]++## Features+* Simple line-based command-response terminal user interface with ANSI colour.+* Terse but combinatorially expressive command language.+* Navigational aids: history, marks, queue.+* Facilities to invoke external commands and use per-scheme proxies.+* Responses streamed to pager or external command.+* Certificate checking with TOFU and/or explicitly trusted CAs.+* Support for TLS resuming, 0RTT, and client certificates.+* All configuration and certificates stored as user-manipulable files.+* Extensive help.++## Building+Install the haskell package manager cabal; e.g. on a debian system:+```+$ sudo apt-get install cabal-install+```++Then in the diohsc directory, run+```+$ cabal update && cabal install+```+The resulting binary will be installed as `~/.cabal/bin/diohsc`.++### Compile-time options+libmagic can be used to detect mimetypes of local files; try:+`cabal install -f Magic`++## Trusting server certificates+First, a disclaimer: do not trust this software to keep you secure. Although +everything seems to be working as intended, and though the libraries it +depends on seem solid, this is "very alpha" software and should not be relied +on.++diohsc uses "Trust On First Use": if a host provides a certificate chain you +do not currently trust, the client will ask for confirmation then add the +certificate for the host to a collection stored in `~/.diohsc/known_hosts/` if +there isn't already one stored; if there is one already stored, it will give +some details and ask if you want to overwrite it with the newly provided one.++You can also trust Certificate Authorities by putting their certificates in +`~/.diohsc/trusted_certs/`. For example, if you want to trust all the +certificates installed on your system,+```+$ ln -s /etc/ssl/certs/* ~/.diohsc/trusted_certs/+```+or if you just want to trust Let's Encrypt:+```+$ mkdir ~/.diohsc/trusted_certs+$ wget -O ~/.diohsc/trusted_certs/lets-encrypt-x3-cross-signed.pem https://letsencrypt.org/certs/lets-encrypt-x3-cross-signed.pem+$ sha256sum ~/.diohsc/trusted_certs/lets-encrypt-x3-cross-signed.pem+e446c5e9dbef9d09ac9f7027c034602492437a05ff6c40011d7235fca639c79a /home/me/.diohsc/trusted_certs/lets-encrypt-x3-cross-signed.pem+```++## Configuration+See diohscrc.sample for ideas for configuration options, in particular+indicating how to make use of third-party software to allow diohsc to access+gopher, and parse markdown and html, and provide ascii-art previews of image+files. Copy the file to ~/.diohsc/diohscrc and uncomment lines as appropriate.++## Multiple instances+Multiple simultaneous diohsc instances may share ~/.diohsc without serious +conflict. However, command history is written only on exit, so the last +instance to exit will determine that history. The log is appended to +continuously, but read only on startup, so logs from simultaneous instances +will be interleaved. Uris in ~/.diohsc/queue are taken by an instance on +startup and whenever it processes a command, and leftover queue items are +written there on exit.++To ensure that an instance won't interfere with other running instances:+either use "--datadir" to specify an alternative directory to ~/.diohsc,+or use the "--ghost" option (which also acts as a "private browsing" mode).++## Running under Windows+It is apparently possible to compile and run diohsc on Windows. However, it +requires a terminal with ANSI and unicode support, which it seems is not the +default situation in even the most recent versions of Windows. On Windows 10, +following the instructions of this link has been reported to work:+https://akr.am/blog/posts/using-utf-8-in-the-windows-terminal
+ Request.hs view
@@ -0,0 +1,43 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE Safe #-}++module Request where++import Data.List (elemIndices)+import Data.Maybe (fromMaybe)+import Safe (lastMay, readMay)+import System.FilePath (FilePath)++import URI (URI, escapeUriString, nullUri, parseAbsoluteUri)++data Host = Host {hostName :: String, hostPort :: Int}+ deriving (Eq,Ord,Show)++showHost :: Host -> String+showHost (Host name port) = name ++ ":" ++ show port++parseHost :: String -> Maybe Host+parseHost s = do+ i <- lastMay $ elemIndices ':' s+ (hostname, ':':portStr) <- return $ splitAt i s+ Host hostname <$> readMay portStr+++data Request+ = NetworkRequest {requestHost :: Host, networkRequestUri :: URI}+ | LocalFileRequest {requestPath :: FilePath}+ deriving (Eq,Ord,Show)++requestUri :: Request -> URI+requestUri (NetworkRequest _ uri) = uri+requestUri (LocalFileRequest abspath) =+ fromMaybe nullUri . parseAbsoluteUri $ "file://" <> escapeUriString abspath
+ RunExternal.hs view
@@ -0,0 +1,110 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module RunExternal where++import Control.Concurrent (forkIO)+import Control.Monad (void)+import Control.Monad.Catch (bracket_, finally)+import Control.Monad.State (State, put, runState)+import System.Environment (setEnv, unsetEnv)+import System.Exit (ExitCode)+import System.IO+import System.IO.Temp (withTempFile)+import System.Process++import qualified Data.ByteString.Lazy as BL++import ANSIColour+import Mundanities+import Prompt+import Util++-- |Wrapper to ensure we don't accidentally allow use of shell commands in +-- restricted mode!+newtype RestrictedIO a = RestrictedIO (IO a)+ deriving (Functor,Applicative,Monad)++runRestrictedIO :: RestrictedIO a -> IO a+runRestrictedIO (RestrictedIO m) = m+++subPercentOrAppend :: String -> String -> String+subPercentOrAppend sub str =+ let (s',subbed) = subPercent str `runState` False+ in if subbed then s' else s' ++ (' ':sub)+ where+ -- |based on specification for $BROWSER in 'man 1 man'+ subPercent :: String -> State Bool String+ subPercent "" = return []+ subPercent ('%':'%':s) = ('%':) <$> subPercent s+ subPercent ('%':'c':s) = (':':) <$> subPercent s+ subPercent ('%':'s':s) = put True >> (sub ++) <$> subPercent s+ subPercent (c:s) = (c:) <$> subPercent s++confirmShell :: String -> String -> IO Bool+confirmShell desc cmd = promptYN True False $+ desc ++ " following shell command?: " ++ withBoldStr cmd++pipeToCmdLazily :: String -> [String] -> [(String,String)] -> BL.ByteString -> RestrictedIO ()+pipeToCmdLazily cmd cArgs = pipeLazily $ proc cmd cArgs++pipeToShellLazily :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO ()+pipeToShellLazily = pipeLazily . shell++filterShell :: String -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString+filterShell = filterProcess . shell++withExtraEnv :: [(String,String)] -> IO a -> IO a+withExtraEnv envir = bracket_+ (mapM_ (uncurry setEnv) envir)+ (mapM_ (unsetEnv . fst) envir)++pipeLazily :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO ()+pipeLazily cp envir b = RestrictedIO . withExtraEnv envir $ do+ (Just inp, _, _, pid) <- createProcess $+ cp { std_in = CreatePipe , std_out = Inherit }+ hSetBuffering inp NoBuffering+ ignoreIOErr . finally (BL.hPut inp b) . void $ do+ hClose inp+ waitForProcess pid++filterProcess :: CreateProcess -> [(String,String)] -> BL.ByteString -> RestrictedIO BL.ByteString+filterProcess cp envir b = RestrictedIO . withExtraEnv envir $ do+ (Just inp, Just outp, _, pid) <- createProcess $+ cp { std_in = CreatePipe , std_out = CreatePipe }+ hSetBuffering inp NoBuffering+ hSetBuffering outp NoBuffering+ _ <- forkIO $ ignoreIOErr . finally (BL.hPut inp b) . void $ do+ hClose inp+ waitForProcess pid+ BL.hGetContents outp++runMailcap :: Bool -> String -> String -> String -> BL.ByteString -> RestrictedIO ()+runMailcap noConfirm action dir mimetype b =+ RestrictedIO . withTempFile dir "runtmp" $ \path h -> do+ BL.hPut h b+ hClose h+ let cArgs = ["--action=" ++ action, mimetype ++ ":" ++ path]+ rawSystem "run-mailcap" ("--norun":cArgs) >>+ (if noConfirm then return True else promptYN True False "Run this command?") >>?+ void $ rawSystem "run-mailcap" cArgs++runShellCmd :: String -> [(String,String)] -> RestrictedIO ExitCode+runShellCmd cmd envir = RestrictedIO . withExtraEnv envir $ spawnCommand cmd >>= waitForProcess++shellOnData :: Bool -> String -> FilePath -> [(String,String)] -> BL.ByteString -> RestrictedIO ()+shellOnData noConfirm cmd dir envir b = RestrictedIO . withTempFile dir "runtmp" $ \path h ->+ let cmd' = subPercentOrAppend path cmd+ in (if noConfirm then return True else confirmShell "Run" cmd') >>? void $ do+ BL.hPut h b >> hClose h+ runRestrictedIO $ runShellCmd cmd' envir
+ ServiceCerts.hs view
@@ -0,0 +1,50 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module ServiceCerts where++import Data.List (elemIndex)+import Data.PEM+import Data.X509+import Data.X509.Validation+import System.FilePath++import qualified Data.ByteString as BS+import qualified Data.Text as TS+import qualified Data.Text.Encoding as TS++import Mundanities+import Util++serviceToString :: ServiceID -> String+serviceToString (host, suffix) = host ++ TS.unpack (TS.decodeUtf8 suffix)++-- |service suffix must start with ':'+stringToService :: String -> ServiceID+stringToService s = maybe+ (s, BS.empty)+ (\i -> (take i s, TS.encodeUtf8 . TS.pack . drop i $ s))+ (elemIndex ':' s)++loadServiceCert :: FilePath -> ServiceID -> IO (Maybe SignedCertificate)+loadServiceCert path service =+ let filepath = path </> serviceToString service+ in ignoreIOErrAlt $+ pemParseBS <$> BS.readFile filepath >>= \pem -> return $ case pem of+ Right [PEM _ _ content] -> case decodeSignedCertificate content of+ Right cert -> Just cert+ _ -> Nothing+ _ -> Nothing++saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO ()+saveServiceCert path service cert =+ let filepath = path </> serviceToString service+ in isSubPath path filepath >>? BS.writeFile filepath .+ pemWriteBS . PEM "CERTIFICATE" [] . encodeSignedObject $ cert
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Slurp.hs view
@@ -0,0 +1,63 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++module Slurp where++import Control.Monad (when)+import Data.Hourglass (timeDiffP)+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Time.System (timeCurrentP)+import Time.Types (ElapsedP, NanoSeconds(..), Seconds(..))++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL++-- incorporate lazy IO into a bytestring such that it will print progress as +-- it is forced, if this takes more than a second.+interleaveProgress :: ElapsedP -> BL.ByteString -> IO BL.ByteString+interleaveProgress t0 bs = do+ t1 <- timeCurrentP+ let slurp _ _ n' [] = do+ t' <- timeCurrentP+ when (t' `timeDiffP` t1 > (Seconds 1, 0)) $ do+ putStrLn $ "\r\ESC[KReceived: " ++ humanBytes n'+ ++ " " ++ humanRate n' (t' `timeDiffP` t0)+ hFlush stdout+ return []+ slurp n t n' (c:cs) = unsafeInterleaveIO $ do+ let n'' = n' + fromIntegral (BS.length c)+ t' <- timeCurrentP+ if t' `timeDiffP` t > (Seconds 1, 0)+ then do+ when (t' `timeDiffP` t1 > (Seconds 1, 0)) $ do+ putStr $ "\r\ESC[KProgress: " ++ humanBytes n'+ ++ " " ++ humanRate (n' - n) (t' `timeDiffP` t)+ hFlush stdout+ (c:) <$> slurp n'' t' n'' cs+ else (c:) <$> slurp n t n'' cs+ humanBytes n | n < 1024 = show n ++ "B"+ humanBytes n | n < 1024*1024 =+ let (n',p) = (`divMod` 10) $ (n*10) `div` 1024+ in show n' ++ "." ++ show p ++ "KB"+ humanBytes n =+ let (n',p) = (`divMod` 10) $ (n*10) `div` (1024*1024)+ in show n' ++ "." ++ show p ++ "MB"+ humanRate _ (0,0) = ""+ humanRate n (Seconds s, NanoSeconds ns) = humanBytes r ++ "/s" where+ r = (billion*n)`div`((billion*s)+ns)+ billion = 1000000000+ BL.fromChunks <$> slurp 0 t0 0 (BL.toChunks bs)++-- |force bs, printing progress+slurpNoisily :: ElapsedP -> BL.ByteString -> IO ()+slurpNoisily t0 bs = do+ bs' <- BL.toStrict <$> interleaveProgress t0 bs+ seq bs' $ return ()
+ THANKS view
@@ -0,0 +1,8 @@+Thanks to solderpunk for the clear and clean gemini spec.++Thanks to Ben (gemini://kwiecien.us/) for suggestions and being my human CI.++Thanks to the authors of the various libraries this relies on, in particular +vincent@snarc.org for the excellent crypto haskell libraries.++Thanks to all who run a gemini server, giving this client something to do!
+ TextGemini.hs view
@@ -0,0 +1,164 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe #-}++module TextGemini where++import Control.Monad.State+import Data.Maybe (catMaybes, mapMaybe)++import ANSIColour++import qualified Data.Text.Lazy as T+import URI++data Link = Link { linkUri :: URIRef, linkDescription :: T.Text }+ deriving (Eq,Ord,Show)++data GeminiLine+ = TextLine T.Text+ | LinkLine { linkLineIndex :: Int, linkLineLink :: Link }+ | AltTextLine T.Text+ | PreformatToggleLine+ | PreformattedLine T.Text+ | HeadingLine Int T.Text+ | ItemLine T.Text+ | QuoteLine T.Text+ | ErrorLine T.Text+ deriving (Eq,Ord,Show)++newtype GeminiDocument = GeminiDocument { geminiDocumentLines :: [GeminiLine] }+ deriving (Eq,Ord,Show)++extractLinks :: GeminiDocument -> [Link]+extractLinks (GeminiDocument ls) = mapMaybe linkOfLine ls+ where+ linkOfLine (LinkLine _ link) = Just link+ linkOfLine _ = Nothing++data PreOpt+ = PreOptAlt+ | PreOptPre+ | PreOptBoth+ deriving (Eq,Ord,Show)++showPreOpt :: PreOpt -> String+showPreOpt PreOptAlt = "alt"+showPreOpt PreOptPre = "pre"+showPreOpt PreOptBoth = "both"++data GemRenderOpts = GemRenderOpts+ { grOptsAnsi :: Bool+ , grOptsPre :: PreOpt+ , grOptsWrapWidth :: Int+ } deriving (Eq,Ord,Show)++printGemDoc :: GemRenderOpts -> (URIRef -> T.Text) -> GeminiDocument -> [T.Text]+printGemDoc (GemRenderOpts ansi preOpt width)+ showUri (GeminiDocument ls) = concatMap printLine ls+ where+ printLine (TextLine line) = wrap width line+ printLine (LinkLine n link) = (:[]) $+ printGemLinkLine ansi showUri (n+1) link+ printLine (AltTextLine line)+ | preOpt == PreOptPre = []+ | preOpt == PreOptBoth && T.null line = []+ | otherwise = (:[]) $ applyIf ansi withBoldStr "`` " <> line++ -- |the spec says preformat toggle lines should not be rendered, but it's the most convenient + -- non-disruptive way to unambiguously indicate which lines are preformatted.+ printLine PreformatToggleLine = []++ printLine (PreformattedLine line)+ | preOpt == PreOptAlt = []+ | otherwise = (:[]) $ applyIf ansi ((resetCode <>) . withBoldStr) "` " <> line+ printLine (HeadingLine level line) = (:[]) $ if ansi+ then applyIf (level /= 2) withUnderlineStr .+ applyIf (level < 3) withBoldStr $ line+ else T.take (fromIntegral level) (T.repeat '#') <> " " <> line+ printLine (ItemLine line) = wrapWith "* " " " line+ printLine (QuoteLine line) = wrapWith "> " "> " line+ printLine (ErrorLine line) = (:[]) $ applyIf ansi (withColourStr Red)+ "! Formatting error in text/gemini: " <> line++ wrapWith first subsequent line =+ zipWith (<>) lineHeaders $ wrap (width - fromIntegral (T.length first)) line+ where lineHeaders = map (applyIf ansi withBoldStr) $ first : repeat subsequent++ wrap :: Int -> T.Text -> [T.Text]+ wrap wrapWidth line = wrap' "" 0 $ T.words line+ where+ wrap' l _ [] = [l]+ wrap' l n (w:ws) =+ let l' = if T.null l then w else l <> " " <> w+ nw = visibleLength w+ n' = n + nw + (if T.null l then 0 else 1)+ in if n' > wrapWidth+ then l : wrap' w nw ws+ else wrap' l' n' ws++printGemLinkLine :: Bool -> (URIRef -> T.Text) -> Int -> Link -> T.Text+printGemLinkLine ansi showUri n (Link uri desc) =+ applyIf ansi withBoldStr (T.pack $ '[' : show n ++ "]")+ <> " "+ <> showUri uri+ <> (if T.null desc then "" else+ applyIf ansi (withColourStr Cyan) $ " " <> desc)++data GeminiParseState = GeminiParseState { numLinks :: Int, preformatted :: Bool }++initialParseState :: GeminiParseState+initialParseState = GeminiParseState 0 False++parseGemini :: T.Text -> GeminiDocument+parseGemini text = GeminiDocument . catMaybes $ evalState+ (forM (T.lines text) (parseLine . stripTrailingCR)) initialParseState+ where+ stripTrailingCR = T.dropWhileEnd (== '\r')+ parseLine :: T.Text -> State GeminiParseState (Maybe GeminiLine)+ parseLine line = do+ pre <- gets preformatted+ if T.take 3 line == "```" then do+ modify $ \s -> s { preformatted = not pre }+ return $ if pre then case T.strip $ T.drop 3 line of+ "" -> Nothing+ _ -> Just . ErrorLine $ "Illegal non-empty text after closing '```'"+ -- ^The spec says we MUST ignore any text on a "```" line closing a preformatted + -- block. This seems like a gaping extensibility hole to me, so I'm interpreting it + -- as not disallowing an error message.+ else Just . AltTextLine . T.strip $ T.drop 3 line+ else if pre then return . Just $ PreformattedLine line+ else if T.take 2 line == "=>" then+ case parseLink . T.dropWhile isGemWhitespace $ T.drop 2 line of+ Nothing -> return . Just . ErrorLine $ "Unparseable link line: " <> line+ Just link -> do+ n <- gets numLinks+ modify $ \s -> s { numLinks = n + 1 }+ return . Just $ LinkLine n link+ else let headers = T.length . T.takeWhile (== '#') $ line+ in if headers > 0 && headers < 4+ then return . Just . HeadingLine (fromIntegral headers) .+ T.dropWhile isGemWhitespace . T.dropWhile (== '#') $ line+ else if T.take 2 line == "* "+ then return . Just . ItemLine $ T.drop 2 line+ else if T.take 1 line == ">"+ then return . Just . QuoteLine $ T.drop 1 line+ else return . Just $ TextLine line++ parseLink :: T.Text -> Maybe Link+ parseLink linkInfo =+ let uriText = T.takeWhile (not . isGemWhitespace) linkInfo+ desc = T.dropWhile isGemWhitespace . T.dropWhile (not . isGemWhitespace) $ linkInfo+ in (`Link` desc) <$> parseUriReference (T.unpack uriText)++ isGemWhitespace :: Char -> Bool+ isGemWhitespace = (`elem` (" \t"::String))
+ URI.hs view
@@ -0,0 +1,167 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe #-}++module URI+ ( URI+ , URIRef+ , escapeUriString+ , escapeQuery+ , escapeQueryPart+ , nullUri+ , parseAbsoluteUri+ , parseUriAsAbsolute+ , parseUriReference+ , pathSegments+ , relativeFrom+ , relativeTo+ , setQuery+ , stripUri+ , unescapeUriString+ , uriFragment+ , uriPath+ , uriPort+ , uriRegName+ , uriScheme+ , uriQuery+ ) where++import Control.Monad (mplus)+import Data.Char (toLower)+import Data.List (dropWhileEnd)+import Data.Maybe (isNothing)+import Safe (readMay)++import qualified Network.URI as NU++defaultScheme :: String+defaultScheme = "gemini"++defaultPort :: Int+defaultPort = 1965++-- | Represents a normalised absolute URI with scheme and port defaults as above.+-- We use "Uri" rather than "URI" in camelcase,+-- because I prefer to think of it as a word rather than an acronym.+-- Still use "URI" if it's the first/only word of the identifier.+newtype URI = URI {uriUri :: NU.URI}+ deriving (Eq,Ord)+instance Show URI where+ show (URI uri) = show uri++uriPath, uriQuery, uriFragment :: URI -> String+uriPath = NU.uriPath . uriUri+uriQuery = NU.uriQuery . uriUri+uriFragment = NU.uriFragment . uriUri++-- | strips trailing ':'+uriScheme :: URI -> String+uriScheme = init . NU.uriScheme . uriUri++pathSegments :: URI -> [String]+pathSegments (URI uri) = NU.pathSegments uri++nullUri :: URI+nullUri = URI NU.nullURI++-- | URI reference. May be absolute. Not normalised.+newtype URIRef = URIRef NU.URI+ deriving (Eq,Ord)+instance Show URIRef where+ show (URIRef uri) = show uri++normaliseUri :: NU.URI -> URI+normaliseUri uri = URI $ uri+ { NU.uriPath = (\p -> if null p then "/" else p) .+ NU.normalizePathSegments . NU.normalizeEscape $ NU.uriPath uri+ , NU.uriFragment = ""+ , NU.uriScheme = if null $ NU.uriScheme uri+ then defaultScheme else toLower <$> NU.uriScheme uri+ , NU.uriAuthority = (\auth -> auth+ { NU.uriPort =+ if NU.uriPort auth == ':' : show defaultPort+ then "" else NU.uriPort auth+ , NU.uriRegName = toLower <$> NU.uriRegName auth+ , NU.uriUserInfo = ""+ })+ <$> NU.uriAuthority uri+ , NU.uriQuery = NU.normalizeEscape $ NU.uriQuery uri+ }++parseAbsoluteUri :: String -> Maybe URI+parseAbsoluteUri = (normaliseUri <$>) . NU.parseURI++parseUriAsAbsolute :: String -> Maybe URI+parseUriAsAbsolute s = parseAbsoluteUri s `mplus` parseAbsoluteUri (defaultScheme ++ "://" ++ s)++parseUriReference :: String -> Maybe URIRef+parseUriReference = (URIRef <$>) . NU.parseURIReference+++setQuery :: String -> URI -> URI+setQuery q (URI uri) = URI $ uri { NU.uriQuery = q }++stripUri :: URI -> URI+stripUri (URI uri) = URI $ uri { NU.uriPath = dropWhileEnd (== '/') $ NU.uriPath uri, NU.uriQuery = "" }++relativeTo :: URIRef -> URI -> URI+relativeTo (URIRef ref) (URI uri) = normaliseUri $ NU.relativeTo ref uri++-- | lift NU.relativeFrom, but set scheme when the result is absolute,+-- and avoid initial slash where possible, and prefer "." to "" and ".." to "../"+relativeFrom :: URI -> URI -> URIRef+relativeFrom (URI uri1) (URI uri2) =+ URIRef . fixDots . stripSlash . setScheme $ NU.relativeFrom uri1 uri2 where+ setScheme ref | isNothing (NU.uriAuthority ref) = ref+ | otherwise = ref { NU.uriScheme = NU.uriScheme uri1 }+ stripSlash ref | '/':path' <- NU.uriPath ref+ , not $ null path'+ , ref' <- ref { NU.uriPath = path' }+ , NU.relativeTo ref' uri2 == uri1 = ref'+ | otherwise = ref+ fixDots ref = case NU.uriPath ref of+ "" -> ref { NU.uriPath = "." }+ "../" -> ref { NU.uriPath = ".." }+ _ -> ref++uriRegName :: URI -> Maybe String+uriRegName = (NU.uriRegName <$>) . NU.uriAuthority . uriUri++uriPort :: URI -> Maybe Int+uriPort = (readPort =<<) . (NU.uriPort <$>) . NU.uriAuthority . uriUri+ where+ readPort (':':n) = readMay n+ readPort _ = Nothing++escapeUriString :: String -> String+escapeUriString = NU.escapeURIString NU.isUnescapedInURI++unescapeUriString :: String -> String+unescapeUriString = NU.unEscapeString++escapeQuery :: String -> String+escapeQuery = NU.escapeURIString NU.isUnescapedInURIComponent . withEscapes+ where+ withEscapes "" = ""+ withEscapes ('\\':'\\':s) = '\\':withEscapes s+ withEscapes ('\\':'x':h1:h2:s) | Just c <- readMay $ "'\\x" <> [h1,h2,'\''] = c:withEscapes s+ withEscapes ('\\':'e':s) = '\ESC':withEscapes s+ withEscapes ('\\':'r':s) = '\r':withEscapes s+ withEscapes ('\\':'n':s) = '\n':withEscapes s+ withEscapes ('\\':'t':s) = '\t':withEscapes s+ withEscapes (c:s) = c:withEscapes s++-- |escape the query part of an unparsed uri string+escapeQueryPart :: String -> String+escapeQueryPart s+ | (s','?':q) <- break (== '?') s = s' ++ '?' : escapeQuery q+ | otherwise = s
+ Util.hs view
@@ -0,0 +1,39 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE TupleSections #-}+{-# LANGUAGE Safe #-}++module Util where+import Control.Monad (when, unless)++-- nice tip from one joeyh:+whenM,unlessM,(>>?),(>>!) :: Monad m => m Bool -> m () -> m ()+whenM c a = c >>= flip when a+unlessM c a = c >>= flip unless a+(>>?) = whenM+(>>!) = unlessM+-- same precedence as ($), allowing e.g. foo bar >>! error $ "failed " ++ meep+infixr 0 >>?+infixr 0 >>!++-- |Probably I'm missing some nice way to do these with prelude...+mapFst :: (a -> c) -> (a,b) -> (c,b)+mapFst f (x,y) = (f x,y)+mapSnd :: (b -> c) -> (a,b) -> (a,c)+mapSnd f (x,y) = (x,f y)++mapFstF :: Functor f => (a -> f c) -> (a,b) -> f (c,b)+mapFstF f (x,y) = (,y) <$> f x+mapSndF :: Functor f => (b -> f c) -> (a,b) -> f (a,c)+mapSndF f (x,y) = (x,) <$> f y++maybeToEither :: e -> Maybe a -> Either e a+maybeToEither e = maybe (Left e) Right
+ Version.hs view
@@ -0,0 +1,19 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE Safe #-}++module Version where++programName :: String+programName = "diohsc"++version :: String+version = "0.1.1"
+ diohsc.1.md view
@@ -0,0 +1,115 @@+% DIOHSC(1) Version $VERSION | diohsc+# NAME+diohsc - line-based gemini client++# SYNOPSIS+diohsc [OPTION]... [URI|PATH]++# DESCRIPTION+diohcs is a gemini client with the following features:++* Simple line-based command-response terminal user interface with ANSI colour.+* Terse but combinatorially expressive command language.+* Navigational aids: history, marks, queue.+* Facilities to invoke external commands and use per-scheme proxies.+* Responses streamed to pager or external command.+* Certificate checking with TOFU and/or explicitly trusted CAs.+* Support for TLS resuming, 0RTT, and client certificates.+* All configuration and certificates stored as user-manipulable files.+* Extensive help.++Please use the "help" and "commands" commands for information on the commands+diohsc understands.++# OPTIONS+-d, \-\-datadir *PATH*+: Directory for configuration and storage of information between sessions.+: Default: ~/.diohsc++-e, \-\-command *COMMAND*+: Execute diohsc command.+: "-e" and "-f" options will be processed in order of appearance,+: after any diohscrc file, and before processing any uri/path argument.++-f, \-\-file *PATH*+: Execute commands from file ("-" for stdin).+: "-e" and "-f" options will be processed in order of appearance,+: after any diohscrc file, and before processing any uri/path argument.++-i, \-\-interact+: Interactively read diohsc commands from stdin, and prompt for further input+: as appropriate.+: This is the default mode unless "-e" or "-f" is used.++-c, \-\-colour+: Use ANSI escape sequences for formatting.+: This is the default if stdout is a terminal.++-C, \-\-no-colour+: Do not output ANSI escape sequences.+: This is the default if stdout is not a terminal.++-g, \-\-ghost+: "Ghost mode". Do not write logs, input history, or marks to *datadir*, and+: don't write or update "known\_hosts" certificates. The "save" command will+: still write to the filesystem, as will the "identity" command if it is used to+: create a new named identity.++-r, \-\-restricted+: Disallow shell and filesystem access. This prevents all use of external+: commands, and reading or writing outside of *datadir*.++-v, \-\-version+: Show version information.++-h, \-\-help+: Show usage information.++# FILES+~/.diohsc+: Default *datadir*. The paths given below assume that this is used.++~/.diohsc/diohscrc+: Configuration file, consisting of diohsc commands to run at startup.++~/.diohsc/log+: Visited uris, one per line.++~/.diohsc/commandHistory+: Commands entered in interactive mode.++~/.diohsc/inputHistory+: Input entered for gemini queries.++~/.diohsc/known\_hosts/+: Contains Trust-On-First-Use trusted certificates of visited hosts.++~/.diohsc/trusted\_certs/+: Certificates will be trusted without warning and without being placed in+: known\_hosts if they are presented with a valid certificate chain from a+: Certificate Authority certificate found in this directory.++~/.diohsc/marks/+: Contains marks for use with the "'" target specifier. Each file contains a+: URI, optionally appended by [IDENT] where IDENT is the name of an identity.++~/.diohsc/identities/+: Contains client certificates and corresponding private RSA keys for named+: cryptographic identities, as produced by the "identify" command.++# ENVIRONMENT+BROWSER+: Default browser used by "browse" command without an argument.++PAGER+: Default pager used by "||" command without an argument.++# BUGS+Only ANSI escape sequences are supported.++# LICENCE+diohsc is free software, released under the terms of the GNU GPL v3 or later.+You should have obtained a copy of the licence as the file COPYING.++# AUTHORS+Martin Bays <mbays@sdf.org>
+ diohsc.cabal view
@@ -0,0 +1,107 @@+name: diohsc+version: 0.1.1+synopsis: Gemini client+homepage: https://mbays.sdf.org/diohsc+category: Browser+license: GPL-3+license-file: COPYING+author: Martin Bays+maintainer: mbays@sdf.org+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md, THANKS, diohscrc.sample, Makefile, diohsc.1.md++description:+ Line-based command-oriented interactive client for the gemini protocol.++source-repository head+ type: git+ location: https://repo.or.cz/diohsc.git++Flag Libiconv+ Description: On windows: use libiconv for charset conversion+ (iconv is always used on POSIX systems, with no need for this flag)+ Default: False+ Manual: True++Flag Magic+ Description: Use libmagic to determine mimetypes of local files+ Default: False+ -- with `Default: True`, `cabal install` fails if libmagic is not installed+ Manual: True++executable diohsc+ main-is: diohsc.hs+ build-depends:+ base (>=4.3 && < 5)+ , asn1-types < 0.4+ , bytestring < 0.11+ , containers < 0.7+ , cryptonite < 0.28+ , data-default-class < 0.2+ , data-hash < 0.3+ , directory (>= 1.3 && < 1.4)+ , drunken-bishop < 0.2+ , exceptions < 0.11+ , filepath < 1.5+ , haskeline (>= 0.8 && < 0.9)+ , hourglass < 0.3+ , mime < 0.5+ , mtl < 2.3+ , network < 3.2+ , network-uri < 2.8+ , parsec < 3.2+ , pem < 0.3+ , process < 1.7+ , regex-compat < 0.96+ , safe < 0.4+ , temporary < 1.4+ , terminal-size < 0.4+ , text < 1.3+ , tls < 1.6+ , transformers < 0.6+ , x509 < 1.8+ , x509-store < 1.7+ , x509-validation < 1.7+ other-modules:+ ActiveIdentities+ , Alias+ , ANSIColour+ , BoundedBSChan+ , BStack+ , ClientCert+ , ClientSessionManager+ , Command+ , CommandLine+ , Fingerprint+ , GeminiProtocol+ , Identity+ , Marks+ , MetaString+ , Mundanities+ , Opts+ , Pager+ , Prompt+ , Request+ , RunExternal+ , ServiceCerts+ , Slurp+ , TextGemini+ , URI+ , Util+ , Version+ default-language: Haskell2010+ ghc-options: -threaded+ if os(windows)+ CPP-Options: -DWINDOWS+ else+ build-depends:+ unix+ if flag(Magic)+ CPP-Options: -DMAGIC+ build-depends:+ magic+ if ! os(windows) || flag(Libiconv)+ CPP-Options: -DICONV+ build-depends:+ iconv
+ diohsc.hs view
@@ -0,0 +1,1125 @@+-- This file is part of Diohsc+-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of version 3 of the GNU General Public License as+-- published by the Free Software Foundation, or any later version.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see http://www.gnu.org/licenses/.++{-# LANGUAGE FlexibleContexts, LambdaCase, OverloadedStrings, TupleSections #-}+{-# LANGUAGE CPP #-}++module Main where++import Control.Applicative (Alternative, empty)+import Control.Monad.Catch+import Control.Monad.State+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Data.Bifunctor (second)+import Data.Char (isUpper, toLower)+import Data.Hash (Hash, hash)+import Data.List (find, intercalate, isPrefixOf, isSuffixOf, stripPrefix)+import Data.Maybe+import Safe+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import Text.Regex (Regex, mkRegexWithOpts, matchRegex)+import Time.System (timeCurrentP)+import Time.Types (ElapsedP)++import qualified Data.ByteString.Lazy as BL++import qualified Codec.MIME.Type as MIME+import qualified Codec.MIME.Parse as MIME+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as TS+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.Text.Lazy.IO as T+import qualified System.Console.Haskeline as HL+import qualified System.Console.Terminal.Size as Size++import ActiveIdentities+import Alias+import ANSIColour+import qualified BStack+import Command+import CommandLine+import GeminiProtocol+import Identity+import Marks+import MetaString+import Mundanities+import Opts+import Pager+import Prompt hiding (promptYN)+import qualified Prompt+import Request+import RunExternal hiding (runRestrictedIO)+import qualified RunExternal+import Slurp+import TextGemini+import Util+import Version+import URI++#ifndef WINDOWS+import System.Posix.Files (setFileMode, ownerModes)+#endif++#ifdef ICONV+import Codec.Text.IConv (convert)+#endif++#ifdef MAGIC+import qualified Magic+#endif++-- |Immutable options set at startup+data ClientOptions = ClientOptions+ { cOptUserDataDir :: FilePath+ , cOptInteractive :: Bool+ , cOptAnsi :: Bool+ , cOptRestrictedMode :: Bool+ , cOptGhost :: Bool+ , cOptRequestContext :: RequestContext+ , cOptLogH :: Maybe Handle+ }++data HistoryChild = HistoryChild+ { childItem :: HistoryItem+ , childLink :: Maybe Int+ }++data HistoryOrigin = HistoryOrigin+ { originItem :: HistoryItem+ , originLink :: Maybe Int+ }++data HistoryItem = HistoryItem+ { historyRequest :: Request+ , historyRequestTime :: ElapsedP+ , historyMimedData :: MimedData+ , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO+ , historyParent :: Maybe HistoryItem+ , historyChild :: Maybe HistoryChild+ }++historyUri :: HistoryItem -> URI+historyUri = requestUri . historyRequest++historyEnv :: HistoryItem -> [(String,String)]+historyEnv item =+ [ ("URI", show $ historyUri item)+ , ("MIMETYPE", showMimeType $ historyMimedData item) ]++historyAncestors :: HistoryItem -> [HistoryItem]+historyAncestors i = case historyParent i of+ Nothing -> []+ Just i' -> i' : historyAncestors i'++historyDescendants :: HistoryItem -> [HistoryItem]+historyDescendants i = case historyChild i of+ Nothing -> []+ Just (HistoryChild i' _) -> i' : historyDescendants i'++pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem+pathItemByUri i uri = find ((uri ==) . historyUri) $+ historyAncestors i ++ [i] ++ historyDescendants i++data ClientConfig = ClientConfig+ { clientConfDefaultAction :: (String, [CommandArg])+ , clientConfProxies :: M.Map String Host+ , clientConfGeminators :: [(String,(Regex,String))]+ , clientConfRenderFilter :: Maybe String+ , clientConfPreOpt :: PreOpt+ , clientConfMaxLogLen :: Int+ , clientConfMaxWrapWidth :: Int+ , clientConfNoConfirm :: Bool+ }++defaultClientConfig :: ClientConfig+defaultClientConfig = ClientConfig ("page", []) M.empty [] Nothing PreOptBoth 1000 80 False++data QueueItem = QueueItem+ { queueOrigin :: Maybe HistoryOrigin+ , queueUri :: URI+ }++data ClientState = ClientState+ { clientCurrent :: Maybe HistoryItem+ , clientJumpBack :: Maybe HistoryItem+ , clientLog :: BStack.BStack T.Text+ , clientVisited :: S.Set Hash+ , clientQueue :: [QueueItem]+ , clientActiveIdentities :: ActiveIdentities+ , clientMarks :: Marks+ , clientSessionMarks :: M.Map Int HistoryItem+ , clientAliases :: Aliases+ , clientQueuedCommands :: [String]+ , clientConfig :: ClientConfig+ }++type ClientM = StateT ClientState IO++type CommandAction = HistoryItem -> ClientM ()++emptyClientState :: ClientState+emptyClientState = ClientState Nothing Nothing BStack.empty S.empty [] M.empty emptyMarks M.empty defaultAliases [] defaultClientConfig++enqueue :: Maybe Int -> [QueueItem] -> ClientM ()+enqueue _ [] = return ()+enqueue after qs = modify $ \s -> s {clientQueue = insert after qs $ clientQueue s}+ where+ insert mn as bs = let (bs',bs'') = maybe (bs,[]) (`splitAt` bs) mn in del as bs' ++ as ++ del as bs''+ del as = filter $ (`notElem` (queueUri <$> as)) . queueUri++dropUriFromQueue :: URI -> ClientM ()+dropUriFromQueue uri = modify $ \s -> s { clientQueue = filter ((/= uri) . queueUri) $ clientQueue s }++popQueuedCommand :: ClientM (Maybe String)+popQueuedCommand = do+ cmd <- gets $ headMay . clientQueuedCommands+ when (isJust cmd) . modify $ \s ->+ s { clientQueuedCommands = drop 1 $ clientQueuedCommands s }+ return cmd++modifyCConf :: (ClientConfig -> ClientConfig) -> ClientM ()+modifyCConf f = modify $ \s -> s { clientConfig = f $ clientConfig s }++main :: IO ()+main = do+ argv <- getArgs+ (opts,args) <- parseArgs argv+ when (Help `elem` opts) $ putStr usage >> exitSuccess+ when (Version `elem` opts) $ putStrLn version >> exitSuccess++ defUserDataDir <- getAppUserDataDirectory programName+ userDataDir <- makeAbsolute . fromMaybe defUserDataDir $ listToMaybe [ path | DataDir path <- opts ]+ let restrictedMode = Restricted `elem` opts++ outTerm <- hIsTerminalDevice stdout+ let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts)++ let argCommands (ScriptFile "-") = warnIOErrAlt $+ (T.unpack . T.strip <$>) . T.lines <$> T.getContents+ argCommands (ScriptFile f) = warnIOErrAlt $ (T.unpack <$>) <$> readFileLines f+ argCommands (OptCommand c) = return [c]+ argCommands _ = return []+ optCommands <- concat <$> mapM argCommands opts+ let interactive = null optCommands || Interactive `elem` opts++ let argToUri arg = doesPathExist arg >>= \case+ True -> Just . ("file://" <>) . escapeUriString <$> makeAbsolute arg+ False | Just uri <- parseUriAsAbsolute arg -> return $ Just $ show uri+ _ -> printErrOpt ansi ("No such URI / file: " <> arg) >> return Nothing+ argCommand <- join <$> mapM argToUri (listToMaybe args)++ let initialCommands = optCommands ++ maybeToList argCommand++ let ghost = Ghost `elem` opts++ mkdirhier userDataDir+#ifndef WINDOWS+ setFileMode userDataDir ownerModes -- chmod 700+#endif+ let cmdHistoryPath = userDataDir </> "commandHistory"+ marksPath = userDataDir </> "marks"+ logPath = userDataDir </> "log"++ let displayInfo :: [String] -> IO ()+ displayInfo = mapM_ $ printInfoOpt ansi+ displayWarning = mapM_ $ printErrOpt ansi+ promptYN = Prompt.promptYN interactive+ callbacks = InteractionCallbacks displayInfo displayWarning waitKey promptYN++ requestContext <- initRequestContext callbacks userDataDir ghost+ (warnings, marks) <- loadMarks marksPath+ displayWarning warnings+ let hlSettings = (HL.defaultSettings::HL.Settings ClientM)+ { HL.complete = HL.noCompletion+ , HL.historyFile = if ghost then Nothing else Just cmdHistoryPath+ }++ cLog <- BStack.fromList . reverse <$> readFileLines logPath+ let visited = S.fromList $ hash . T.unpack <$> BStack.toList cLog++ let openLog :: IO (Maybe Handle)+ openLog = ignoreIOErrAlt $ Just <$> do+ h <- openFile logPath AppendMode+ hSetBuffering h LineBuffering+ return h+ closeLog :: Maybe Handle -> IO ()+ closeLog = maybe (return ()) hClose++ bracketOnError openLog closeLog $ \logH ->+ let clientOptions = ClientOptions userDataDir interactive ansi ghost+ restrictedMode requestContext logH+ initState = emptyClientState {clientMarks = marks+ , clientLog = cLog, clientVisited = visited}+ in do+ endState <- (`execStateT` initState) . HL.runInputT hlSettings $+ lineClient clientOptions initialCommands+ closeLog logH+ -- |reread file rather than just writing clientLog, in case another instance has also + -- been appending to the log.+ unless ghost . warnIOErr $ truncateToEnd (clientConfMaxLogLen $ clientConfig endState) logPath++printErrOpt :: MonadIO m => Bool -> String -> m ()+printErrOpt ansi s = liftIO . hPutStrLn stderr . applyIf ansi (withColourStr BoldRed) $ "! " <> s++printInfoOpt :: MonadIO m => Bool -> String -> m ()+printInfoOpt ansi s = liftIO . hPutStrLn stderr $ applyIf ansi withBoldStr ". " <> s++getTermSize :: IO (Int,Int)+getTermSize = do+ Size.Window height width <- fromMaybe (Size.Window 25 80) <$> Size.size+ return (height,width)++lineClient :: ClientOptions -> [String] -> HL.InputT ClientM ()+lineClient cOpts@ClientOptions{ cOptUserDataDir = userDataDir+ , cOptInteractive = interactive, cOptAnsi = ansi, cOptGhost = ghost} initialCommands = do+ (liftIO . readFileLines $ userDataDir </> "diohscrc") >>= mapM_ (handleLine' . T.unpack)+ lift addToQueueFromFile+ mapM_ handleLine' initialCommands+ when interactive lineClient'+ where+ handleLine' :: String -> HL.InputT ClientM Bool+ handleLine' line = lift get >>= \s -> handleLine cOpts s line++ lineClient' :: HL.InputT ClientM ()+ lineClient' = do+ cmd <- runMaybeT $ msum+ [ do+ c <- MaybeT $ lift popQueuedCommand+ printInfoOpt ansi $ "> " <> c+ return c+ , MaybeT $ lift getPrompt >>= promptLineInputT ]+ lift addToQueueFromFile+ quit <- case cmd of+ Nothing -> if interactive+ then printErrOpt ansi "Use \"quit\" to quit" >> return False+ else return True+ Just line -> handleLine' line+ when (quit && not ghost) $ lift appendQueueToFile+ unless quit lineClient'++ addToQueueFromFile :: ClientM ()+ addToQueueFromFile | ghost = return ()+ | otherwise = (enqueue Nothing =<<) . liftIO . ignoreIOErr $ doesPathExist queueFile >>= \case+ True -> catMaybes . (queueLine <$>) <$> readFileLines queueFile <* removeFile queueFile+ where+ queueLine :: T.Text -> Maybe QueueItem+ queueLine s = QueueItem Nothing <$> parseUriAsAbsolute (T.unpack s)+ False -> return []++ appendQueueToFile :: ClientM ()+ appendQueueToFile = do+ queue <- gets clientQueue+ unless (null queue) . liftIO . BL.appendFile queueFile .+ T.encodeUtf8 . T.unlines $ T.pack . show . queueUri <$> queue++ queueFile :: FilePath+ queueFile = userDataDir </> "queue"++ getPrompt :: ClientM String+ getPrompt = do+ queue <- gets clientQueue+ curr <- gets clientCurrent+ proxies <- gets $ clientConfProxies . clientConfig+ ais <- gets clientActiveIdentities+ let queueStatus :: Maybe String+ queueStatus = guard (not $ null queue) >> return (show (length queue) ++ "~")+ colour = applyIf ansi . withColourStr+ bold = applyIf ansi withBoldStr+ uriStatus :: Int -> URI -> String+ uriStatus w uri =+ let fullUriStr = stripGem $ show uri+ stripGem s = fromMaybe s $ stripPrefix "gemini://" s+ mIdName = (identityName <$>) $ findIdentity ais =<< requestOfProxiesAndUri proxies uri+ idStr = flip (maybe "") mIdName $ \idName ->+ let abbrId = length idName > 8 && length fullUriStr + 2 + length idName > w - 2+ in "[" ++ (if abbrId then ".." ++ take 6 idName else idName) ++ "]"+ abbrUri = length fullUriStr + length idStr > w - 2+ uriFormat = colour BoldMagenta+ uriStr = if abbrUri+ then+ let abbrUriChars = w - 4 - length idStr+ preChars = abbrUriChars `div` 2+ postChars = abbrUriChars - preChars+ in uriFormat (take preChars fullUriStr) <>+ ".." <>+ uriFormat (drop (length fullUriStr - postChars) fullUriStr)+ else uriFormat fullUriStr+ in uriStr +++ (if null idStr then "" else colour Green idStr)+ prompt :: Int -> String+ prompt maxPromptWidth+ | interactive = (colour BoldCyan "%%% " ++) . (++ bold "> ") . unwords $ catMaybes+ [ queueStatus+ , uriStatus (maxPromptWidth - 5 - maybe 0 ((+1) . length) queueStatus) . historyUri <$> curr+ ]+ | otherwise = ""+ prompt . min 40 . (`div` 2) . snd <$> liftIO getTermSize++handleLine :: ClientOptions -> ClientState -> String -> HL.InputT ClientM Bool+handleLine cOpts@ClientOptions{ cOptAnsi = ansi } s line = handle backupHandler . catchInterrupts $ case parseCommandLine line of+ Left err -> printErrOpt ansi err >> return False+ Right (CommandLine Nothing (Just (c,_))) | c `isPrefixOf` "quit" -> return True+ Right cline -> handleCommandLine cOpts s cline >> return False+ where+ catchInterrupts = HL.handleInterrupt (printErrOpt ansi "Interrupted." >> return False) . HL.withInterrupt . lift+ backupHandler :: SomeException -> HL.InputT ClientM Bool+ backupHandler = (>> return False) . printErrOpt ansi . ("Unhandled exception: " <>) . show++data Target+ = TargetHistory HistoryItem+ | TargetFrom HistoryOrigin URI+ | TargetIdUri String URI+ | TargetUri URI++targetUri :: Target -> URI+targetUri (TargetHistory item) = historyUri item+targetUri (TargetFrom _ uri) = uri+targetUri (TargetIdUri _ uri) = uri+targetUri (TargetUri uri) = uri++targetQueueItem :: Target -> QueueItem+targetQueueItem (TargetFrom o uri) = QueueItem (Just o) uri+targetQueueItem i = QueueItem Nothing $ targetUri i++handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM ()+handleCommandLine+ cOpts@(ClientOptions userDataDir interactive ansi ghost restrictedMode requestContext logH)+ cState@(ClientState curr jumpBack cLog visited queue _ marks sessionMarks aliases _+ (ClientConfig defaultAction proxies geminators renderFilter preOpt maxLogLen maxWrapWidth confNoConfirm))+ = \(CommandLine mt mcas) -> case mcas of+ Just (c,args) | Just (Alias _ (CommandLine mt' mcas')) <- lookupAlias c aliases ->+ let mcas'' = (, drop 1 args) . commandArgArg <$> headMay args+ appendCArgs (c',as') = (c', (appendTail <$> as') ++ args)+ where+ appendTail arg@(CommandArg a' t') = case args of+ [] -> arg+ (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t+ in handleCommandLine' (mt' `mplus` mt) $+ (appendCArgs <$> mcas') `mplus` mcas''+ _ -> handleCommandLine' mt mcas++ where++ -- Remark: we handle haskell's "configurations problem" by having the below all within the scope + -- of the ClientOptions parameter. This is nicer to my mind than the heavier approaches of + -- simulating global variables or threading a Reader monad throughout. The downside is that this + -- module can't be split as much as it ought to be.+ -- Similar remarks go for `GeminiProtocol.makeRequest`.++ onRestriction :: IO ()+ onRestriction = printErr "This is not allowed in restricted mode."++ doRestricted :: Monoid a => RestrictedIO a -> IO a+ doRestricted m | restrictedMode = onRestriction >> return mempty+ | otherwise = RunExternal.runRestrictedIO m++ doRestrictedAlt :: Alternative f => RestrictedIO (f a) -> IO (f a)+ doRestrictedAlt m | restrictedMode = onRestriction >> return empty+ | otherwise = RunExternal.runRestrictedIO m++ doRestrictedFilter :: (a -> RestrictedIO a) -> (a -> IO a)+ doRestrictedFilter f | restrictedMode = \a -> do+ onRestriction+ return a+ | otherwise = RunExternal.runRestrictedIO . f++ printInfo :: MonadIO m => String -> m ()+ printInfo = printInfoOpt ansi+ printErr :: MonadIO m => String -> m ()+ printErr = printErrOpt ansi++ printIOErr :: IOError -> IO ()+ printIOErr = printErr . show++ noConfirm :: Bool+ noConfirm = confNoConfirm || not interactive++ confirm :: Applicative m => m Bool -> m Bool+ confirm | noConfirm = const $ pure True+ | otherwise = id++ promptYN = Prompt.promptYN interactive++ colour :: MetaString a => Colour -> a -> a+ colour = applyIf ansi . withColourStr+ bold :: MetaString a => a -> a+ bold = applyIf ansi withBoldStr++ isVisited :: URI -> Bool+ isVisited uri = S.member (hash $ show uri) visited++ requestOfUri = requestOfProxiesAndUri proxies++ idAtUri :: ActiveIdentities -> URI -> Maybe Identity+ idAtUri ais uri = findIdentity ais =<< requestOfUri uri++ showUriRefFull :: MetaString a => Bool -> ActiveIdentities -> URI -> URIRef -> a+ showUriRefFull ansi' ais base ref = showUriFull ansi' ais (Just base) $ relativeTo ref base++ showUriFull :: MetaString a => Bool -> ActiveIdentities -> Maybe URI -> URI -> a+ showUriFull ansi' ais base uri =+ let scheme = uriScheme uri+ handled = scheme `elem` ["gemini","file"] || M.member scheme proxies+ col = case (isVisited uri,handled) of+ (True,True) -> Yellow+ (False,True) -> BoldYellow+ (True,False) -> Red+ (False,False) -> BoldRed+ s = case base of+ Nothing -> show uri+ Just b -> show $ relativeFrom uri b+ in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of+ Nothing -> ""+ Just ident -> showIdentity ansi' ident++ displayUri :: MetaString a => URI -> a+ displayUri = colour Yellow . fromString . show++ showUri :: URI -> ClientM ()+ showUri uri = do+ ais <- gets clientActiveIdentities+ liftIO . putStrLn $ showUriFull ansi ais Nothing uri++ addToLog :: URI -> ClientM ()+ addToLog uri = do+ let t = T.pack $ show uri+ modify $ \s -> s+ { clientLog = BStack.push maxLogLen t $ clientLog s+ , clientVisited = S.insert (hash $ show uri) $ clientVisited s }+ unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH++ loggedUris = catMaybes $ (parseAbsoluteUri . T.unpack <$>) $ BStack.toList cLog++ expand :: String -> String+ expand = expandHelp ansi (fst <$> aliases) userDataDir++ idsPath = userDataDir </> "identities"+ savesDir = userDataDir </> "saves"+ marksDir = userDataDir </> "marks"++ setMark :: String -> URIWithIdName -> ClientM ()+ setMark mark uriId = do+ modify $ \s -> s { clientMarks = insertMark mark uriId $ clientMarks s }+ unless (mark `elem` tempMarks) . liftIO .+ handle printIOErr $ saveMark marksDir mark uriId++ promptInput = if ghost then promptLine else promptLineWithHistoryFile inputHistPath+ where inputHistPath = userDataDir </> "inputHistory"++ handleCommandLine' :: Maybe PTarget -> Maybe (String, [CommandArg]) -> ClientM ()+ handleCommandLine' mt mcas = void . runMaybeT $ do+ ts <- case mt of+ Nothing -> return []+ Just pt -> either ((>> mzero) . printErr)+ (\ts -> mapM_ addTargetId ts >> return ts) $+ resolveTarget pt+ case mcas of+ Nothing -> lift $ handleBareTargets ts+ Just (s,as) -> do+ c' <- maybe (printErr (unknownCommand s) >> mzero)+ return $ normaliseCommand s+ lift $ handleCommand ts (c',as)+ where+ unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help."+ addTargetId :: Target -> MaybeT ClientM ()+ addTargetId (TargetIdUri idName uri) =+ (requestOfUri uri,) <$> liftIO (loadIdentity idsPath idName) >>= \case+ (Nothing, _) -> printErr ("Bad URI: " ++ show uri) >> mzero+ (_, Nothing) -> printErr ("Unknown identity: " ++ showIdentityName ansi idName) >> mzero+ (Just req, Just ident) -> lift $ addIdentity req ident+ addTargetId _ = return ()++ resolveTarget :: PTarget -> Either String [Target]+ resolveTarget PTargetCurr =+ (:[]) . TargetHistory <$> maybeToEither "No current location" curr++ resolveTarget PTargetJumpBack =+ (:[]) . TargetHistory <$> maybeToEither "'' mark not set" jumpBack++ resolveTarget (PTargetMark s)+ | Just n <- readMay s =+ (:[]) . TargetHistory <$> maybeToEither ("Mark not set: " <> s) (M.lookup n sessionMarks)+ | otherwise =+ (:[]) . targetOfMark <$> maybeToEither ("Unknown mark: " <> s) (lookupMark s marks)+ where+ targetOfMark (URIWithIdName uri Nothing) = TargetUri uri+ targetOfMark (URIWithIdName uri (Just idName)) = TargetIdUri idName uri++ resolveTarget (PTargetLog specs) =+ (TargetUri <$>) <$> resolveElemsSpecs "log entry" (matchPatternOn show) loggedUris specs++ resolveTarget (PTargetQueue specs) =+ (queueTarget <$>) <$> resolveElemsSpecs "queue item" (matchPatternOn $ show . queueUri) queue specs+ where+ queueTarget (QueueItem Nothing uri) = TargetUri uri+ queueTarget (QueueItem (Just o) uri) = TargetFrom o uri++ resolveTarget (PTargetAncestors base specs) =+ concat <$> (mapM resolveAncestors =<< resolveTarget base)+ where+ resolveAncestors :: Target -> Either String [Target]+ resolveAncestors (TargetHistory item) = (TargetHistory <$>) <$>+ resolveElemsSpecs "ancestor" (matchPatternOn $ show . historyUri)+ (historyAncestors item) specs+ resolveAncestors _ = Left "No history"++ resolveTarget (PTargetDescendants base specs) =+ concat <$> (mapM resolveDescendants =<< resolveTarget base)+ where+ resolveDescendants :: Target -> Either String [Target]+ resolveDescendants (TargetHistory item) = (TargetHistory <$>) <$>+ resolveElemsSpecs "descendant" (matchPatternOn $ show . historyUri)+ (historyDescendants item) specs+ resolveDescendants _ = Left "No history"++ resolveTarget (PTargetChild increasing noVisited base specs) =+ concat <$> (mapM resolveChild =<< resolveTarget base)+ where+ resolveChild (TargetHistory item) =+ let itemLinks = extractLinksMimed $ historyGeminatedMimedData item+ b = case historyChild item of+ Just (HistoryChild _ (Just b')) -> b'+ _ | increasing -> -1+ _ -> length itemLinks+ slice | increasing = zip [b+1..] $ drop (b+1) itemLinks+ | otherwise = zip (reverse [0..b-1]) . reverse $ take b itemLinks+ linkUnvisited (_,l) = not . isVisited $ linkUri l `relativeTo` historyUri item+ slice' = applyIf noVisited (filter linkUnvisited) slice+ in resolveLinkSpecs False item slice' specs+ resolveChild _ = Left "No known links"++ resolveTarget (PTargetLinks noVisited base specs) =+ concat <$> (mapM resolveLinks =<< resolveTarget base)+ where+ resolveLinks (TargetHistory item) =+ let itemLinks = extractLinksMimed $ historyGeminatedMimedData item+ in resolveLinkSpecs noVisited item (zip [0..] itemLinks) specs+ resolveLinks _ = Left "No known links"++ resolveTarget (PTargetRef base s) =+ let makeRel r | base == PTargetCurr = r+ makeRel r@('/':_) = '.':r+ makeRel r = r+ in case parseUriReference . escapeQueryPart $ makeRel s of+ Nothing -> Left $ "Failed to parse relative URI: " <> s+ Just ref -> map relTarget <$> resolveTarget base+ where+ relTarget (TargetHistory item) = TargetFrom (HistoryOrigin item Nothing) $+ ref `relativeTo` historyUri item+ relTarget t = TargetUri . relativeTo ref $ targetUri t++ resolveTarget (PTargetAbs s) = case parseUriAsAbsolute $ escapeQueryPart s of+ Nothing -> Left $ "Failed to parse URI: " <> s+ Just uri -> return [TargetUri uri]++ resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target]+ resolveLinkSpecs purgeVisited item slice specs =+ let isMatch s (_,l) = matchPattern s (show $ linkUri l) ||+ matchPattern s (T.unpack $ linkDescription l)+ linkTarg (n,l) =+ let uri = linkUri l `relativeTo` historyUri item+ in if purgeVisited && isVisited uri then Nothing+ else Just $ TargetFrom (HistoryOrigin item $ Just n) uri+ in catMaybes . (linkTarg <$>) <$> resolveElemsSpecs "link" isMatch slice specs >>= \case+ [] -> Left "No such link"+ targs -> return targs++ matchPattern :: String -> String -> Bool+ matchPattern patt =+ let regex = mkRegexWithOpts patt True (exists isUpper patt)+ exists f = not . all (not . f)+ in isJust . matchRegex regex++ matchPatternOn :: (a -> String) -> String -> a -> Bool+ matchPatternOn f patt = matchPattern patt . f++ doPage :: [T.Text] -> ClientM ()+ doPage ls+ | interactive = do+ (height,width) <- liftIO getTermSize+ let pageWidth = min maxWrapWidth (width - 4)+ queued <- liftIO $ printLinesPaged pageWidth width (height - 2) ls+ modify $ \s -> s { clientQueuedCommands = clientQueuedCommands s ++ queued }+ | otherwise = liftIO $ mapM_ T.putStrLn ls++ handleBareTargets :: [Target] -> ClientM ()+ handleBareTargets [] = return ()+ handleBareTargets (_:_:_) =+ printErr "Can only go to one place at a time. Try \"show\" or \"page\"?"+ handleBareTargets [TargetHistory item] = goHistory item+ handleBareTargets [TargetFrom origin uri] = goUri False (Just origin) uri+ handleBareTargets [t] = goUri False Nothing $ targetUri t+++ handleCommand :: [Target] -> (String, [CommandArg]) -> ClientM ()+ handleCommand _ (c,_) | restrictedMode && notElem c (commands True) =+ printErr "Command disabled in restricted mode"+ handleCommand [] ("help", args) = case args of+ [] -> doPage . map (T.pack . expand) $ helpText+ CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s+ handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText+ where+ commandHelpText = ["Aliases:"] ++ (showAlias <$> aliases) +++ ["","Commands:"] ++ (('{' :) . (<> "}") <$> commands False)+ showAlias (a, Alias s _) = "{" <> a <> "}: " <> s++ handleCommand [] ("mark", []) =+ let ms = M.toAscList marks+ markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m+ in T.pack $ "'" <> m' <>+ replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <>+ showUriWithId uriId+ in doPage $ markLine <$> ms+ handleCommand [] ("inventory",_) = do+ ais <- gets clientActiveIdentities+ let showNumberedUri :: T.Text -> (Int,URI) -> T.Text+ showNumberedUri s (n,uri) = s <> T.pack (show n) <> " " <> showUriFull ansi ais Nothing uri+ showNumberedItem s (n,item) = showNumberedUri s (n, historyUri item)+ showNumberedQueueItem s (n,q) = showNumberedUri s (n, queueUri q)+ showJumpBack :: [T.Text]+ showJumpBack = maybeToList $ ("'' " <>) . showUriFull ansi ais Nothing . historyUri <$> jumpBack+ doPage . intercalate [""] . filter (not . null) $+ [ showJumpBack+ , showNumberedQueueItem "~" <$> zip [1..] queue+ , showNumberedItem "'" <$> M.toAscList sessionMarks+ , showNumberedItem "<" <$> zip [1..] (maybe [] historyAncestors curr)+ , showNumberedItem ">" <$> zip [1..] (maybe [] historyDescendants curr)+ ]+ handleCommand [] ("log",_) =+ let showLog (n,t) = "$" <> T.pack (show n) <> " " <> colour Yellow t+ in doPage $ showLog <$> zip [(1::Int)..] (BStack.toList cLog)+ handleCommand [] ("alias", CommandArg a _ : CommandArg _ str : _) = void . runMaybeT $ do+ c <- either ((>>mzero) . printErr) return $ parseCommand a+ when (c /= a) $ printErr ("Bad alias: " <> a) >> mzero+ cl <- either ((>>mzero) . printErr) return $ parseCommandLine str+ modify $ \s ->+ s { clientAliases = insertAlias a (Alias str cl) . deleteAlias a $ clientAliases s }+ handleCommand [] ("alias", [CommandArg a _]) =+ modify $ \s -> s { clientAliases = deleteAlias a $ clientAliases s }+ handleCommand [] ("set", []) = liftIO $ do+ let (c,args) = defaultAction+ putStrLn $ expand "{default_action}: " <> c <>+ maybe "" ((" "<>) . commandArgLiteralTail) (headMay args)+ putStrLn $ expand "{proxies}:"+ printMap showHost $ M.toAscList proxies+ putStrLn $ expand "{geminators}:"+ printMap id $ second snd <$> geminators+ putStrLn $ expand "{render_filter}: " <> fromMaybe "" renderFilter+ putStrLn $ expand "{pre_display}: " <> showPreOpt preOpt+ putStrLn $ expand "{log_length}: " <> show maxLogLen+ putStrLn $ expand "{max_wrap_width}: " <> show maxWrapWidth+ putStrLn $ expand "{no_confirm}: " <> show noConfirm+ where+ printMap :: (a -> String) -> [(String,a)] -> IO ()+ printMap f as = mapM_ putStrLn $+ (\(k,e) -> " " <> k <> " " <> f e) <$> as+ handleCommand [] ("set", CommandArg opt _ : val)+ | opt `isPrefixOf` "default_action" = case val of+ (CommandArg cmd _ : args) -> case actionOfCommand (cmd,args) of+ Just _ -> modifyCConf $ \c -> c { clientConfDefaultAction = (cmd,args) }+ Nothing -> printErr "Invalid action"+ _ -> printErr "Require value for option."+ | opt `isPrefixOf` "proxies" || opt `isPrefixOf` "proxy" = case val of+ (CommandArg scheme _ : val') ->+ let f = maybe (M.delete scheme) (M.insert scheme) $+ parseHost . commandArgLiteralTail =<< headMay val'+ in modifyCConf $ \c -> c { clientConfProxies = f $ clientConfProxies c }+ -- if only I'd allowed myself to use lenses, eh?+ [] -> printErr "Require mimetype to set geminator for."+ | opt `isPrefixOf` "geminators" = case val of+ (CommandArg patt _ : val') ->+ let f = maybe (filter $ (/= patt) . fst)+ (\v -> (++ [(patt, (mkRegexWithOpts patt True True,+ commandArgLiteralTail v))])) $+ headMay val'+ in modifyCConf $ \c -> c { clientConfGeminators = f $ clientConfGeminators c }+ [] -> printErr "Require mimetype to set geminator for."+ | opt `isPrefixOf` "render_filter" =+ modifyCConf $ \c -> c { clientConfRenderFilter =+ commandArgLiteralTail <$> headMay val }+ | opt `isPrefixOf` "pre_display" = case val of+ [CommandArg s _] | map toLower s `isPrefixOf` "both" ->+ modifyCConf $ \c -> c { clientConfPreOpt = PreOptBoth }+ [CommandArg s _] | map toLower s `isPrefixOf` "pre" ->+ modifyCConf $ \c -> c { clientConfPreOpt = PreOptPre }+ [CommandArg s _] | map toLower s `isPrefixOf` "alt" ->+ modifyCConf $ \c -> c { clientConfPreOpt = PreOptAlt }+ _ -> printErr "Require \"both\" or \"pre\" or \"alt\" for pre_display"+ | opt `isPrefixOf` "log_length" = case val of+ [CommandArg s _] | Just n <- readMay s, n >= 0 -> do+ modifyCConf $ \c -> c { clientConfMaxLogLen = n }+ modify $ \st -> st { clientLog = BStack.truncate n $ clientLog st }+ _ -> printErr "Require non-negative integer value for log_length"+ | opt `isPrefixOf` "max_wrap_width" = case val of+ [CommandArg s _] | Just n <- readMay s, n > 0 ->+ modifyCConf $ \c -> c { clientConfMaxWrapWidth = n }+ _ -> printErr "Require positive integer value for max_wrap_width"+ | opt `isPrefixOf` "no_confirm" = case val of+ [CommandArg s _] | map toLower s `isPrefixOf` "true" ->+ modifyCConf $ \c -> c { clientConfNoConfirm = True }+ [CommandArg s _] | map toLower s `isPrefixOf` "false" ->+ modifyCConf $ \c -> c { clientConfNoConfirm = False }+ _ -> printErr "Require \"true\" or \"false\" as value for no_confirm"+ | otherwise = printErr $ "No such option \"" <> opt <> "\"."+ handleCommand [] cargs =+ case curr of+ Just item -> handleCommand [TargetHistory item] cargs+ Nothing -> printErr "No current location. Enter an URI, or type \"help\"."++ handleCommand ts ("add", args) =+ enqueue (readMay . commandArgArg =<< headMay args) $ targetQueueItem <$> ts+ handleCommand ts cargs =+ mapM_ handleTargetCommand ts+ where+ handleTargetCommand (TargetHistory item) | Just action <- actionOfCommand cargs =+ action item+ handleTargetCommand t | Just action <- actionOfCommand cargs =+ let uri = targetUri t+ in dropUriFromQueue uri >> doRequestUri uri action+ handleTargetCommand (TargetHistory item) | ("repeat",_) <- cargs =+ goUri True (recreateOrigin <$> historyParent item) $ historyUri item+ handleTargetCommand (TargetHistory item) | ("repl",_) <- cargs =+ repl (recreateOrigin <$> historyParent item) $ historyUri item+ handleTargetCommand (TargetHistory item) =+ handleUriCommand (historyUri item) cargs+ handleTargetCommand t =+ handleUriCommand (targetUri t) cargs++ recreateOrigin :: HistoryItem -> HistoryOrigin+ recreateOrigin parent = HistoryOrigin parent $ childLink =<< historyChild parent++ handleUriCommand uri ("delete",_) = dropUriFromQueue uri+ handleUriCommand uri ("repeat",_) = goUri True Nothing uri+ handleUriCommand uri ("uri",_) = showUri uri+ handleUriCommand uri ("mark", CommandArg mark _ : _)+ | Just _ <- readMay mark :: Maybe Int = error "Bad mark for uri"+ | otherwise = do+ ais <- gets clientActiveIdentities+ let mIdName = case findIdentity ais =<< requestOfUri uri of+ Just ident | not $ isTemporary ident -> Just $ identityName ident+ _ -> Nothing+ setMark mark $ URIWithIdName uri mIdName+ handleUriCommand uri ("identify", args) = case requestOfUri uri of+ Nothing -> printErr "Bad URI"+ Just req -> gets ((`findIdentityRoot` req) . clientActiveIdentities) >>= \case+ Just (root,(ident,_)) -> endIdentityPrompted root ident+ Nothing -> void . runMaybeT $ do+ ident <- MaybeT . liftIO $ case args of+ (CommandArg idName _ : _) -> getIdentity noConfirm ansi idsPath idName+ [] -> getIdentityRequesting ansi idsPath+ lift $ addIdentity req ident+ handleUriCommand uri ("browse", args) = void . liftIO . runMaybeT $ do+ cmd <- case args of+ [] -> maybe notSet+ (\s -> if null s then notSet else return $ parseBrowser s) =<<+ lift (lookupEnv "BROWSER")+ where+ notSet = printErr "Please set $BROWSER or give a command to run" >> mzero+ -- |based on specification for $BROWSER in 'man 1 man'+ parseBrowser :: String -> String+ parseBrowser = subPercentOrAppend (show uri) . takeWhile (/=':')+ (CommandArg _ c : _) -> return $ subPercentOrAppend (show uri) c+ lift $ confirm (confirmShell "Run" cmd) >>? doRestricted $ void (runShellCmd cmd [])+ handleUriCommand uri ("repl",_) = repl Nothing uri+ handleUriCommand uri ("log",_) = addToLog uri++ handleUriCommand _ (c,_) = printErr $ "Bad arguments to command " <> c++ repl :: Maybe HistoryOrigin -> URI -> ClientM ()+ repl origin uri = repl' where+ repl' = liftIO (promptInput ">> ") >>= \case+ Nothing -> return ()+ Just "" -> return ()+ Just query -> do+ goUri True origin . setQuery ('?':escapeQuery query) $ uri+ repl'++ actionOnRendered :: Bool -> ([T.Text] -> ClientM ()) -> CommandAction+ actionOnRendered ansi' m item = do+ ais <- gets clientActiveIdentities+ liftIO (renderMimed ansi' (historyUri item) ais (historyGeminatedMimedData item)) >>=+ either printErr m++ actionOfCommand :: (String, [CommandArg]) -> Maybe CommandAction+ actionOfCommand (c,_) | restrictedMode && notElem c (commands True) = Nothing+ actionOfCommand ("show",_) = Just . actionOnRendered ansi $ liftIO . mapM_ T.putStrLn+ actionOfCommand ("page",_) = Just $ actionOnRendered ansi doPage+ actionOfCommand ("links",_) = Just $ \item -> do+ ais <- gets clientActiveIdentities+ let cl = childLink =<< historyChild item+ linkLine n link =+ applyIf (cl == Just (n-1)) (bold "* " <>) $+ printGemLinkLine ansi (showUriRefFull ansi ais $ historyUri item) n link+ doPage . zipWith linkLine [1..] . extractLinksMimed . historyGeminatedMimedData $ item++ actionOfCommand ("mark", CommandArg mark _ : _) |+ Just n <- readMay mark :: Maybe Int = Just $ \item ->+ modify $ \s -> s { clientSessionMarks = M.insert n item $ clientSessionMarks s }+ actionOfCommand ("mime",_) = Just $ liftIO . print . showMimeType . historyMimedData+ actionOfCommand ("save", []) = actionOfCommand ("save", [CommandArg "" savesDir])+ actionOfCommand ("save", CommandArg _ path : _) = Just $ \item -> liftIO . doRestricted . RestrictedIO $ do+ createDirectoryIfMissing True savesDir+ homePath <- getHomeDirectory+ let path' = if take 2 path == "~/"+ then homePath </> drop 2 path+ else savesDir </> path+ body = mimedBody $ historyMimedData item+ name = fromMaybe "" . lastMay . pathSegments $ historyUri item+ handle printIOErr . void . runMaybeT $ do+ lift $ mkdirhierto path'+ isDir <- lift $ doesDirectoryExist path'+ let fullpath = if isDir then path' </> name else path'+ lift (doesDirectoryExist fullpath) >>? do+ lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory"+ mzero+ lift (doesFileExist fullpath) >>?+ guard =<< not <$> lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?")+ lift $ do+ putStrLn $ "Saving to " ++ fullpath+ t0 <- timeCurrentP+ BL.writeFile fullpath =<< interleaveProgress t0 body++ actionOfCommand ("!", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted .+ shellOnData noConfirm cmd userDataDir (historyEnv item) . mimedBody $ historyMimedData item++ actionOfCommand ("view",_) = Just $ \item ->+ let mimed = historyMimedData item+ mimetype = showMimeType mimed+ body = mimedBody mimed+ in liftIO . handle printIOErr . doRestricted $ runMailcap noConfirm "view" userDataDir mimetype body+ actionOfCommand ("|", CommandArg _ cmd : _) = Just $ \item -> liftIO . handle printIOErr . doRestricted $+ pipeToShellLazily cmd (historyEnv item) . mimedBody $ historyMimedData item+ actionOfCommand ("||", args) = Just $ pipeRendered ansi args+ actionOfCommand ("||-", args) = Just $ pipeRendered False args+ actionOfCommand ("cat",_) = Just $ liftIO . BL.putStr . mimedBody . historyMimedData+ actionOfCommand ("at", CommandArg _ str : _) = Just $ \item -> void . runMaybeT $ do+ cl <- either ((>>mzero) . printErr) return $ parseCommandLine str+ lift $ handleCommandLine cOpts (cState { clientCurrent = Just item }) cl+ actionOfCommand _ = Nothing++ pipeRendered :: Bool -> [CommandArg] -> CommandAction+ pipeRendered ansi' args item = (\action -> actionOnRendered ansi' action item) $ \ls ->+ liftIO . void . runMaybeT $ do+ cmd <- case args of+ [] -> maybe notSet+ (\s -> if null s then notSet else return s) =<<+ liftIO (lookupEnv "PAGER")+ where+ notSet = printErr "Please set $PAGER or give a command to run" >> mzero+ (CommandArg _ cmd : _) -> return cmd+ lift . doRestricted . pipeToShellLazily cmd (historyEnv item) . T.encodeUtf8 $ T.unlines ls++ setCurr :: HistoryItem -> ClientM ()+ setCurr i =+ let isJump = isNothing $ historyUri <$> curr >>= pathItemByUri i+ in do+ when isJump $ modify $ \s -> s { clientJumpBack = curr }+ modify $ \s -> s { clientCurrent = Just i }++ goHistory :: HistoryItem -> ClientM ()+ goHistory i = setCurr i >> showUri (historyUri i)++ goUri :: Bool -> Maybe HistoryOrigin -> URI -> ClientM ()+ goUri forceRequest origin uri = dropUriFromQueue uri >> case curr >>= flip pathItemByUri uri of+ Just i' | not forceRequest -> goHistory i'+ _ -> doRequestUri uri $ \item -> do+ maybe (printErr "Bad default action!") ($ item) $ actionOfCommand defaultAction+ liftIO . slurpNoisily (historyRequestTime item) . mimedBody $ historyMimedData item+ let updateParent i =+ -- Lazily recursively update the links in the doubly linked list+ let i' = i { historyParent = updateParent . updateChild i' <$> historyParent i }+ in i'+ updateChild i' i = i { historyChild = setChild <$> historyChild i }+ where setChild c = c { childItem = i' }+ glueOrigin (HistoryOrigin o l) = updateParent $ o { historyChild = Just $ HistoryChild item' l }+ item' = item { historyParent = glueOrigin <$> origin }+ setCurr item'+ addToLog uri++ doRequestUri :: URI -> CommandAction -> ClientM ()+ doRequestUri uri0 action = doRequestUri' 0 uri0+ where+ doRequestUri' redirs uri+ | Just req <- requestOfUri uri = doRequest redirs req+ | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ (+ let scheme = uriScheme uri+ in if scheme /= "gemini" && isNothing (M.lookup scheme proxies)+ then " : No proxy set for non-gemini scheme " ++ scheme ++ "; use \"browse\"?"+ else "")++ doRequest :: Int -> Request -> ClientM ()+ doRequest redirs _ | redirs > 5 =+ printErr "Too many redirections!"+ doRequest redirs req@(NetworkRequest _ uri) = do+ (mId, ais) <- liftIO . useActiveIdentity noConfirm ansi req =<< gets clientActiveIdentities+ modify $ \s -> s { clientActiveIdentities = ais }+ printInfo $ ">>> " ++ showUriFull ansi ais Nothing uri+ let respBuffSize = 2 ^ (15::Int) -- 32KB max cache for response stream+ liftIO (makeRequest requestContext mId respBuffSize req)+ `bracket` either (\_ -> return ()) (liftIO . snd) $+ either+ (printErr . displayException)+ (handleResponse . fst)+ where+ handleResponse :: Response -> ClientM ()+ handleResponse (Input isPass prompt) = do+ let defaultPrompt = "[" ++ (if isPass then "PASSWORD" else "INPUT") ++ "]"+ prompter = if isPass then promptPassword else promptInput+ (liftIO . prompter $ (if null prompt then defaultPrompt else prompt) ++ " > ") >>= \case+ Nothing -> return ()+ Just query -> doRequestUri' redirs . setQuery ('?':escapeQuery query) $ uri++ handleResponse (Success mimedData) = doAction req mimedData++ handleResponse (Redirect isPerm to) = do+ let uri' = to `relativeTo` uri+ crossSite = uriRegName uri' /= uriRegName uri+ crossScheme = uriScheme uri' /= uriScheme uri+ warningStr = colour BoldRed+ ais <- gets clientActiveIdentities+ proceed <- (isJust <$>) . lift . runMaybeT $ do+ when crossSite . (guard =<<) . liftIO . promptYN False $+ warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"+ when crossScheme . (guard =<<) . liftIO . promptYN False $+ warningStr "Follow cross-protocol redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?"+ when proceed $ do+ when (isPerm && not ghost) . mapM_ (updateMark uri') . marksWithUri uri =<< gets clientMarks+ doRequestUri' (redirs + 1) uri'+ where updateMark uri' (mark,uriId) = do+ conf <- confirm . liftIO . promptYN True $ "Update mark '" <> mark <> " to " <> show uri' <> " ?"+ when conf . setMark mark $ uriId { uriIdUri = uri' }+ handleResponse (Failure code info) | 60 <= code && code <= 69 = void . runMaybeT $ do+ identity <- do+ liftIO . putStrLn $ (case code of+ 60 -> "Server requests identification"+ _ -> "Server rejects provided identification certificate" +++ (if code == 61 then " as unauthorised" else if code == 62 then " as invalid" else ""))+ ++ if null info then "" else ": " ++ info+ MaybeT . liftIO $ getIdentityRequesting ansi idsPath+ lift $ do+ addIdentity req identity+ doRequest redirs req++ handleResponse (Failure code info) =+ printErr $ "Server returns failure: " ++ show code ++ " " ++ info+ handleResponse (MalformedResponse malformation) =+ printErr $ "Malformed response from server: " ++ show malformation++ doRequest redirs (LocalFileRequest path) | redirs > 0 = printErr "Ignoring redirect to local file."+ | otherwise = void . runMaybeT $ do+ (path', mimedData) <- MaybeT . liftIO . doRestrictedAlt . RestrictedIO . warnIOErrAlt $ do+ let detectExtension = case takeExtension path of+ -- |certain crucial filetypes we can't rely on magic to detect:+ s | s `elem` [".gmi", ".gem", ".gemini"] -> Just "text/gemini"+ ".md" -> Just "text/markdown"+ ".html" -> Just "text/html"+ _ -> Nothing+#ifdef MAGIC+ detectPlain "text/plain" = fromMaybe "text/plain" detectExtension+ detectPlain s = s+ magic <- Magic.magicOpen [Magic.MagicMimeType]+ Magic.magicLoadDefault magic+ s <- detectPlain <$> Magic.magicFile magic path+#else+ let s = if "/" `isSuffixOf` path then "inode/directory"+ else fromMaybe "application/octet-stream" detectExtension+#endif+ case MIME.parseMIMEType $ TS.pack s of+ Nothing -> printErr ("Failed to parse mimetype string: " <> s) >> return Nothing+ _ | s == "inode/directory" -> Just . (slashedPath,) . MimedData gemTextMimeType .+ T.encodeUtf8 . T.unlines . ((("=> " <>) . T.pack . escapeUriString) <$>) <$>+ getDirectoryContents path+ where slashedPath | "/" `isSuffixOf` path = path+ | otherwise = path <> "/"+ Just mimetype -> Just . (path,) . MimedData mimetype <$> BL.readFile path+ lift $ doAction (LocalFileRequest path') mimedData++ doAction req mimedData = do+ t0 <- liftIO timeCurrentP+ geminated <- geminate mimedData+ action $ HistoryItem req t0 mimedData geminated Nothing Nothing+ where+ -- |returns MimedData with lazy IO+ geminate :: MimedData -> ClientM MimedData+ geminate mimed =+ let geminator = lookupGeminator $ showMimeType mimed+ in liftIO . unsafeInterleaveIO $ applyGeminator geminator+ where+ lookupGeminator mimetype =+ listToMaybe [ gem | (_, (regex, gem)) <- geminators+ , isJust $ matchRegex regex mimetype ]+ applyGeminator Nothing = return mimed+ applyGeminator (Just cmd) =+ printInfo ("| " <> cmd) >>+ MimedData gemTextMimeType <$>+ doRestrictedFilter (filterShell cmd [("URI", show $ requestUri req)]) (mimedBody mimed)++ gemTextMimeType :: MIME.Type+ gemTextMimeType = MIME.Type (MIME.Text "gemini") []+++ addIdentity :: Request -> Identity -> ClientM ()+ addIdentity req identity = do+ ais <- gets clientActiveIdentities >>= liftIO . insertIdentity req identity+ modify $ \s -> s {clientActiveIdentities = ais}+ endIdentityPrompted :: Request -> Identity -> ClientM ()+ endIdentityPrompted root ident = do+ conf <- confirm $ liftIO . promptYN False $ "Stop using " +++ (if isTemporary ident then "temporary anonymous identity" else showIdentity ansi ident) +++ " at " ++ displayUri (requestUri root) ++ "?"+ when conf . modify $ \s ->+ s { clientActiveIdentities = deleteIdentity root $ clientActiveIdentities s }++ extractLinksMimed :: MimedData -> [Link]+ extractLinksMimed (MimedData (MIME.Type (MIME.Text "gemini") _) body) =+ extractLinks . parseGemini $ T.decodeUtf8With T.lenientDecode body+ extractLinksMimed _ = []++ renderMimed :: Bool -> URI -> ActiveIdentities -> MimedData -> IO (Either String [T.Text])+ renderMimed ansi' uri ais (MimedData mime body) = case MIME.mimeType mime of+ MIME.Text textType -> do+ let extractCharsetParam (MIME.MIMEParam "charset" v) = Just v+ extractCharsetParam _ = Nothing+ charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime+ isUtf8 = map toLower charset `elem` ["utf-8", "utf8"]+#ifdef ICONV+ reencoder = if isUtf8 then id else+ convert charset "UTF-8"+#else+ reencoder = id+ unless isUtf8 . printErr $+ "Warning: Treating unsupported charset " ++ show charset ++ " as utf-8"+#endif+ (_,width) <- getTermSize+ let pageWidth = if interactive+ then min maxWrapWidth (width - 4)+ else maxWrapWidth+ let bodyText = T.decodeUtf8With T.lenientDecode $ reencoder body+ applyFilter :: [T.Text] -> IO [T.Text]+ applyFilter = case renderFilter of+ Nothing -> return+ Just cmd -> (T.lines . T.decodeUtf8With T.lenientDecode <$>) .+ doRestrictedFilter (filterShell cmd []) . BL.concat . (appendNewline . T.encodeUtf8 <$>)+ where appendNewline = (`BL.snoc` 10)+ (Right <$>) . applyFilter . (sanitiseNonCSI <$>) $ case textType of+ "gemini" ->+ let opts = GemRenderOpts ansi' preOpt pageWidth+ in printGemDoc opts (showUriRefFull ansi' ais uri) $ parseGemini bodyText+ _ -> T.stripEnd <$> T.lines bodyText+ mimeType ->+ return . Left $ "Display of non-text MIME type " ++ TS.unpack (MIME.showMIMEType mimeType) ++ " not supported."
+ diohscrc.sample view
@@ -0,0 +1,58 @@+#### Sample diohsc configuration:+# Copy this to ~/.diohsc/diohscrc and edit it appropriately.+# Each line is a diohsc command to be run at startup.+++## Proxies+# To allow diohsc to access gopher:// URIs:+# run an Agena https://tildegit.org/solderpunk/agena instance locally+# and uncomment the following option (you may want to change the port if+# you're also running a gemini server locally).+#set proxy gopher 127.0.0.1:1965++# To allow diohsc to access http:// and https:// URIs:+# run a Duckling https://github.com/LukeEmmet/duckling-proxy instance locally+# and uncomment the following options (you may want to change the port if+# you're running a gemini server or agena instance)+#set proxy http 127.0.0.1:1965+#set proxy https 127.0.0.1:1965+# By default, duckling-proxy automatically converts text/html using html2gmi;+# you may prefer to use the --unfiltered option and set a geminator as below,+# This gives you more control over the conversion, and lets you access the+# html source in diohsc.+++## Geminators+# The following "geminator" options will allow display of various mimetypes;+# install the corresponding software, and uncomment the corresponding line.++# https://github.com/makeworld-the-better-one/md2gemini/+#set geminator text/markdown md2gemini -l paragraph++# https://github.com/LukeEmmet/html2gmi+#set geminator (text|application)/(html|xml|xhtml.*) html2gmi -me++# These lines use jp2a and imagemagick, which are probably packages in your+# distro, to produce nice ascii art previews of image files:+#set geminator image/jpeg echo '```' && jp2a --colors - && echo '```'+#set geminator image/.* echo '```' && convert - jpeg:- | jp2a --colors - && echo '```'+++## Render filter+# This will do a best effort translation of utf8 to ascii when rendering text:+#set render_filter stdbuf -o0 uni2ascii -BPq+++## Aliases+# You can set aliases as shorthands for commands. e.g.:+#alias up ..+#alias Mpv |mpv --cache-secs 5 -+#alias Read ||- espeak -s 300 --stdin --stdout | aplay+#alias BGRead ||- espeak -s 300 --stdin --stdout | aplay &+#alias QueueNew at *- add++## Identification+# You may want to configure certain cryptographic identities to always be used+# for certain sites. e.g. if you've created an identity "astrobotany" for use+# on astrobotany.mozz.us, you may want to uncomment the following line.+#gemini://astrobotany.mozz.us identify astrobotany