diff --git a/ANSIColour.hs b/ANSIColour.hs new file mode 100644 --- /dev/null +++ b/ANSIColour.hs @@ -0,0 +1,127 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/ActiveIdentities.hs b/ActiveIdentities.hs new file mode 100644 --- /dev/null +++ b/ActiveIdentities.hs @@ -0,0 +1,64 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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) diff --git a/Alias.hs b/Alias.hs new file mode 100644 --- /dev/null +++ b/Alias.hs @@ -0,0 +1,42 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/BStack.hs b/BStack.hs new file mode 100644 --- /dev/null +++ b/BStack.hs @@ -0,0 +1,41 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/BoundedBSChan.hs b/BoundedBSChan.hs new file mode 100644 --- /dev/null +++ b/BoundedBSChan.hs @@ -0,0 +1,68 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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) diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/ClientCert.hs b/ClientCert.hs new file mode 100644 --- /dev/null +++ b/ClientCert.hs @@ -0,0 +1,133 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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) +-} diff --git a/ClientSessionManager.hs b/ClientSessionManager.hs new file mode 100644 --- /dev/null +++ b/ClientSessionManager.hs @@ -0,0 +1,54 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Command.hs b/Command.hs new file mode 100644 --- /dev/null +++ b/Command.hs @@ -0,0 +1,475 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 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), 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 diff --git a/CommandLine.hs b/CommandLine.hs new file mode 100644 --- /dev/null +++ b/CommandLine.hs @@ -0,0 +1,203 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Fingerprint.hs b/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/Fingerprint.hs @@ -0,0 +1,28 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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) diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs new file mode 100644 --- /dev/null +++ b/GeminiProtocol.hs @@ -0,0 +1,392 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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" diff --git a/Identity.hs b/Identity.hs new file mode 100644 --- /dev/null +++ b/Identity.hs @@ -0,0 +1,81 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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/ diff --git a/Marks.hs b/Marks.hs new file mode 100644 --- /dev/null +++ b/Marks.hs @@ -0,0 +1,87 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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'] diff --git a/MetaString.hs b/MetaString.hs new file mode 100644 --- /dev/null +++ b/MetaString.hs @@ -0,0 +1,24 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Mundanities.hs b/Mundanities.hs new file mode 100644 --- /dev/null +++ b/Mundanities.hs @@ -0,0 +1,57 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Opts.hs b/Opts.hs new file mode 100644 --- /dev/null +++ b/Opts.hs @@ -0,0 +1,54 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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)) diff --git a/Pager.hs b/Pager.hs new file mode 100644 --- /dev/null +++ b/Pager.hs @@ -0,0 +1,60 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Prompt.hs b/Prompt.hs new file mode 100644 --- /dev/null +++ b/Prompt.hs @@ -0,0 +1,86 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 } diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Request.hs b/Request.hs new file mode 100644 --- /dev/null +++ b/Request.hs @@ -0,0 +1,43 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/RunExternal.hs b/RunExternal.hs new file mode 100644 --- /dev/null +++ b/RunExternal.hs @@ -0,0 +1,110 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/ServiceCerts.hs b/ServiceCerts.hs new file mode 100644 --- /dev/null +++ b/ServiceCerts.hs @@ -0,0 +1,50 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Slurp.hs b/Slurp.hs new file mode 100644 --- /dev/null +++ b/Slurp.hs @@ -0,0 +1,63 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 () diff --git a/THANKS b/THANKS new file mode 100644 --- /dev/null +++ b/THANKS @@ -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! diff --git a/TextGemini.hs b/TextGemini.hs new file mode 100644 --- /dev/null +++ b/TextGemini.hs @@ -0,0 +1,164 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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)) diff --git a/URI.hs b/URI.hs new file mode 100644 --- /dev/null +++ b/URI.hs @@ -0,0 +1,167 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,39 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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 diff --git a/Version.hs b/Version.hs new file mode 100644 --- /dev/null +++ b/Version.hs @@ -0,0 +1,19 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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" diff --git a/diohsc.1.md b/diohsc.1.md new file mode 100644 --- /dev/null +++ b/diohsc.1.md @@ -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 diff --git a/diohsc.cabal b/diohsc.cabal new file mode 100644 --- /dev/null +++ b/diohsc.cabal @@ -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 diff --git a/diohsc.hs b/diohsc.hs new file mode 100644 --- /dev/null +++ b/diohsc.hs @@ -0,0 +1,1125 @@ +-- This file is part of Diohsc +-- Copyright (C) 2020 Martin Bays +-- +-- 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." diff --git a/diohscrc.sample b/diohscrc.sample new file mode 100644 --- /dev/null +++ b/diohscrc.sample @@ -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