diff --git a/ANSIColour.hs b/ANSIColour.hs --- a/ANSIColour.hs +++ b/ANSIColour.hs @@ -9,7 +9,7 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} -- Basic ansi attributes, using only most widely supported ansi terminal codes module ANSIColour @@ -28,12 +28,12 @@ , Colour(..) ) where -import Control.Exception.Base (bracket_) +import Control.Exception.Base (bracket_) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T -import MetaString +import MetaString data Colour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White @@ -50,22 +50,22 @@ 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 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" + colNum BoldCyan = "6" + colNum BoldWhite = "7" thenReset :: IO () -> IO a -> IO a thenReset = (`bracket_` T.putStr resetCode) @@ -86,7 +86,7 @@ -- |"applyIf cond f" is shorthand for "if cond then f else id" applyIf :: Bool -> (a -> a) -> (a -> a) -applyIf True = id +applyIf True = id applyIf False = const id @@ -122,6 +122,6 @@ (pre,'\ESC':'[':post) -> ((pre <> "\ESC[") <>) $ case break endCSI post of (pre',e:post') -> (pre' <>) $ e : '\STX' : escapePromptCSI post' - (pre',[]) -> pre' + (pre',[]) -> pre' (pre,[]) -> pre (pre,e:post) -> (pre <>) $ e : escapePromptCSI post diff --git a/ActiveIdentities.hs b/ActiveIdentities.hs --- a/ActiveIdentities.hs +++ b/ActiveIdentities.hs @@ -12,17 +12,17 @@ module ActiveIdentities where -import Control.Monad (mplus) -import Data.Hourglass (Elapsed(..)) -import Data.Maybe (fromJust) -import Time.System (timeCurrent) +import Control.Monad (mplus) +import Data.Hourglass (Elapsed (..)) +import Data.Maybe (fromJust) +import Time.System (timeCurrent) -import qualified Data.Map as Map +import qualified Data.Map as Map -import Identity (Identity(..), isTemporary, showIdentity) -import Prompt -import Request -import URI +import Identity (Identity (..), isTemporary, showIdentity) +import Prompt +import Request +import URI type ActiveIdentities = Map.Map Request (Identity, Elapsed) diff --git a/Alias.hs b/Alias.hs --- a/Alias.hs +++ b/Alias.hs @@ -12,11 +12,11 @@ module Alias where -import Data.Bifunctor (second) -import Data.List (isPrefixOf) -import Safe (headMay) +import Data.Bifunctor (second) +import Data.List (isPrefixOf) +import Safe (headMay) -import CommandLine +import CommandLine data Alias = Alias String CommandLine deriving (Eq,Ord,Show) @@ -32,7 +32,7 @@ where aliasOf s = let Right cl = parseCommandLine s in Alias s cl lookupAlias :: String -> Aliases -> Maybe Alias -lookupAlias s aliases = +lookupAlias s aliases = headMay [ alias | (a,alias) <- aliases, s `isPrefixOf` a ] insertAlias :: String -> Alias -> Aliases -> Aliases diff --git a/BStack.hs b/BStack.hs --- a/BStack.hs +++ b/BStack.hs @@ -11,10 +11,10 @@ -- |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 +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as S +import Prelude hiding (truncate) data BStack a = BStack (Seq a) Int diff --git a/BoundedBSChan.hs b/BoundedBSChan.hs --- a/BoundedBSChan.hs +++ b/BoundedBSChan.hs @@ -8,22 +8,22 @@ -- 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 +-- |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 +-- 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 +-- 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 +-- 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 +-- 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 +-- There's stm-sbchan, but it seems a bit heavy, and would add stm as a -- dependency. module BoundedBSChan ( newBSChan @@ -31,12 +31,12 @@ , getBSChanContents ) where -import Control.Concurrent -import Control.Monad -import Data.Maybe (fromMaybe) -import System.IO.Unsafe (unsafeInterleaveIO) +import Control.Concurrent +import Control.Monad +import Data.Maybe (fromMaybe) +import System.IO.Unsafe (unsafeInterleaveIO) -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS data BoundedBSChan = BoundedBSChan Int -- ^bound diff --git a/CHANGELOG.gmi b/CHANGELOG.gmi new file mode 100644 --- /dev/null +++ b/CHANGELOG.gmi @@ -0,0 +1,16 @@ +# Changelog for diohsc +This file covers only non-trivial user-visible changes; +see the git log for full gory details. + +## 0.1.3 +* Allow trusting certificates just for the current session +* Don't require tail certificates to be v3 +* Add uri of any request to log, even if request fails +* Just show fingerprint of known cert rather than picture + +## 0.1.2 +* Add @ target modifier for history root +* Understand e.g. ~< +* Suppress alt text by default +* Fix: uri quoting for queries and file:// was incorrect +* Fix: queue was not appended to on exit in non-interactive mode diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,9 +0,0 @@ -This file covers only non-trivial user-visible changes; -see the git log for full gory details. - -## 0.1.2 -- Add @ target modifier for history root -- Understand e.g. ~< -- Suppress alt text by default -- Fix: uri quoting for queries and file:// was incorrect -- Fix: queue was not appended to on exit in non-interactive mode diff --git a/ClientCert.hs b/ClientCert.hs --- a/ClientCert.hs +++ b/ClientCert.hs @@ -8,36 +8,37 @@ -- 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 CPP #-} +{-# LANGUAGE LambdaCase #-} {-# 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 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 qualified Data.ByteString as BS +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS -import Fingerprint -import Mundanities -import Util +import Fingerprint +import Mundanities +import Util #ifndef WINDOWS -import System.Posix.Files +import System.Posix.Files #endif -- |Certificate chain with secret key for tail cert @@ -53,11 +54,11 @@ let certpath = path name <.> "crt" keypath = path name <.> "rsa" in ignoreIOErrAlt $ do - chain <- pemParseBS <$> BS.readFile certpath >>= \pem -> return $ case pem of + chain <- (\case Right pems -> case decodeCertificateChain . CertificateChainRaw $ map pemContent pems of Right chain -> Just chain - _ -> Nothing - _ -> Nothing + _ -> Nothing + _ -> Nothing) . pemParseBS <$> BS.readFile certpath key <- (PrivKeyRSA <$>) . readMay <$> readFile keypath return $ liftA2 ClientCert chain key @@ -102,7 +103,7 @@ cert return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey) -{- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for +{- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for -- gemini, we should use this? import qualified Data.ByteArray as BA diff --git a/ClientSessionManager.hs b/ClientSessionManager.hs --- a/ClientSessionManager.hs +++ b/ClientSessionManager.hs @@ -15,17 +15,17 @@ , lookupClientSession ) where -import Control.Concurrent -import Data.Map (fromAscList, toAscList) -import Network.TLS +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 Data.Hourglass (timeAdd) +import Time.System (timeCurrent) +import Time.Types (Elapsed (..), Seconds (..)) -import qualified Data.Map as Map +import qualified Data.Map as Map -import Fingerprint +import Fingerprint type ClientSessions = MVar (Map.Map (HostName, Maybe Fingerprint) (Elapsed, (SessionID, SessionData))) diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -8,9 +8,9 @@ -- 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 CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} module Command ( commands @@ -21,15 +21,15 @@ , 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 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 qualified Data.Text.Lazy as T -import ANSIColour +import ANSIColour commands :: Bool -> [String] commands restricted = metaCommands ++ navCommands ++ infoCommands ++ @@ -40,7 +40,7 @@ infoCommands = ["show", "page", "uri", "links", "mime"] unsafeActionCommands = ["save", "view", "browse", "!", "|", "||", "||-"] safeActionCommands = ["cat"] - actionCommands True = safeActionCommands + actionCommands True = safeActionCommands actionCommands False = unsafeActionCommands ++ safeActionCommands otherCommands = ["commands", "log", "repl", "alias", "set", "at"] @@ -453,7 +453,6 @@ -- 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 @@ -472,6 +471,6 @@ applyIf ansi (withColourStr col) str c | c `elem` cs -> showMinPrefix ansi cs c t | t `elem` topics -> showMinPrefix ansi (cs ++ topics) t - _ -> twixt + _ -> '{' : twixt ++ "}" in pre <> sub <> expandHelp' post | otherwise = s diff --git a/CommandLine.hs b/CommandLine.hs --- a/CommandLine.hs +++ b/CommandLine.hs @@ -9,7 +9,7 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} module CommandLine ( CommandLine(..) @@ -21,14 +21,14 @@ , 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) +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 @@ -48,9 +48,9 @@ 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' + mapM resolveElemsSpec ess >>= (\case + [] -> Left $ "No such " <> typeStr + as' -> return as') . concat where resolveElemsSpec (EsSElemSpec es) = maybeToList . atMay as <$> resolveES es @@ -88,7 +88,7 @@ deriving (Eq,Ord,Show) data CommandArg = CommandArg - { commandArgArg :: String + { commandArgArg :: String , commandArgLiteralTail :: String } deriving (Eq,Ord,Show) diff --git a/Fingerprint.hs b/Fingerprint.hs --- a/Fingerprint.hs +++ b/Fingerprint.hs @@ -8,15 +8,15 @@ -- 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 +-- | 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 Data.ASN1.Types (ASN1Object) -import qualified Data.X509 as X +import qualified Data.ByteString as BS +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) diff --git a/GeminiProtocol.hs b/GeminiProtocol.hs --- a/GeminiProtocol.hs +++ b/GeminiProtocol.hs @@ -9,52 +9,58 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} 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 Control.Concurrent +import Control.Exception +import Control.Monad (guard, mplus, unless, when) +import Data.Default.Class (def) +import Data.Hourglass +import Data.List (intercalate, intersperse, + isPrefixOf, stripPrefix, transpose) +import Data.Maybe (fromMaybe) +import Data.X509 +import Data.X509.CertificateStore +import Data.X509.Validation hiding (Fingerprint (..), + getFingerprint) +import Network.Socket (AddrInfo (..), Socket, + SocketOption (..), SocketType (..), + 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 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 qualified Codec.MIME.Parse as MIME +import qualified Codec.MIME.Type 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 BoundedBSChan +import ClientCert +import ClientSessionManager +import Fingerprint +import Identity +import Mundanities +import Request +import ServiceCerts -import URI +import URI -import Data.Digest.DrunkenBishop +import Data.Digest.DrunkenBishop defaultGeminiPort :: Int defaultGeminiPort = 1965 @@ -126,9 +132,9 @@ 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 + -- ^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 @@ -140,9 +146,9 @@ 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 +-- |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 @@ -209,8 +215,8 @@ 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 + (defaultChecks { checkExhaustive = True , checkLeafV3 = False }) store cache service chain + if null errors || any isTrustError errors || null signedCerts then return errors else do ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredErrors @@ -224,20 +230,18 @@ 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 + -- |error pertaining to the tail certificate, to be ignored if the -- user explicitly trusts the certificate for this service. - isTrustableError LeafNotV3 = True + isTrustableError LeafNotV3 = True isTrustableError (NameMismatch _) = True - isTrustableError _ = False + isTrustableError _ = False tailSigned = head signedCerts tailFingerprint = fingerprint tailSigned - doTofu errors = if not . exists isTrustError $ errors + doTofu errors = if not . any isTrustError $ errors then return errors else do trust <- checkTrust $ filter isTrustableError errors @@ -261,16 +265,22 @@ [ "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 ] + displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ] return True else do displayInfo $ showChain signedCerts - trust <- case known of + let promptTrust def pprompt tprompt = do + p <- promptYN def pprompt + if p then return (True,True) else + (False,) <$> promptYN def tprompt + (saveCert,trust) <- case known of Nothing -> do displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ] warnErrors - promptYN (null errors) $ - "Trust provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" + let prompt = "provided certificate (" ++ + take 8 (fingerprintHex tailFingerprint) ++ ")?" + promptTrust (null errors) ("Permamently trust " ++ prompt) + ("Temporarily trust " ++ prompt) Just trustedSignedCert -> do currentTime <- timeConvert <$> timeCurrent let trustedCert = getCertificate trustedSignedCert @@ -290,9 +300,12 @@ ("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) $ + promptTrust (expired || samePubKey) + ("Permanently trust new certificate" <> + (if readOnly then "" else " (and delete old certificate)") <> "?") + ("Temporarily trust new certificate" <> + (if readOnly then "" else " (but keep old certificate)") <> "?") + when (saveCert && not readOnly) $ saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr return trust diff --git a/Identity.hs b/Identity.hs --- a/Identity.hs +++ b/Identity.hs @@ -12,19 +12,19 @@ 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 Control.Monad (guard, msum) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe +import Data.Maybe (mapMaybe) +import Safe +import System.Directory (listDirectory) -import ANSIColour -import ClientCert -import Prompt -import MetaString -import Mundanities +import ANSIColour +import ClientCert +import MetaString +import Mundanities +import Prompt data Identity = Identity { identityName :: String, identityCert :: ClientCert } deriving (Eq,Show) @@ -70,7 +70,7 @@ "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" <> ": " + let prompt = applyIf ansi (withColourStr Green) "Identity" <> ": " idName <- MaybeT $ promptLineWithCompletions prompt =<< listIdentities idsPath MaybeT $ getIdentity True ansi idsPath idName @@ -78,4 +78,4 @@ listIdentities path = mapMaybe stripCrtExt <$> ignoreIOErr (listDirectory path) where stripCrtExt s = case splitAt (length s - 4) s of (s', ".crt") -> Just s' - _ -> Nothing + _ -> Nothing diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.2 +VERSION=0.1.3 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa @@ -27,24 +27,27 @@ 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 +dist/diohsc-${VERSION}.tar.gz: *.hs README.md CHANGELOG.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.gmi: index.gmi.in + cat $< | sed 's/\$$VERSION/${VERSION}/g' > $@ -index.html: index.md - cat $< | sed s/README.md/README.html/g | sed 's/\$$VERSION/${VERSION}/g' | pandoc --ascii -f markdown -t html > $@ +index.html: index.gmi + cat $< | sed s/\.gmi/.html/g | ./tools/gmi2html.sed > $@ -%.gmi: %.md - md2gemini < $< > $@ +index.md: index.gmi + cat $< | sed s/\.gmi/.md/g | ./tools/gmi2md.sed > $@ -%.html: %.md - pandoc --ascii -f markdown -t html < $< > $@ +%.md: %.gmi + ./tools/gmi2md.sed < $< > $@ -publish: diohsc-${VERSION}-src.tgz index.gmi index.html README.md README.gmi README.html tutorial/diohsc-tutorial.cast tutorial/diohsc-tutorial.txt +%.html: %.gmi + ./tools/gmi2html.sed < $< > $@ + +publish: diohsc-${VERSION}-src.tgz index.gmi index.html README.md README.gmi README.html CHANGELOG.gmi CHANGELOG.md CHANGELOG.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 --- a/Marks.hs +++ b/Marks.hs @@ -8,26 +8,28 @@ -- 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 #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TupleSections #-} 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 Control.Exception (handle) +import Control.Monad (guard, msum) +import Data.Bifunctor (second) +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.ByteString as BS +import qualified Data.Map as Map +import qualified Data.Text as TS import qualified Data.Text.Encoding as TS -import Mundanities -import URI -import Util +import Mundanities +import URI +import Util data URIWithIdName = URIWithIdName { uriIdUri :: URI, uriIdId :: Maybe String } deriving (Eq,Show) @@ -62,7 +64,7 @@ loadMarks :: FilePath -> IO ([String], Marks) loadMarks path = - mapSnd Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path)) + second Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path)) where loadMark :: FilePath -> IO (Either String (String, URIWithIdName)) loadMark filename = diff --git a/MetaString.hs b/MetaString.hs --- a/MetaString.hs +++ b/MetaString.hs @@ -8,14 +8,14 @@ -- 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 #-} +{-# LANGUAGE 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 Data.String (IsString, fromString) import qualified Data.Text.Lazy as T class (Monoid a, IsString a) => MetaString a diff --git a/Mundanities.hs b/Mundanities.hs --- a/Mundanities.hs +++ b/Mundanities.hs @@ -12,18 +12,18 @@ 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 Control.Applicative (Alternative, empty) +import Control.Monad.Catch (MonadMask, handle) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.Directory +import System.FilePath -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text.Lazy as T +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as TS +import qualified Data.Text.IO as TS +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 @@ -53,5 +53,5 @@ -- 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 + TS.readFile path >>= TS.writeFile path . TS.unlines . dropAllBut n . TS.lines where dropAllBut m as = drop (length as - m) as diff --git a/Opts.hs b/Opts.hs --- a/Opts.hs +++ b/Opts.hs @@ -12,9 +12,9 @@ module Opts (usage, parseArgs, Opt(..)) where -import System.Console.GetOpt +import System.Console.GetOpt -import Version +import Version data Opt = Restricted @@ -50,5 +50,5 @@ parseArgs :: [String] -> IO ([Opt],[String]) parseArgs argv = case getOpt Permute options argv of - (o,n,[]) -> return (o,n) + (o,n,[]) -> return (o,n) (_,_,errs) -> ioError (userError (concat errs ++ usage)) diff --git a/Pager.hs b/Pager.hs --- a/Pager.hs +++ b/Pager.hs @@ -12,19 +12,19 @@ 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 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 qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as T -import ANSIColour -import Prompt +import ANSIColour +import Prompt printLinesPaged :: Int -> Int -> Int -> [T.Text] -> IO [String] printLinesPaged wrapCol termWidth perpage diff --git a/Prompt.hs b/Prompt.hs --- a/Prompt.hs +++ b/Prompt.hs @@ -19,19 +19,19 @@ , 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 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 +import ANSIColour +import Util defaultInputSettings :: HL.Settings IO defaultInputSettings = (HL.defaultSettings :: HL.Settings IO) {HL.complete = HL.noCompletion} diff --git a/README.gmi b/README.gmi new file mode 100644 --- /dev/null +++ b/README.gmi @@ -0,0 +1,56 @@ +# 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/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,82 +0,0 @@ -# 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 --- a/Request.hs +++ b/Request.hs @@ -12,12 +12,13 @@ module Request where -import Data.List (elemIndices) -import Data.Maybe (fromMaybe) -import Safe (lastMay, readMay) -import System.FilePath (FilePath) +import Data.List (elemIndices) +import Data.Maybe (fromMaybe) +import Safe (lastMay, readMay) +import System.FilePath (FilePath) -import URI (URI, escapePathString, nullUri, parseAbsoluteUri) +import URI (URI, escapePathString, nullUri, + parseAbsoluteUri) data Host = Host {hostName :: String, hostPort :: Int} deriving (Eq,Ord,Show) diff --git a/RunExternal.hs b/RunExternal.hs --- a/RunExternal.hs +++ b/RunExternal.hs @@ -12,24 +12,24 @@ 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 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 +import ANSIColour +import Mundanities +import Prompt +import Util --- |Wrapper to ensure we don't accidentally allow use of shell commands in +-- |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) @@ -45,11 +45,11 @@ where -- |based on specification for $BROWSER in 'man 1 man' subPercent :: String -> State Bool String - subPercent "" = return [] + 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 + subPercent (c:s) = (c:) <$> subPercent s confirmShell :: String -> String -> IO Bool confirmShell desc cmd = promptYN True False $ diff --git a/ServiceCerts.hs b/ServiceCerts.hs --- a/ServiceCerts.hs +++ b/ServiceCerts.hs @@ -8,20 +8,22 @@ -- 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 #-} + module ServiceCerts where -import Data.List (elemIndex) -import Data.PEM -import Data.X509 -import Data.X509.Validation -import System.FilePath +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 qualified Data.ByteString as BS +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS -import Mundanities -import Util +import Mundanities +import Util serviceToString :: ServiceID -> String serviceToString (host, suffix) = host ++ TS.unpack (TS.decodeUtf8 suffix) @@ -36,12 +38,11 @@ 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 + in ignoreIOErrAlt $ (\case Right [PEM _ _ content] -> case decodeSignedCertificate content of Right cert -> Just cert - _ -> Nothing - _ -> Nothing + _ -> Nothing + _ -> Nothing) . pemParseBS <$> BS.readFile filepath saveServiceCert :: FilePath -> ServiceID -> SignedCertificate -> IO () saveServiceCert path service cert = diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Slurp.hs b/Slurp.hs --- a/Slurp.hs +++ b/Slurp.hs @@ -10,17 +10,17 @@ 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 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 as BS import qualified Data.ByteString.Lazy as BL --- incorporate lazy IO into a bytestring such that it will print progress as +-- 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 diff --git a/TextGemini.hs b/TextGemini.hs --- a/TextGemini.hs +++ b/TextGemini.hs @@ -9,17 +9,17 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} module TextGemini where -import Control.Monad.State -import Data.Maybe (catMaybes, mapMaybe) +import Control.Monad.State +import Data.Maybe (catMaybes, mapMaybe) -import ANSIColour +import ANSIColour -import qualified Data.Text.Lazy as T -import URI +import qualified Data.Text.Lazy as T +import URI data Link = Link { linkUri :: URIRef, linkDescription :: T.Text } deriving (Eq,Ord,Show) @@ -43,7 +43,7 @@ extractLinks (GeminiDocument ls) = mapMaybe linkOfLine ls where linkOfLine (LinkLine _ link) = Just link - linkOfLine _ = Nothing + linkOfLine _ = Nothing data PreOpt = PreOptAlt @@ -52,13 +52,13 @@ deriving (Eq,Ord,Show) showPreOpt :: PreOpt -> String -showPreOpt PreOptAlt = "alt" -showPreOpt PreOptPre = "pre" +showPreOpt PreOptAlt = "alt" +showPreOpt PreOptPre = "pre" showPreOpt PreOptBoth = "both" data GemRenderOpts = GemRenderOpts - { grOptsAnsi :: Bool - , grOptsPre :: PreOpt + { grOptsAnsi :: Bool + , grOptsPre :: PreOpt , grOptsWrapWidth :: Int } deriving (Eq,Ord,Show) @@ -74,7 +74,7 @@ | 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 + -- |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 = [] @@ -132,8 +132,8 @@ 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 + -- ^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 diff --git a/URI.hs b/URI.hs --- a/URI.hs +++ b/URI.hs @@ -9,7 +9,7 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} module URI ( URI @@ -35,13 +35,13 @@ , uriQuery ) where -import Control.Monad (mplus) -import Data.Char (toLower) -import Data.List (dropWhileEnd) -import Data.Maybe (isNothing) -import Safe (readMay) +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 +import qualified Network.URI as NU defaultScheme :: String defaultScheme = "gemini" @@ -129,18 +129,18 @@ , NU.relativeTo ref' uri2 == uri1 = ref' | otherwise = ref fixDots ref = case NU.uriPath ref of - "" -> ref { NU.uriPath = "." } + "" -> ref { NU.uriPath = "." } "../" -> ref { NU.uriPath = ".." } - _ -> ref + _ -> ref uriRegName :: URI -> Maybe String uriRegName = (NU.uriRegName <$>) . NU.uriAuthority . uriUri uriPort :: URI -> Maybe Int -uriPort = (readPort =<<) . (NU.uriPort <$>) . NU.uriAuthority . uriUri +uriPort = (readPort . NU.uriPort) <=< (NU.uriAuthority . uriUri) where readPort (':':n) = readMay n - readPort _ = Nothing + readPort _ = Nothing escapePathString :: String -> String escapePathString = NU.escapeURIString (\c -> NU.isUnreserved c || c == '/') diff --git a/Util.hs b/Util.hs --- a/Util.hs +++ b/Util.hs @@ -8,11 +8,11 @@ -- 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) +import Control.Monad (unless, when) -- nice tip from one joeyh: whenM,unlessM,(>>?),(>>!) :: Monad m => m Bool -> m () -> m () @@ -23,17 +23,6 @@ -- 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 --- a/Version.hs +++ b/Version.hs @@ -16,4 +16,4 @@ programName = "diohsc" version :: String -version = "0.1.2" +version = "0.1.3" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,107 +1,116 @@ -name: diohsc -version: 0.1.2 -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, CHANGELOG.md - +cabal-version: >=1.10 +name: diohsc +version: 0.1.3 +license: GPL-3 +license-file: COPYING +maintainer: mbays@sdf.org +author: Martin Bays +homepage: https://mbays.sdf.org/diohsc +synopsis: Gemini client description: - Line-based command-oriented interactive client for the gemini protocol. + Line-based command-oriented interactive client for the gemini protocol. +category: Browser +build-type: Simple +extra-source-files: + README.gmi + THANKS + diohscrc.sample + Makefile + diohsc.1.md + CHANGELOG.gmi + source-repository head - type: git + type: git location: https://repo.or.cz/diohsc.git -Flag Libiconv - Description: On windows: use libiconv for charset conversion +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 + default: False + manual: True +flag magic + description: Use libmagic to determine mimetypes of local files + default: False + 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: + main-is: diohsc.hs + 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 < 2.8 - if flag(Magic) - CPP-Options: -DMAGIC - build-depends: - magic < 1.2 - if ! os(windows) || flag(Libiconv) - CPP-Options: -DICONV + 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 build-depends: - iconv < 0.5 + base >=4.3 && <5, + asn1-types >=0.3.4 && <0.4, + bytestring >=0.10.4.0 && <0.11, + containers >=0.5.5.1 && <0.7, + cryptonite >=0.26 && <0.28, + data-default-class >=0.1.2.0 && <0.2, + data-hash >=0.2.0.1 && <0.3, + directory >=1.2.1.0 && <1.4, + drunken-bishop >=0.1.0.0 && <0.2, + exceptions >=0.10.4 && <0.11, + filepath >=1.3.0.2 && <1.5, + haskeline ==0.8.*, + hourglass >=0.2.12 && <0.3, + mime >=0.4.0.2 && <0.5, + mtl >=2.1.3.1 && <2.3, + network >=2.4.2.3 && <3.2, + network-uri >=2.6.3.0 && <2.8, + parsec >=3.1.5 && <3.2, + pem >=0.2.4 && <0.3, + process >=1.2.0.0 && <1.7, + regex-compat >=0.95.1 && <0.96, + safe >=0.3.19 && <0.4, + temporary ==1.3.*, + terminal-size >=0.3.2.1 && <0.4, + text >=1.1.0.0 && <1.3, + tls >=1.5.4 && <1.6, + transformers >=0.3.0.0 && <0.6, + x509 >=1.7.5 && <1.8, + x509-store >=1.6.7 && <1.7, + x509-validation >=1.6.11 && <1.7 + + if os(windows) + cpp-options: -DWINDOWS + + else + build-depends: unix >=2.7.0.1 && <2.8 + + if flag(magic) + cpp-options: -DMAGIC + build-depends: magic <1.2 + + if (!os(windows) || flag(libiconv)) + cpp-options: -DICONV + build-depends: iconv >=0.4.1.3 && <0.5 diff --git a/diohsc.hs b/diohsc.hs --- a/diohsc.hs +++ b/diohsc.hs @@ -8,75 +8,81 @@ -- 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 #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} 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 Control.Applicative (Alternative, empty) +import Control.Monad ((<=<)) +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, matchRegex, + mkRegexWithOpts) +import Time.System (timeCurrentP) +import Time.Types (ElapsedP) -import qualified Data.ByteString.Lazy as BL +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 Codec.MIME.Parse as MIME +import qualified Codec.MIME.Type as MIME +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as TS +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding 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 ANSIColour +import ActiveIdentities +import Alias 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 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 Request +import RunExternal hiding (runRestrictedIO) import qualified RunExternal -import Slurp -import TextGemini -import Util -import Version -import URI +import Slurp +import TextGemini +import URI +import Util +import Version #ifndef WINDOWS -import System.Posix.Files (setFileMode, ownerModes) +import System.Posix.Files (ownerModes, setFileMode) #endif #ifdef ICONV -import Codec.Text.IConv (convert) +import Codec.Text.IConv (convert) #endif #ifdef MAGIC @@ -85,13 +91,13 @@ -- |Immutable options set at startup data ClientOptions = ClientOptions - { cOptUserDataDir :: FilePath - , cOptInteractive :: Bool - , cOptAnsi :: Bool + { cOptUserDataDir :: FilePath + , cOptInteractive :: Bool + , cOptAnsi :: Bool , cOptRestrictedMode :: Bool - , cOptGhost :: Bool + , cOptGhost :: Bool , cOptRequestContext :: RequestContext - , cOptLogH :: Maybe Handle + , cOptLogH :: Maybe Handle } data HistoryChild = HistoryChild @@ -105,12 +111,12 @@ } data HistoryItem = HistoryItem - { historyRequest :: Request - , historyRequestTime :: ElapsedP - , historyMimedData :: MimedData + { historyRequest :: Request + , historyRequestTime :: ElapsedP + , historyMimedData :: MimedData , historyGeminatedMimedData :: MimedData -- ^generated with lazy IO - , historyParent :: Maybe HistoryItem - , historyChild :: Maybe HistoryChild + , historyParent :: Maybe HistoryItem + , historyChild :: Maybe HistoryChild } historyUri :: HistoryItem -> URI @@ -128,7 +134,7 @@ historyDescendants :: HistoryItem -> [HistoryItem] historyDescendants i = case historyChild i of - Nothing -> [] + Nothing -> [] Just (HistoryChild i' _) -> i' : historyDescendants i' pathItemByUri :: HistoryItem -> URI -> Maybe HistoryItem @@ -137,13 +143,13 @@ 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 + , clientConfProxies :: M.Map String Host + , clientConfGeminators :: [(String,(Regex,String))] + , clientConfRenderFilter :: Maybe String + , clientConfPreOpt :: PreOpt + , clientConfMaxLogLen :: Int + , clientConfMaxWrapWidth :: Int + , clientConfNoConfirm :: Bool } defaultClientConfig :: ClientConfig @@ -151,21 +157,21 @@ data QueueItem = QueueItem { queueOrigin :: Maybe HistoryOrigin - , queueUri :: URI + , queueUri :: URI } data ClientState = ClientState - { clientCurrent :: Maybe HistoryItem - , clientJumpBack :: Maybe HistoryItem - , clientLog :: BStack.BStack T.Text - , clientVisited :: S.Set Hash - , clientQueue :: [QueueItem] + { 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 + , clientMarks :: Marks + , clientSessionMarks :: M.Map Int HistoryItem + , clientAliases :: Aliases + , clientQueuedCommands :: [String] + , clientConfig :: ClientConfig } type ClientM = StateT ClientState IO @@ -269,7 +275,7 @@ endState <- (`execStateT` initState) . HL.runInputT hlSettings $ lineClient clientOptions initialCommands closeLog logH - -- |reread file rather than just writing clientLog, in case another instance has also + -- |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 @@ -314,7 +320,7 @@ addToQueueFromFile :: ClientM () addToQueueFromFile | ghost = return () - | otherwise = (enqueue Nothing =<<) . liftIO . ignoreIOErr $ doesPathExist queueFile >>= \case + | otherwise = enqueue Nothing <=< (liftIO . ignoreIOErr) $ doesPathExist queueFile >>= \case True -> catMaybes . (queueLine <$>) <$> readFileLines queueFile <* removeFile queueFile where queueLine :: T.Text -> Maybe QueueItem @@ -388,13 +394,13 @@ targetUri :: Target -> URI targetUri (TargetHistory item) = historyUri item -targetUri (TargetFrom _ uri) = uri -targetUri (TargetIdUri _ uri) = uri -targetUri (TargetUri uri) = uri +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 +targetQueueItem i = QueueItem Nothing $ targetUri i handleCommandLine :: ClientOptions -> ClientState -> CommandLine -> ClientM () handleCommandLine @@ -407,7 +413,7 @@ appendCArgs (c',as') = (c', (appendTail <$> as') ++ args) where appendTail arg@(CommandArg a' t') = case args of - [] -> arg + [] -> arg (CommandArg _ t : _) -> CommandArg a' $ t' <> " " <> t in handleCommandLine' (mt' `mplus` mt) $ (appendCArgs <$> mcas') `mplus` mcas'' @@ -415,9 +421,9 @@ 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 + -- 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`. @@ -476,15 +482,15 @@ 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 + (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 + Just b -> show $ relativeFrom uri b in fromString (applyIf ansi' (withColourStr col) s) <> case idAtUri ais uri of - Nothing -> "" + Nothing -> "" Just ident -> showIdentity ansi' ident displayUri :: MetaString a => URI -> a @@ -538,10 +544,10 @@ unknownCommand s = "Unknown command \"" <> s <> "\". Type \"help\" for help." addTargetId :: Target -> MaybeT ClientM () addTargetId (TargetIdUri idName uri) = - (requestOfUri uri,) <$> liftIO (loadIdentity idsPath idName) >>= \case + 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 + (Just req, Just ident) -> lift $ addIdentity req ident) . (requestOfUri uri,) addTargetId _ = return () resolveTarget :: PTarget -> Either String [Target] @@ -566,16 +572,16 @@ resolveTarget (PTargetQueue specs) = (queueTarget <$>) <$> resolveElemsSpecs "queue item" (matchPatternOn $ show . queueUri) queue specs where - queueTarget (QueueItem Nothing uri) = TargetUri uri + queueTarget (QueueItem Nothing uri) = TargetUri uri queueTarget (QueueItem (Just o) uri) = TargetFrom o uri resolveTarget (PTargetRoot base) = (rootOf <$>) <$> resolveTarget base where rootOf :: Target -> Target - rootOf (TargetHistory item) = rootOfItem item + rootOf (TargetHistory item) = rootOfItem item rootOf (TargetFrom (HistoryOrigin item _) _) = rootOfItem item - rootOf t = t + rootOf t = t rootOfItem item = TargetHistory . lastDef item $ historyAncestors item resolveTarget (PTargetAncestors base specs) = @@ -607,8 +613,8 @@ let itemLinks = extractLinksMimed $ historyGeminatedMimedData item b = case historyChild item of Just (HistoryChild _ (Just b')) -> b' - _ | increasing -> -1 - _ -> length itemLinks + _ | 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 @@ -637,7 +643,7 @@ relTarget t = TargetUri . relativeTo ref $ targetUri t resolveTarget (PTargetAbs s) = case parseUriAsAbsolute $ escapeQueryPart s of - Nothing -> Left $ "Failed to parse URI: " <> s + Nothing -> Left $ "Failed to parse URI: " <> s Just uri -> return [TargetUri uri] resolveLinkSpecs :: Bool -> HistoryItem -> [(Int,Link)] -> ElemsSpecs -> Either String [Target] @@ -648,14 +654,13 @@ 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 + in resolveElemsSpecs "link" isMatch slice specs >>= (\case + [] -> Left "No such link" + targs -> return targs) . catMaybes . (linkTarg <$>) matchPattern :: String -> String -> Bool matchPattern patt = - let regex = mkRegexWithOpts patt True (exists isUpper patt) - exists f = not . all (not . f) + let regex = mkRegexWithOpts patt True (any isUpper patt) in isJust . matchRegex regex matchPatternOn :: (a -> String) -> String -> a -> Bool @@ -683,7 +688,7 @@ 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 + [] -> doPage . map (T.pack . expand) $ helpText CommandArg s _ : _ -> doPage . map (T.pack . expand) $ helpOn s handleCommand [] ("commands",_) = doPage $ T.pack . expand <$> commandHelpText where @@ -901,7 +906,7 @@ lift . printErr $ "Path " ++ show fullpath ++ " exists and is directory" mzero lift (doesFileExist fullpath) >>? - guard =<< not <$> lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?") + guard . not =<< lift (promptYN False $ "Overwrite " ++ show fullpath ++ "?") lift $ do putStrLn $ "Saving to " ++ fullpath t0 <- timeCurrentP @@ -939,7 +944,7 @@ setCurr :: HistoryItem -> ClientM () setCurr i = - let isJump = isNothing $ historyUri <$> curr >>= pathItemByUri i + let isJump = isNothing $ curr >>= pathItemByUri i . historyUri in do when isJump $ modify $ \s -> s { clientJumpBack = curr } modify $ \s -> s { clientCurrent = Just i } @@ -962,13 +967,12 @@ 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 + | Just req <- requestOfUri uri = addToLog uri >> doRequest redirs req | otherwise = printErr $ "Bad URI: " ++ displayUri uri ++ ( let scheme = uriScheme uri in if scheme /= "gemini" && isNothing (M.lookup scheme proxies) @@ -1006,9 +1010,9 @@ warningStr = colour BoldRed ais <- gets clientActiveIdentities proceed <- (isJust <$>) . lift . runMaybeT $ do - when crossSite . (guard =<<) . liftIO . promptYN False $ + when crossSite . guard <=< (liftIO . promptYN False) $ warningStr "Follow cross-site redirect to " ++ showUriRefFull ansi ais uri to ++ warningStr "?" - when crossScheme . (guard =<<) . liftIO . promptYN False $ + 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 @@ -1107,7 +1111,7 @@ 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 + extractCharsetParam _ = Nothing charset = TS.unpack . fromMaybe "utf-8" . msum . map extractCharsetParam $ MIME.mimeParams mime isUtf8 = map toLower charset `elem` ["utf-8", "utf8"] #ifdef ICONV