diff --git a/BStack.hs b/BStack.hs --- a/BStack.hs +++ b/BStack.hs @@ -19,7 +19,7 @@ import qualified Data.Sequence as S import Prelude hiding (truncate) -data BStack a = BStack (Seq a) Int +data BStack a = BStack { stack :: Seq a, size :: Int } fromList :: [a] -> BStack a fromList as = BStack (S.fromList as) $ length as diff --git a/ClientState.hs b/ClientState.hs --- a/ClientState.hs +++ b/ClientState.hs @@ -11,7 +11,6 @@ module ClientState where import Control.Monad.State (StateT, modify) -import Data.Hash (Hash) import Text.Regex (Regex) import qualified Data.Map as M @@ -48,7 +47,7 @@ { clientCurrent :: Maybe HistoryItem , clientJumpBack :: Maybe HistoryItem , clientLog :: BStack.BStack T.Text - , clientVisited :: S.Set Hash + , clientVisited :: S.Set Int , clientQueues :: QueueMap , clientActiveIdentities :: ActiveIdentities , clientMarks :: Marks diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -320,7 +320,7 @@ [ "{set} {link_desc_first} true: show link description before uri" , "{set} {link_desc_first} false: show uri before link description" ] "log_length" -> - [ "{set} {log_length} N: set number of items to store in log" + [ "{set} {log_length} N: set approximate number of items to store in log" , "{set} {log_length} 0: clear log and disable logging" , "See also: {log}" ] "max_wrap_width" -> diff --git a/LineClient.hs b/LineClient.hs --- a/LineClient.hs +++ b/LineClient.hs @@ -26,7 +26,7 @@ import Data.Bifunctor (second) import qualified Data.ByteString.Lazy as BL import Data.Char (toLower) -import Data.Hash (hash) +import Data.Hashable (hash) import Data.IORef (modifyIORef, newIORef, readIORef) import Data.List (intercalate, isPrefixOf, isSuffixOf, sort, stripPrefix) @@ -269,7 +269,7 @@ bold = applyIf ansi withBoldStr isVisited :: URI -> Bool - isVisited uri = S.member (hash $ show uri) visited + isVisited uri = S.member (hash . T.pack $ show uri) visited requestOfUri = requestOfProxiesAndUri proxies @@ -310,7 +310,7 @@ let t = T.pack $ show uri modify $ \s -> s { clientLog = BStack.push maxLogLen t $ clientLog s - , clientVisited = S.insert (hash $ show uri) $ clientVisited s } + , clientVisited = S.insert (hash . T.pack $ show uri) $ clientVisited s } unless ghost . liftIO $ maybe (return ()) (ignoreIOErr . (`T.hPutStrLn` t)) logH preprocessQuery :: String -> ClientM String @@ -402,10 +402,11 @@ handleCommand [] ("mark", []) = let ms = M.toAscList marks - markLine (m, uriId) = let m' = showMinPrefix ansi (fst <$> ms) m + markLine (m, Just uriId) = let m' = showMinPrefix ansi (fst <$> ms) m in T.pack $ "'" <> m' <> replicate (max 1 $ 16 - visibleLength (T.pack m')) ' ' <> showUriWithId uriId + markLine (m, Nothing) = T.pack $ "'" <> m <> " [Failed to read mark]" in doPage $ markLine <$> ms handleCommand [] ("inventory",_) = do ais <- gets clientActiveIdentities diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -VERSION=0.1.14 +VERSION=0.1.14.1 GHCOPTS=-threaded -DICONV -DMAGIC -ignore-package regex-compat-tdfa diff --git a/Marks.hs b/Marks.hs --- a/Marks.hs +++ b/Marks.hs @@ -9,19 +9,16 @@ -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Safe #-} {-# LANGUAGE TupleSections #-} module Marks where -import Control.Exception (handle) import Control.Monad (guard, msum) -import Data.Bifunctor (second) import Data.Char (isAlphaNum) -import Data.Either (partitionEithers) import Data.List (isPrefixOf) import System.Directory import System.FilePath +import System.IO.Unsafe (unsafeInterleaveIO) import qualified Data.ByteString as BS import qualified Data.Map as Map @@ -49,34 +46,29 @@ return . URIWithIdName uri . Just $ TS.unpack idName , (`URIWithIdName` Nothing) <$> (parseUriAsAbsolute . escapeIRI $ TS.unpack s) ] -type Marks = Map.Map String URIWithIdName +type Marks = Map.Map String (Maybe URIWithIdName) emptyMarks :: Marks emptyMarks = Map.empty lookupMark :: String -> Marks -> Maybe URIWithIdName lookupMark s marks = do - (s',uriId) <- Map.lookupGE s marks + (s', Just uriId) <- Map.lookupGE s marks guard $ s `isPrefixOf` s' return uriId insertMark :: String -> URIWithIdName -> Marks -> Marks -insertMark = Map.insert +insertMark s = Map.insert s . Just -loadMarks :: FilePath -> IO ([String], Marks) +loadMarks :: FilePath -> IO Marks loadMarks path = - second Map.fromList . partitionEithers <$> (mapM loadMark =<< ignoreIOErr (listDirectory path)) + (Map.fromList <$>) $ mapM lazyKeyVal =<< ignoreIOErr (listDirectory path) where - loadMark :: FilePath -> IO (Either String (String, URIWithIdName)) + lazyKeyVal f = (f,) <$> unsafeInterleaveIO (loadMark f) + loadMark :: FilePath -> IO (Maybe 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 + in ignoreIOErrAlt $ readUriWithId . TS.strip . TS.decodeUtf8 <$> BS.readFile filepath markNameValid :: String -> Bool markNameValid = all isAlphaNum @@ -88,7 +80,7 @@ saveMark _ _ _ = pure () marksWithUri :: URI -> Marks -> [(String,URIWithIdName)] -marksWithUri uri = Map.toList . Map.filter ((==uri) . uriIdUri) +marksWithUri uri = Map.toList . Map.filter ((==uri) . uriIdUri) . Map.mapMaybe id tempMarks :: [String] tempMarks = (:[]) <$> ['0'..'9'] diff --git a/ResolveTarget.hs b/ResolveTarget.hs --- a/ResolveTarget.hs +++ b/ResolveTarget.hs @@ -13,7 +13,7 @@ module ResolveTarget (resolveTarget) where import Data.Char (isUpper) -import Data.Hash (hash) +import Data.Hashable (hash) import Data.Maybe import Safe import Text.Regex (matchRegex, mkRegexWithOpts) @@ -158,6 +158,6 @@ matchPatternOn f patt = matchPattern patt . f isVisited :: URI -> Bool - isVisited uri = S.member (hash $ show uri) visited + isVisited uri = S.member (hash . T.pack $ show uri) visited loggedUris = catMaybes $ (parseAbsoluteUri . escapeIRI . T.unpack <$>) $ BStack.toList cLog 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.14" +version = "0.1.14.1" diff --git a/diohsc.cabal b/diohsc.cabal --- a/diohsc.cabal +++ b/diohsc.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: diohsc -version: 0.1.14 +version: 0.1.14.1 license: GPL-3 license-file: COPYING maintainer: mbays@sdf.org @@ -26,11 +26,9 @@ flag libiconv description: - On windows: use libiconv for charset conversion - (iconv is always used on POSIX systems, with no need for this flag) + Use libiconv for charset conversion - default: False - manual: True + default: True flag magic description: Use libmagic to determine mimetypes of local files @@ -94,7 +92,7 @@ containers >=0.5.5.1 && <0.7, cryptonite >=0.26 && <0.31, data-default-class >=0.1.2.0 && <0.2, - data-hash >=0.2.0.1 && <0.3, + hashable >= 1.1 && <1.5, directory >=1.2.1.0 && <1.4, drunken-bishop >=0.1.0.0 && <0.2, exceptions >=0.10.4 && <0.11, @@ -135,6 +133,6 @@ if flag(irilinks) cpp-options: -DIRILinks - if (!os(windows) || flag(libiconv)) + if 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 @@ -12,14 +12,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Main where import Control.Monad.Catch import Control.Monad.State -import Data.Hash (hash) +import Data.Hashable (hash) import Data.Maybe +import Data.Semigroup (Any (..)) import qualified Data.Set as S import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as T @@ -30,6 +32,7 @@ import System.Exit import System.FilePath import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) import qualified BStack @@ -64,13 +67,15 @@ outTerm <- hIsTerminalDevice stdout let ansi = NoAnsi `notElem` opts && (outTerm || Ansi `elem` opts) - let argCommands (ScriptFile "-") = warnIOErrAlt $ + let argCommands :: Opt -> IO (Any, [String]) + argCommands (ScriptFile "-") = ((Any True,) <$>) . 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 repl = (null optCommands && Batch `notElem` opts) || Prompt `elem` opts + argCommands (ScriptFile f) = ((Any True,) <$>) . warnIOErrAlt $ + (T.unpack <$>) <$> readFileLines f + argCommands (OptCommand c) = return (Any True, [c]) + argCommands _ = return (Any False, []) + (Any commandsInOpts, optCommands) <- mconcat <$> mapM argCommands opts + let repl = (not commandsInOpts && Batch `notElem` opts) || Prompt `elem` opts let interactive = Batch `notElem` opts && (repl || Interactive `elem` opts) let argToUri arg = doesPathExist arg >>= \case @@ -102,16 +107,16 @@ (listToMaybe [ h | SocksHost h <- opts ]) . fromMaybe "1080" $ listToMaybe [ p | SocksPort p <- opts ] - requestContext <- initRequestContext callbacks userDataDir ghost socksProxy - (warnings, marks) <- loadMarks marksPath - displayWarning warnings + requestContext <- unsafeInterleaveIO $ initRequestContext callbacks userDataDir ghost socksProxy + marks <- unsafeInterleaveIO $ loadMarks marksPath 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 + logLines <- reverse <$> readFileLines logPath + let cLog = BStack.fromList logLines + let visited = S.fromList $ hash <$> logLines let openLog :: IO (Maybe Handle) openLog = ignoreIOErrAlt $ Just <$> do @@ -130,6 +135,9 @@ endState <- (`execStateT` initState) . HL.runInputT hlSettings $ lineClient clientOptions initialCommands repl 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 + let maxlen = clientConfMaxLogLen $ clientConfig endState + curlen = BStack.size $ clientLog endState + when (not ghost && curlen > maxlen + maxlen `div` 10) . warnIOErr $ + -- |reread file rather than just writing clientLog, in case + -- another instance has also been appending to the log. + truncateToEnd maxlen logPath